Index: /LMDZ4/branches/LMDZ4-dev-20091210/000-README =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/000-README (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/000-README (revision 1280) @@ -0,0 +1,20 @@ + +Logiciel LMDZ +------------- + +La documentation relative à LMDZ est accessible sur : +http://lmdz.lmd.jussieu.fr/documentation + +Les quides d'installation et utilisation de LMDZ sont accessibles sur : +http://lmdz.lmd.jussieu.fr/documentation/guides + +========================================================================== + +LMDZ software +------------- + +Documentation about the LMDZ software is available on the web at this address: +http://lmdz.lmd.jussieu.fr/documentation + +Practical installation and user guides are available here: +http://lmdz.lmd.jussieu.fr/documentation/guides Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-AMD64_CICLAD.fcm =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-AMD64_CICLAD.fcm (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-AMD64_CICLAD.fcm (revision 1280) @@ -0,0 +1,15 @@ +%COMPILER /usr/lib64/openmpi/1.2.8-pgf/bin/mpif90 +%LINK /usr/lib64/openmpi/1.2.8-pgf/bin/mpif90 +%AR ar +%MAKE gmake +%FPP_FLAGS -P -traditional +%FPP_DEF NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM +%BASE_FFLAGS -i4 -r8 +%PROD_FFLAGS -O2 -Munroll -Mnoframe -Mautoinline -Mcache_align +%DEV_FFLAGS -Mbounds +%DEBUG_FFLAGS -g -traceback -Mbounds -Mchkfpstk -Mchkstk -Ktrap=denorm,divz,ovf,unf +%MPI_FFLAGS +%OMP_FFLAGS -mp +%BASE_LD -lblas +%MPI_LD -L/usr/lib64/openmpi/1.2.8-pgf/lib +%OMP_LD -mp Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-AMD64_CICLAD.path =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-AMD64_CICLAD.path (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-AMD64_CICLAD.path (revision 1280) @@ -0,0 +1,10 @@ +NETCDF_LIBDIR=/opt/netcdf/pgf/lib +NETCDF_INCDIR=/opt/netcdf/pgf/include +IOIPSL_INCDIR=$LMDGCM/../../lib +IOIPSL_LIBDIR=$LMDGCM/../../lib +ORCH_INCDIR=$LMDGCM/../../lib +ORCH_LIBDIR=$LMDGCM/../../lib +OASIS_INCDIR=$LMDGCM/../../prism/SX/build/lib/psmile.$couple +OASIS_LIBDIR=$LMDGCM/../../prism/SX/lib +INCA_LIBDIR=$LMDGCM/../INCA3/config/lib +INCA_INCDIR=$LMDGCM/../INCA3/config/lib Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-ES_MOON.fcm =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-ES_MOON.fcm (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-ES_MOON.fcm (revision 1280) @@ -0,0 +1,17 @@ +%COMPILER esmpif90 +%LINK esmpif90 +%AR esar +%MAKE gmake +%FPP_FLAGS -P -traditional +%FPP_DEF NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_MATHKEISAN +%BASE_FFLAGS -P stack -Wf,-pvctl res=whole,-A dbl4,-ptr byte -EP -R5 -float0 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume" +%PROD_FFLAGS -C vopt +%DEV_FFLAGS -C vsafe -gv -Wf,-init stack=nan,-init heap=nan +%DEBUG_FFLAGS -C debug -eC -Wf,-init stack=nan,-init heap=nan +%MPI_FFLAGS +%OMP_FFLAGS -P openmp +%BASE_LD -lblas -lfft +%MPI_LD +%OMP_LD -P openmp -Wl,"-ZL 3G" + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-ES_MOON.path =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-ES_MOON.path (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-ES_MOON.path (revision 1280) @@ -0,0 +1,11 @@ +NETCDF_LIBDIR=/S/home010/c0010/ES/lib +NETCDF_INCDIR=/S/home010/c0010/ES/include +IOIPSL_INCDIR=$LMDGCM/../../lib +IOIPSL_LIBDIR=$LMDGCM/../../lib +ORCH_INCDIR=$LMDGCM/../../lib +ORCH_LIBDIR=$LMDGCM/../../lib +OASIS_INCDIR=$LMDGCM/../../prism/ES/build/lib/psmile.$couple +OASIS_LIBDIR=$LMDGCM/../../prism/ES/lib +INCA_LIBDIR=$LMDGCM/../INCA3/config/lib +INCA_INCDIR=$LMDGCM/../INCA3/config/lib +LIBPREFIX=sx Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-IA64_PLATINE.fcm =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-IA64_PLATINE.fcm (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-IA64_PLATINE.fcm (revision 1280) @@ -0,0 +1,15 @@ +%COMPILER mpif90 +%LINK mpif90 +%AR ar +%MAKE gmake +%FPP_FLAGS -P -traditional +%FPP_DEF NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_MKL +%BASE_FFLAGS -i4 -r8 -automatic -align all -I/applications/intel/mkl/10.0.1.014/include +%PROD_FFLAGS -O3 +%DEV_FFLAGS -p -g -O3 -traceback +%DEBUG_FFLAGS -p -g -traceback +%MPI_FFLAGS +%OMP_FFLAGS -openmp +%BASE_LD -p -i4 -r8 -automatic -L/applications/intel/mkl/10.0.1.014/lib/64 -lmkl_intel_lp64 -lmkl_sequential -lmkl_core -lpthread -lguide +%MPI_LD +%OMP_LD -openmp Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-IA64_PLATINE.path =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-IA64_PLATINE.path (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-IA64_PLATINE.path (revision 1280) @@ -0,0 +1,11 @@ +NETCDF_LIBDIR='/usr/lib -lnetcdff' +NETCDF_INCDIR=/usr/include +IOIPSL_INCDIR=$LMDGCM/../../lib +IOIPSL_LIBDIR=$LMDGCM/../../lib +ORCH_INCDIR=$LMDGCM/../../lib +ORCH_LIBDIR=$LMDGCM/../../lib +OASIS_INCDIR=$LMDGCM/../../prism/IA64/build/lib/psmile.$couple +OASIS_LIBDIR=$LMDGCM/../../prism/IA64/lib +INCA_LIBDIR=$LMDGCM/../INCA3/config/lib +INCA_INCDIR=$LMDGCM/../INCA3/config/lib + Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-PW6_VARGAS.fcm =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-PW6_VARGAS.fcm (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-PW6_VARGAS.fcm (revision 1280) @@ -0,0 +1,15 @@ +%COMPILER xlf_r +%LINK mpxlf_r +%AR ar +%MAKE gmake +%FPP_FLAGS -P +%FPP_DEF NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM +%BASE_FFLAGS -qautodbl=dbl4 -qxlf90=autodealloc +%PROD_FFLAGS -O5 +%DEV_FFLAGS -O2 -qfullpath -qinitauto=7FBFFFFF -qfloat=nans -qflttrap=overflow:zerodivide:invalid:enable -qsigtrap +%DEBUG_FFLAGS -g -qfullpath -qnooptimize -qinitauto=7FBFFFFF -qfloat=nans -qflttrap=overflow:zerodivide:invalid:enable -qsigtrap +%MPI_FFLAGS -I/usr/lpp/ppe.poe/include/thread64 +%OMP_FFLAGS -qsmp=omp +%BASE_LD -lessl +%MPI_LD +%OMP_LD -qsmp=omp Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-PW6_VARGAS.path =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-PW6_VARGAS.path (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-PW6_VARGAS.path (revision 1280) @@ -0,0 +1,10 @@ +NETCDF_LIBDIR=/usr/local/pub/NetCDF/3.6.3/lib +NETCDF_INCDIR=/usr/local/pub/NetCDF/3.6.3/include +IOIPSL_INCDIR=$LMDGCM/../../lib +IOIPSL_LIBDIR=$LMDGCM/../../lib +ORCH_INCDIR=$LMDGCM/../../lib +ORCH_LIBDIR=$LMDGCM/../../lib +OASIS_INCDIR=$LMDGCM/../../prism/AIX6/build/lib/psmile.$couple +OASIS_LIBDIR=$LMDGCM/../../prism/AIX6/lib +INCA_LIBDIR=$LMDGCM/../INCA3/config/lib +INCA_INCDIR=$LMDGCM/../INCA3/config/lib Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_BRODIE.fcm =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_BRODIE.fcm (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_BRODIE.fcm (revision 1280) @@ -0,0 +1,16 @@ +%COMPILER sxmpif90 +%LINK sxmpif90 +%AR sxar +%MAKE make +%FPP_FLAGS -P -traditional +%FPP_DEF NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_MATHKEISAN +%BASE_FFLAGS -P stack -Wf,-pvctl res=whole,-A dbl4,-ptr byte -EP -R5 -float0 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume" +%PROD_FFLAGS -C vopt +%DEV_FFLAGS -C vsafe -gv -Wf,-init stack=nan,-init heap=nan +%DEBUG_FFLAGS -C debug -eR -Wf,-init stack=nan,-init heap=nan +%MPI_FFLAGS +%OMP_FFLAGS -P openmp +%BASE_LD -lblas -lfft +%MPI_LD +%OMP_LD -P openmp -Wl,"-ZL 3G" + Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_BRODIE.opt =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_BRODIE.opt (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_BRODIE.opt (revision 1280) @@ -0,0 +1,12 @@ +%INLINE -pi auto exp=swtt1_lmdar4,swtt_lmdar4,swde_lmdar4,lwttm_lmdar4,lwtt_lmdar4,swr_lmdar4,swclr_lmdar4 noexp=SW_LMDAR4,SWU_LMDAR4,SW1S_LMDAR4,SW2S_LMDAR4,LW_LMDAR4,LWU_LMDAR4,LWBV_LMDAR4,LWC_LMDAR4,LWB_LMDAR4,LWV_LMDAR4,LWVB_LMDAR4,LWVD_LMDAR4,LWVN_LMDAR4 line=2000 + +bld::tool::fflags::phys::readaerosol %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt -pi auto +bld::tool::fflags::phys::aeropt_2bands %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR +bld::tool::fflags::phys::radiation_AR4 %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt -Wf,-O,extendreorder %INLINE +bld::tool::fflags::phys::radiation_AR4_param %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt %INLINE +bld::tool::fflags::phys::fisrtilp %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::phys::cv30_routines %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -Wf,-O,extendreorder +bld::tool::fflags::phys::cvltr %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::phys::clouds_gno %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::dyn::vlsplt_p %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::dyn::groupeun_p %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_BRODIE.path =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_BRODIE.path (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_BRODIE.path (revision 1280) @@ -0,0 +1,10 @@ +NETCDF_LIBDIR=/SXlocal/pub/netCDF/3.6.1-openmp/lib +NETCDF_INCDIR=/SXlocal/pub/netCDF/3.6.1-openmp/include +IOIPSL_INCDIR=$LMDGCM/../../lib +IOIPSL_LIBDIR=$LMDGCM/../../lib +ORCH_INCDIR=$LMDGCM/../../lib +ORCH_LIBDIR=$LMDGCM/../../lib +OASIS_INCDIR=$LMDGCM/../../prism/SX/build/lib/psmile.$couple +OASIS_LIBDIR=$LMDGCM/../../prism/SX/lib +INCA_LIBDIR=$LMDGCM/../INCA3/config/lib +INCA_INCDIR=$LMDGCM/../INCA3/config/lib Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_MERCURE.fcm =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_MERCURE.fcm (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_MERCURE.fcm (revision 1280) @@ -0,0 +1,15 @@ +%COMPILER sxmpif90 +%LINK sxmpif90 +%AR sxar +%MAKE make +%FPP_FLAGS -P -traditional +%FPP_DEF NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_MATHKEISAN +%BASE_FFLAGS -P stack -Wf,-pvctl res=whole,-A dbl4,-ptr byte -EP -R5 -float0 -size_t64 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume" +%PROD_FFLAGS -C vopt +%DEV_FFLAGS -C vsafe -gv -Wf,-init stack=nan,-init heap=nan +%DEBUG_FFLAGS -C debug -eC -Wf,-init stack=nan,-init heap=nan +%MPI_FFLAGS +%OMP_FFLAGS -P openmp +%BASE_LD -size_t64 -lblas -lfft +%MPI_LD +%OMP_LD -P openmp -Wl,"-ZL 3G" Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_MERCURE.opt =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_MERCURE.opt (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_MERCURE.opt (revision 1280) @@ -0,0 +1,12 @@ +%INLINE -pi auto exp=swtt1_lmdar4,swtt_lmdar4,swde_lmdar4,lwttm_lmdar4,lwtt_lmdar4,swr_lmdar4,swclr_lmdar4 noexp=SW_LMDAR4,SWU_LMDAR4,SW1S_LMDAR4,SW2S_LMDAR4,LW_LMDAR4,LWU_LMDAR4,LWBV_LMDAR4,LWC_LMDAR4,LWB_LMDAR4,LWV_LMDAR4,LWVB_LMDAR4,LWVD_LMDAR4,LWVN_LMDAR4 line=2000 + +bld::tool::fflags::phys::readaerosol %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt -pi auto +bld::tool::fflags::phys::aeropt_2bands %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR +bld::tool::fflags::phys::radiation_AR4 %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt -Wf,-O,extendreorder %INLINE +bld::tool::fflags::phys::radiation_AR4_param %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt %INLINE +bld::tool::fflags::phys::fisrtilp %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::phys::cv30_routines %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -Wf,-O,extendreorder +bld::tool::fflags::phys::cvltr %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::phys::clouds_gno %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::dyn::vlsplt_p %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::dyn::groupeun_p %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_MERCURE.path =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_MERCURE.path (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX8_MERCURE.path (revision 1280) @@ -0,0 +1,10 @@ +NETCDF_LIBDIR=${NETCDF_SX_LIBDIR:-/usr/local/SX8/soft/netcdf/lib} +NETCDF_INCDIR=${NETCDF_SX_INCLUDEDIR:-/usr/local/SX8/soft/netcdf/include} +IOIPSL_INCDIR=$LMDGCM/../../lib +IOIPSL_LIBDIR=$LMDGCM/../../lib +ORCH_INCDIR=$LMDGCM/../../lib +ORCH_LIBDIR=$LMDGCM/../../lib +OASIS_INCDIR=$LMDGCM/../../prism/SX/build/lib/psmile.$couple +OASIS_LIBDIR=$LMDGCM/../../prism/SX/lib +INCA_LIBDIR=$LMDGCM/../INCA3/config/lib +INCA_INCDIR=$LMDGCM/../INCA3/config/lib Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX9_MERCURE.fcm =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX9_MERCURE.fcm (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX9_MERCURE.fcm (revision 1280) @@ -0,0 +1,15 @@ +%COMPILER sxmpif90 +%LINK sxmpif90 +%AR sxar +%MAKE make +%FPP_FLAGS -P -traditional +%FPP_DEF NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_MATHKEISAN +%BASE_FFLAGS -P stack -Wf,-pvctl res=whole,-A dbl4,-ptr byte -EP -R2 -float0 -size_t64 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume" +%PROD_FFLAGS -C vopt -pi expin=%SRC_PATH/%DYN/cray.F exp=ssum,scopy +%DEV_FFLAGS -C vsafe -gv -Wf,-init stack=nan,-init heap=nan +%DEBUG_FFLAGS -C debug -eC -Wf,-init stack=nan,-init heap=nan +%MPI_FFLAGS +%OMP_FFLAGS -P openmp +%BASE_LD -size_t64 -lblas -lfft +%MPI_LD +%OMP_LD -P openmp -Wl,"-ZL 3G" Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX9_MERCURE.opt =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX9_MERCURE.opt (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX9_MERCURE.opt (revision 1280) @@ -0,0 +1,12 @@ +%INLINE -pi auto exp=swtt1_lmdar4,swtt_lmdar4,swde_lmdar4,lwttm_lmdar4,lwtt_lmdar4,swr_lmdar4,swclr_lmdar4 noexp=SW_LMDAR4,SWU_LMDAR4,SW1S_LMDAR4,SW2S_LMDAR4,LW_LMDAR4,LWU_LMDAR4,LWBV_LMDAR4,LWC_LMDAR4,LWB_LMDAR4,LWV_LMDAR4,LWVB_LMDAR4,LWVD_LMDAR4,LWVN_LMDAR4 line=2000 + +bld::tool::fflags::phys::readaerosol %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt -pi auto +bld::tool::fflags::phys::aeropt_2bands %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR +bld::tool::fflags::phys::radiation_AR4 %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt -Wf,-O,extendreorder %INLINE +bld::tool::fflags::phys::radiation_AR4_param %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt %INLINE +bld::tool::fflags::phys::fisrtilp %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::phys::cv30_routines %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -Wf,-O,extendreorder +bld::tool::fflags::phys::cvltr %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::phys::clouds_gno %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::dyn::vlsplt_p %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::dyn::groupeun_p %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX9_MERCURE.path =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX9_MERCURE.path (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-SX9_MERCURE.path (revision 1280) @@ -0,0 +1,10 @@ +NETCDF_LIBDIR=${NETCDF_SX_LIBDIR:-/ccc/applications/sx9/netcdf-3.6.1/lib} +NETCDF_INCDIR=${NETCDF_SX_INCLUDEDIR:-/ccc/applications/sx9/netcdf-3.6.1/include} +IOIPSL_INCDIR=$LMDGCM/../../lib +IOIPSL_LIBDIR=$LMDGCM/../../lib +ORCH_INCDIR=$LMDGCM/../../lib +ORCH_LIBDIR=$LMDGCM/../../lib +OASIS_INCDIR=$LMDGCM/../../prism/SX/build/lib/psmile.$couple +OASIS_LIBDIR=$LMDGCM/../../prism/SX/lib +INCA_LIBDIR=$LMDGCM/../INCA3/config/lib +INCA_INCDIR=$LMDGCM/../INCA3/config/lib Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-X64_TITANE.fcm =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-X64_TITANE.fcm (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-X64_TITANE.fcm (revision 1280) @@ -0,0 +1,15 @@ +%COMPILER mpif90 +%LINK mpif90 +%AR ar +%MAKE gmake +%FPP_FLAGS -P -traditional +%FPP_DEF NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_MKL +%BASE_FFLAGS -i4 -r8 -automatic -align all -I${MKLROOT}/include +%PROD_FFLAGS -O3 +%DEV_FFLAGS -p -g -O3 -traceback -fp-stack-check -ftrapuv +%DEBUG_FFLAGS -p -g -traceback +%MPI_FFLAGS +%OMP_FFLAGS -openmp +%BASE_LD -p -i4 -r8 -automatic -L/applications/intel/mkl/10.1.1.019/lib/em64t -lmkl_intel_lp64 -lmkl_sequential -lmkl_core -lpthread -lguide +%MPI_LD +%OMP_LD -openmp Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-X64_TITANE.path =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-X64_TITANE.path (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-X64_TITANE.path (revision 1280) @@ -0,0 +1,11 @@ +NETCDF_LIBDIR="$NETCDF_LIBDIR -lnetcdff" +NETCDF_INCDIR=$NETCDF_INCLUDEDIR +IOIPSL_INCDIR=$LMDGCM/../../lib +IOIPSL_LIBDIR=$LMDGCM/../../lib +ORCH_INCDIR=$LMDGCM/../../lib +ORCH_LIBDIR=$LMDGCM/../../lib +OASIS_INCDIR=$LMDGCM/../../prism/IA64/build/lib/psmile.$couple +OASIS_LIBDIR=$LMDGCM/../../prism/IA64/lib +INCA_LIBDIR=$LMDGCM/../INCA3/config/lib +INCA_INCDIR=$LMDGCM/../INCA3/config/lib + Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-linux-32bit.fcm =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-linux-32bit.fcm (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-linux-32bit.fcm (revision 1280) @@ -0,0 +1,15 @@ +%COMPILER pgf90 +%LINK pgf90 +%AR ar +%MAKE make +%FPP_FLAGS -P -traditional +%FPP_DEF +%BASE_FFLAGS +%PROD_FFLAGS -fast +%DEV_FFLAGS -g +%DEBUG_FFLAGS -g +%MPI_FFLAGS +%OMP_FFLAGS +%BASE_LD -Wl,-Bstatic -L/usr/lib/gcc-lib/i386-linux/2.95.2 +%MPI_LD +%OMP_LD Index: /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-linux-32bit.path =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-linux-32bit.path (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/arch/arch-linux-32bit.path (revision 1280) @@ -0,0 +1,6 @@ +NETCDF_LIBDIR=/usr/local/netcdf-pgi/lib +NETCDF_INCDIR=/usr/local/netcdf-pgi/include +IOIPSL_INCDIR=/usr/local/guez/modipsl/lib +IOIPSL_LIBDIR=/usr/local/guez/modipsl/lib +ORCH_INCDIR=/u/fairhead/modipsl_ioipsl_3/lib +ORCH_LIBDIR=/u/fairhead/modipsl_ioipsl_3/lib Index: /LMDZ4/branches/LMDZ4-dev-20091210/bld.cfg =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/bld.cfg (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/bld.cfg (revision 1280) @@ -0,0 +1,103 @@ +# ----------------------- FCM extract configuration file ----------------------- +cfg::type bld +cfg::version 1.0 + + +# ------------------------------------------------------------------------------ +# Build information +# ------------------------------------------------------------------------------ + +#Default value of FPP fortran preprocessor +%FPP cpp + +inc arch.fcm +inc config.fcm + +%CONFIG_NAME %{ARCH}%SUFF_NAME +%BASE_CONFIG_PATH %LIBO/%CONFIG_NAME +%CONFIG_PATH %BASE_CONFIG_PATH/.config +%SRC_PATH %LIBF + +%FFLAGS %BASE_FFLAGS %COMPIL_FFLAGS %PARA_FFLAGS +%LD_FLAGS %BASE_LD %PARA_LD + +src::dyn %SRC_PATH/%DYN +src::phys %SRC_PATH/%PHYS +src::grid %SRC_PATH/grid +src::filtrez %SRC_PATH/filtrez +src::bibio %SRC_PATH/bibio +src::cosp %SRC_PATH/cosp + +bld::lib::dyn %DYN +bld::lib::phys %PHYS +bld::lib::grid grid +bld::lib::filtrez filtrez +bld::lib::bibio bibio + + +bld::outfile_ext::exe %SUFF_NAME.e +bld::target lib%{DYN}.a lib%{PHYS}.a libgrid.a libfiltrez.a libbibio.a +bld::target %EXEC%SUFF_NAME.e +bld::exe_dep %{DYN} %{PHYS} grid filtrez bibio cosp + + +dir::root %CONFIG_PATH +dir::lib %BASE_CONFIG_PATH +dir::bin %ROOT_PATH/bin + +#search_src 1 + +bld::tool::fpp %FPP +bld::tool::fc %COMPILER +bld::tool::ld %LINK +bld::tool::ar %AR +bld::tool::make %MAKE +bld::tool::fflags %FFLAGS %INCDIR +bld::tool::ldflags %LD_FLAGS %LIB + +bld::tool::cppflags %FPP_FLAGS %INCDIR +bld::tool::fppflags %FPP_FLAGS %INCDIR +bld::tool::fppkeys %CPP_KEY %FPP_DEF + + +#bld::tool::fflags::phys::readaerosol %BASE_FFLAGS %PROD_FFLAGS %INCDIR -C hopt -pi auto +#bld::tool::fflags::phys::aeropt_2bands %BASE_FFLAGS %PROD_FFLAGS %INCDIR +#bld::tool::fflags::phys::radiation_AR4 %BASE_FFLAGS %PROD_FFLAGS1 %INCDIR -C hopt -Wf,-O,extendreorder +#bld::tool::fflags::phys::radiation_AR4_param %BASE_FFLAGS %PROD_FFLAGS1 %INCDIR -C hopt -f3 +#bld::tool::fflags::phys::fisrtilp %BASE_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +#bld::tool::fflags::phys::cv30_routines %BASE_FFLAGS %PROD_FFLAGS %INCDIR -Wf,-O,extendreorder +#bld::tool::fflags::phys::cvltr %BASE_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +#bld::tool::fflags::phys::clouds_gno %BASE_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +#bld::tool::fflags::dyn::vlsplt_p %BASE_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +#bld::tool::fflags::dyn::groupeun_p %BASE_FFLAGS %PROD_FFLAGS %INCDIR -C hopt + + +inc arch.opt + +# Pre-process code before analysing dependencies +bld::pp 1 + + +# Ignore the following dependencies +bld::excl_dep inc::netcdf.inc +bld::excl_dep use::netcdf +bld::excl_dep use::typesizes +bld::excl_dep h::netcdf.inc +bld::excl_dep h::mpif.h +bld::excl_dep inc::mpif.h +bld::excl_dep use::ioipsl +bld::excl_dep use::intersurf +bld::excl_dep use::mod_prism_proto +bld::excl_dep use::mod_prism_def_partition_proto +bld::excl_dep use::mod_prism_get_proto +bld::excl_dep use::mod_prism_put_proto +bld::excl_dep use::mkl_dfti + +# Don't generate interface files +bld::tool::geninterface none + +# Allow ".inc" as an extension for CPP include files +bld::infile_ext::inc CPP::INCLUDE + +# extension for module output +bld::outfile_ext::mod .mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/build_gcm =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/build_gcm (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/build_gcm (revision 1280) @@ -0,0 +1,24 @@ +#!/bin/csh + +if ( -f '.lock' ) then + echo 'ATTENTION: vous etes sans doute en train de compiler le modele par ailleurs' + echo "Attendez que la premiere compilation soit terminee pour relancer la suivante." + echo "Si vous etes sur que vous ne compilez pas le modele par ailleurs," + echo vous pouvez continuer en repondant oui. + echo "Voulez-vous vraiment continuer?" + + if ( $< == "oui" ) then + + else + exit + endif +else + echo "compilation en cours..." > '.lock' +endif + +#set arch=$1 + + +fcm build + +\rm -f '.lock' Index: /LMDZ4/branches/LMDZ4-dev-20091210/cosp_input_nl.txt =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/cosp_input_nl.txt (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/cosp_input_nl.txt (revision 1280) @@ -0,0 +1,104 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +! Namelist that sets up the main COSP options +&COSP_INPUT + CMOR_NL='./cmor/cosp_cmor_nl.txt', ! CMOR namelist + NPOINTS=9026,! Number of gridpoints (klon dans LMDZi : ici correspond a klon de 96x95) + NPOINTS_IT=10000,! Max number of gridpoints to be processed in one iteration + NCOLUMNS=20, ! Number of subcolumns + NLEVELS=39, ! Number of model levels + USE_VGRID=.true., ! Use fixed vertical grid for outputs? (if .true. then you need to define number of levels with Nlr) + NLR=40, ! Number of levels in statistical outputs (only used if USE_VGRID=.true.) + CSAT_VGRID=.true., ! CloudSat vertical grid? (if .true. then the CloudSat standard grid is used for the outputs. + ! USE_VGRID needs also be .true.) + FINPUT='histday.nc', ! NetCDF file with 1D inputs +! FINPUT='cosp_input_um_2d.nc', ! NetCDF file with 2D inputs + !---------------------------------------------------------------------------------- + !--------------- Inputs related to radar simulations + !---------------------------------------------------------------------------------- + RADAR_FREQ=94.0, ! CloudSat radar frequency (GHz) + SURFACE_RADAR=0, ! surface=1, spaceborne=0 + use_mie_tables=0,! use a precomputed lookup table? yes=1,no=0 + use_gas_abs=1, ! include gaseous absorption? yes=1,no=0 + do_ray=0, ! calculate/output Rayleigh refl=1, not=0 + melt_lay=0, ! melting layer model off=0, on=1 + k2=-1, ! |K|^2, -1=use frequency dependent default + use_reff=.true., ! True if you want effective radius to be used by radar simulator (always used by lidar) + use_precipitation_fluxes=.true., ! True if precipitation fluxes are input to the algorithm + !---------------------------------------------------------------------------------- + !---------------- Inputs related to lidar simulations + !---------------------------------------------------------------------------------- + Nprmts_max_hydro=12, ! Max number of parameters for hydrometeor size distributions + Naero=1, ! Number of aerosol species (Not used) + Nprmts_max_aero=1, ! Max number of parameters for aerosol size distributions (Not used) + lidar_ice_type=0, ! Ice particle shape in lidar calculations (0=ice-spheres ; 1=ice-non-spherical) + OVERLAP=3, ! overlap type: 1=max, 2=rand, 3=max/rand + !---------------------------------------------------------------------------------- + !---------------- Inputs related to ISCCP simulator + !---------------------------------------------------------------------------------- + ISCCP_TOPHEIGHT=1, ! 1 = adjust top height using both a computed + ! infrared brightness temperature and the visible + ! optical depth to adjust cloud top pressure. Note + ! that this calculation is most appropriate to compare + ! to ISCCP data during sunlit hours. + ! 2 = do not adjust top height, that is cloud top + ! pressure is the actual cloud top pressure + ! in the model + ! 3 = adjust top height using only the computed + ! infrared brightness temperature. Note that this + ! calculation is most appropriate to compare to ISCCP + ! IR only algortihm (i.e. you can compare to nighttime + ! ISCCP data with this option) + ISCCP_TOPHEIGHT_DIRECTION=1, ! direction for finding atmosphere pressure level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! 1 = find the *lowest* altitude (highest pressure) level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! 2 = find the *highest* altitude (lowest pressure) level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! ONLY APPLICABLE IF top_height EQUALS 1 or 3 + ! 1 = default setting, and matches all versions of + ! ISCCP simulator with versions numbers 3.5.1 and lower + ! 2 = experimental setting + !---------------------------------------------------------------------------------- + !-------------- RTTOV inputs + !---------------------------------------------------------------------------------- + Platform=1, ! satellite platform + Satellite=15, ! satellite + Instrument=0, ! instrument + Nchannels=8, ! Number of channels to be computed + Channels=1,3,5,6,8,10,11,13, ! Channel numbers (please be sure that you supply Nchannels) + Surfem=0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0, ! Surface emissivity (please be sure that you supply Nchannels) + ZenAng=50.0, ! Satellite Zenith Angle + CO2=5.241e-04, ! Mixing ratios of trace gases + CH4=9.139e-07, + N2O=4.665e-07, + CO=2.098e-07 +/ + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/cosp_output_nl.txt =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/cosp_output_nl.txt (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/cosp_output_nl.txt (revision 1280) @@ -0,0 +1,63 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! Namelist that sets up output-related variables. It controls +! the instrument simulators to run and the list of variables +! to be written to file +&COSP_OUTPUT + ! Simulator flags + Lradar_sim=.false., + Llidar_sim=.true., + Lisccp_sim=.true., + Lmisr_sim=.false., + ! Output variables + Lalbisccp=.true., + Latb532=.true., + Lboxptopisccp=.true., + Lboxtauisccp=.true., + Lcfad_dbze94=.false., + Lcfad_lidarsr532=.true., + Lclcalipso=.true., + Lclhcalipso=.true., + Lclisccp2=.true., + Lcllcalipso=.true., + Lclmcalipso=.true., + Lcltcalipso=.true., + Lctpisccp=.true., + Ldbze94=.false., + Ltauisccp=.true., + Ltclisccp=.true., + Llongitude=.false., + Llatitude=.false., + Lparasol_refl=.true., + LclMISR=.false., + Lmeantbisccp=.true., + Lmeantbclrisccp=.true., + ! Use lidar and radar + Lclcalipso2=.false., + Lcltlidarradar=.false., + ! These are provided for debugging or special purposes + Lfrac_out=.false., + Lbeta_mol532=.true., +/ Index: /LMDZ4/branches/LMDZ4-dev-20091210/create_make_gcm =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/create_make_gcm (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/create_make_gcm (revision 1280) @@ -0,0 +1,253 @@ +#!/bin/sh +# +# $Header$ +# +#set -xv +machine=`hostname` +os=`uname` +gcm=`pwd` +libf=$gcm/libf +libo=$gcm/libo +CRAY=0 +if [ "$machine" = "atlas" -o "$machine" = "etoile" -o "$machine" = "axis" ] ; then + CRAY=1 +fi +XNEC=0 +if [ "$machine" = "rhodes" ] ; then + XNEC=1 +fi +X6NEC=0 +if [ "$machine" = "mercure" ] ; then + X6NEC=1 +fi +X8BRODIE=0 +if [ "$machine" = "brodie" ] ; then + X8BRODIE=1 +fi +VPP=0 +if [ "$machine" = "nymphea0" ] ; then + VPP=1 +fi +# +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo "# Definitions de Macros pour Make" +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo +echo "# Repertoires :" +echo +echo "GCM = "$gcm +echo 'LIBF = $(GCM)/libf' +if [ "$CRAY" = '0' ] ; then +# echo 'LIBO = $(GCM)/libo/$(MACHINE)' + echo 'LIBO = $(LIBOGCM)/$(MACHINE)' +else + echo 'LIBO = $(GCM)/libo' +fi +#echo 'LOCAL_DIR=$(GCM)' +#echo $localdir +echo "LOCAL_DIR=`echo $localdir`" +echo 'BIBIO = $(LIBF)/bibio' +echo "FILTRE = filtre" +echo "PHYS = " +echo "DYN = dyn " +echo 'LIBPHY = $(LIBO)/libphy$(PHYS).a' +echo 'DIRMAIN=dyn$(DIM)d$(FLAG_PARA)' +echo 'RM=rm' +echo +echo "OPLINK = " +echo +echo '# Les differentes librairies pour l"edition des liens:' +echo +if ( [ "$XNEC" = '1' ] || [ "$X6NEC" = '1' ] || [ "$X8BRODIE" = '1' ] ) ; then + echo 'dyn3d = $(LIBO)/libsxdyn3d.a $(LIBO)/libsx$(FILTRE).a' + echo 'dyn3dpar = $(LIBO)/libsxdyn3dpar.a $(LIBO)/libsx$(FILTRE).a' + echo 'dyn2d = $(LIBO)/libsxdyn2d.a' + echo 'dyn1d = $(LIBO)/libsxdyn1d.a' + echo 'L_DYN = -lsxdyn$(DIM)d$(FLAG_PARA)' + echo 'L_FILTRE = -lsx$(FILTRE)' + echo 'L_PHY = -lsxphy$(PHYS) ' + echo 'L_BIBIO = -lsxbibio' + echo 'L_ADJNT =' + echo 'L_COSP = -lsxcosp' +else + echo 'dyn3d = $(LIBO)/libdyn3d.a $(LIBO)/lib$(FILTRE).a' + echo 'dyn3dpar = $(LIBO)/libdyn3dpar.a $(LIBO)/lib$(FILTRE).a' + echo 'dyn2d = $(LIBO)/libdyn2d.a' + echo 'dyn1d = $(LIBO)/libdyn1d.a' + echo 'L_DYN = -ldyn$(DIM)d$(FLAG_PARA)' + echo 'L_FILTRE = -l$(FILTRE)' + echo 'L_PHY = -lphy$(PHYS) ' + echo 'L_BIBIO = -lbibio' + echo 'L_ADJNT =' + echo 'L_COSP = -lcosp' +fi + +echo +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo "# Option de compilation FORTRAN" +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo + echo 'COMPILE = $(F77) $(OPTIM) $(INCLUDE) -c' + echo 'COMPILE90 = $(F90) $(OPTIM90) $(INCLUDE) -c' + echo 'COMPTRU90 = $(F90) $(OPTIMTRU90) $(INCLUDE) -c' + echo "LINK = $LINK" + echo "AR = $AR" +echo +echo +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo "# Creation des differents executables" +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo +echo "# Executables:" +echo "# ------------" +echo +echo "PROG = code" +echo +#echo 'main : chimie $(DYN) bibio phys $(OPTION_DEP) ' +echo 'main : $(DYN) bibio phys $(OPTION_DEP) ' +echo ' cd $(LIBO) ; $(RANLIB) lib*.a ; cd $(GCM) ;\' +echo ' cd $(LOCAL_DIR); \' +echo ' $(COMPILE90) $(LIBF)/$(DIRMAIN)/$(PROG).F -o $(PROG).o ; \' +echo ' $(LINK) $(PROG).o -L$(LIBO) $(L_DYN) $(L_ADJNT) $(L_COSP) $(L_FILTRE) $(L_PHY) $(L_DYN) $(L_BIBIO) $(L_DYN) $(OPLINK) $(OPTION_LINK) -o $(LOCAL_DIR)/$(PROG).e ; $(RM) $(PROG).o ' +echo +echo 'dyn : $(LIBO)/libdyn$(DIM)d$(FLAG_PARA).a $(FILTRE)$(DIM)d' +echo +echo 'phys : $(LIBPHY)' +echo +#echo 'chimie : $(LIBO)/libchimie.a' +echo +echo 'bibio : $(LIBO)/libbibio.a' +echo +echo 'adjnt : $(LIBO)/libadjnt.a' +echo +echo 'cosp : $(LIBO)/libcosp.a' +echo +echo '$(FILTRE)3d : $(LIBO)/lib$(FILTRE).a' +echo +echo '$(FILTRE)2d :' +echo +echo '$(FILTRE)1d :' +echo +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo "# Contenu des differentes bibliotheques" +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo +echo +cd $libf >/dev/null 2>&1 +for diri in ` ls ` +do + if [ -d $diri ] ; then + if [ "`ls $diri/*.F`" != "" ] || [ "`ls $diri/*.F90`" != "" ] ; then + cd $diri >/dev/null 2>&1 + echo + listlib="" + for i in `ls *.F` + do + fili=`basename $i .F` + test=` ( head $i | grep ' PROGRAM' ) ` + if [ "$test" = "" ] ; then + listlib=$listlib" "$fili + fi + done + for i in `ls *.F90` + do + fili=`basename $i .F90` + test=` ( head $i | grep ' PROGRAM' ) ` + if [ "$test" = "" ] ; then + listlib=$listlib" "$fili + fi + done +# + echo + echo + echo "#=======================================================================" + echo "# Contenu de la bibliotheque correspondant au Directory "$diri + echo "#=======================================================================" + echo + for fili in $listlib + do + echo '$(LIBO)/lib'$diri".a : " '$(LIBO)/lib'$diri".a("$fili".o)" + echo + done + echo '.PRECIOUS : $(LIBO)/lib'$diri'.a' + echo + echo + echo "# Compilation des membres de la bibliotheque lib"$diri".a" + echo + for fili in $listlib + do + if [ -f $fili.F90 ] ; then + trufile=$fili.F90 + else + trufile=$fili.F + fi + F90=0 ; egrep -i '^ *use ' $trufile > /dev/null 2>&1 && F90=1 + egrep -i '^ *module ' $trufile > /dev/null 2>&1 && F90=1 + egrep -i '#include*.inc ' $trufile > /dev/null 2>&1 && F90=1 + str1='$(LIBO)/lib'$diri'.a('$fili'.o) : $(LIBF)/'$diri/$trufile + [ "$fili" = "chem.subs" ] && str1=$str1' $(LIBF)/'$diri/chem.mods.F + for stri in ` ( sed -n "/\#include/s/\#include//p" $trufile | sed 's/\"//g' ; egrep -i '^ *use ' $trufile | sed -e 's/,/ /' | awk ' { print $2 } ' ) ` + do + + +# Differents cas de dependance correspondant a des include ou des +# use module. +# soit dans le repertoire local soit dans un autre. + + stri=`echo $stri | tr [A-Z] [a-z]` + if [ -f $stri ] ; then + echo $str1 \\ + str1='$(LIBF)/'$diri'/'$stri + else + if [ -f $stri.F ] || [ -f $stri.F90 ] ; then + echo $str1 \\ + str1='$(LIBO)/lib'$diri'.a('$stri'.o)' + else + for dirinc in dyn3d grid bibio filtrez + do + if [ -f ../$dirinc/$stri ] ; then + echo $str1 \\ + str1='$(LIBF)/'`cd .. ; ls */$stri | head -1` + fi + if [ -f ../$dirinc/$stri.F90 ] ; then + echo $str1 \\ + str1='$(LIBO)/lib'$dirinc'.a('$stri'.o)' + fi + done + fi + fi + done + echo $str1 + if [ "$F90" -eq '0' ] ; then + echo ' cd $(LOCAL_DIR); \' + echo ' $(COMPILE) $(LIBF)/'$diri'/'$trufile' ; \' + else + echo ' cd $(LOCAL_DIR); \' + if [ -f $fili.F90 ] ; then + echo ' $(COMPTRU90) $(LIBF)/'$diri'/'$trufile' ; \' + else + echo ' $(COMPILE90) $(LIBF)/'$diri'/'$trufile' ; \' + fi + MODU=0; egrep -i '^ *module ' $trufile> /dev/null 2>&1 && MODU=1 + if [ "$MODU" -eq '1' -a "$CRAY" != '1' ] ; then + if [ "$os" = 'UNIX_System_V' ] ; then + echo ' cp $(MOD_LOC_DIR)/*.$(MOD_SUFFIX) $(LIBO)/ ; \' + else + echo ' mv $(MOD_LOC_DIR)/'$fili'.$(MOD_SUFFIX) $(LIBO)/'$fili'.$(MOD_SUFFIX) ; \' +# echo ' if [ "$(MOD_LOC_DIR)" ne "$(LIBO)" ] ; then mv $(MOD_LOC_DIR)/'*'.$(MOD_SUFFIX) $(LIBO) ; fi ; \' + fi + fi + fi + if ( [ "$XNEC" -eq '1' ] || [ "$X6NEC" = '1' ] || [ "$X8BRODIE" = '1' ] ) ; then + echo ' sxar r $(LIBO)/libsx'$diri'.a '$fili'.o ; \' + fi + echo ' $(AR) r $(LIBO)/lib'$diri'.a '$fili'.o ; $(RM) '$fili'.o ; \' + echo ' cd $(GCM)' + echo + done +# + echo + cd $libf + fi + fi +done Index: /LMDZ4/branches/LMDZ4-dev-20091210/gcm.def =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/gcm.def (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/gcm.def (revision 1280) @@ -0,0 +1,51 @@ +# +## $Id$ +# +## nombre de pas par jour (multiple de iperiod) +day_step=480 +## periode pour le pas Matsuno (en pas) +iperiod=5 +## periode de la dissipation (en pas) +idissip=5 +## choix de l'operateur de dissipation (star ou non star ) +lstardis=y +## nombre d'iterations de l'operateur de dissipation gradiv +nitergdiv=2 +## nombre d'iterations de l'operateur de dissipation nxgradrot +nitergrot=2 +## nombre d'iterations de l'operateur de dissipation divgrad +niterh=2 +## temps de dissipation des plus petites long.d ondes pour u,v (gradiv) +tetagdiv=10800. +## temps de dissipation des plus petites long.d ondes pour u,v(nxgradrot) +tetagrot=18000. +## temps de dissipation des plus petites long.d ondes pour h ( divgrad) +tetatemp=18000. +## coefficient pour gamdissip +coefdis=0. +## choix du shema d'integration temporelle (Matsuno ou Matsuno-leapfrog) +purmats=n +## physics type (0: none 1: phylmd,... 2: newtonian) +iflag_phys=1 +## periode de la physique (en pas) +iphysiq=10 +## longitude en degres du centre du zoom +clon=0. +## latitude en degres du centre du zoom +clat=0. +## facteur de grossissement du zoom,selon longitude +grossismx=1.0 +## facteur de grossissement du zoom ,selon latitude +grossismy=1.0 +## Fonction f(y) hyperbolique si = .true. , sinon sinusoidale +fxyhypb=y +## extension en longitude de la zone du zoom ( fraction de la zone totale) +dzoomx=0.0 +## extension en latitude de la zone du zoom ( fraction de la zone totale) +dzoomy=0.0 +##raideur du zoom en X +taux=3. +##raideur du zoom en Y +tauy=3. +## Fonction f(y) avec y = Sin(latit.) si = .true. , sinon y = latit. +ysinus=y Index: /LMDZ4/branches/LMDZ4-dev-20091210/guide.def =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/guide.def (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/guide.def (revision 1280) @@ -0,0 +1,37 @@ +ok_guide=y +# guidage sur niveaux modèle (y) ou standard +guide_modele=y +# inversion de l'ordre des niveaux verticaux +ok_invertp=y +ncep=y + ###################################### + #### guidage de u ##### + guide_u=y + ###################################### + #### guidage de v ##### + guide_v=y + ###################################### + #### guidage de T ##### + guide_T=y + ###################################### + #### guidage de P ##### + guide_P=n + ###################################### + #### guidage de Q (hr=y:hum.rel,n:hum.spec) ##### + guide_Q=n + guide_hr=n + ###################################### + ## guidage dans la couche limite + guide_BL=n + ###################################### +ini_anal=n +tau_min_u=0.04166667 +tau_max_u=0.125 +tau_min_v=0.04166667 +tau_max_v=0.125 +tau_min_T=0.04166667 +tau_max_T=10. +tau_min_Q=0.2 +tau_max_Q=10. +# gamma limité +gamma4=n Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/assert_eq_m.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/assert_eq_m.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/assert_eq_m.F90 (revision 1280) @@ -0,0 +1,70 @@ +! $Id$ +MODULE assert_eq_m + + implicit none + + INTERFACE assert_eq + MODULE PROCEDURE assert_eq2,assert_eq3,assert_eq4,assert_eqn + END INTERFACE + + private assert_eq2,assert_eq3,assert_eq4,assert_eqn + +CONTAINS + + FUNCTION assert_eq2(n1,n2,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, INTENT(IN) :: n1,n2 + INTEGER assert_eq2 + if (n1 == n2) then + assert_eq2=n1 + else + write (*,*) 'nrerror: an assert_eq failed with this tag: ', & + string + print *, 'program terminated by assert_eq2' + stop 1 + end if + END FUNCTION assert_eq2 + !BL + FUNCTION assert_eq3(n1,n2,n3,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, INTENT(IN) :: n1,n2,n3 + INTEGER assert_eq3 + if (n1 == n2 .and. n2 == n3) then + assert_eq3=n1 + else + write (*,*) 'nrerror: an assert_eq failed with this tag: ', & + string + print *, 'program terminated by assert_eq3' + stop 1 + end if + END FUNCTION assert_eq3 + !BL + FUNCTION assert_eq4(n1,n2,n3,n4,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, INTENT(IN) :: n1,n2,n3,n4 + INTEGER assert_eq4 + if (n1 == n2 .and. n2 == n3 .and. n3 == n4) then + assert_eq4=n1 + else + write (*,*) 'nrerror: an assert_eq failed with this tag: ', & + string + print *, 'program terminated by assert_eq4' + stop 1 + end if + END FUNCTION assert_eq4 + !BL + FUNCTION assert_eqn(nn,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, DIMENSION(:), INTENT(IN) :: nn + INTEGER assert_eqn + if (all(nn(2:) == nn(1))) then + assert_eqn=nn(1) + else + write (*,*) 'nrerror: an assert_eq failed with this tag: ', & + string + print *, 'program terminated by assert_eqn' + stop 1 + end if + END FUNCTION assert_eqn + +END MODULE assert_eq_m Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/assert_m.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/assert_m.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/assert_m.F90 (revision 1280) @@ -0,0 +1,69 @@ +! $Id$ +MODULE assert_m + + implicit none + + INTERFACE assert + MODULE PROCEDURE assert1,assert2,assert3,assert4,assert_v + END INTERFACE + + private assert1,assert2,assert3,assert4,assert_v + +CONTAINS + + SUBROUTINE assert1(n1,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, INTENT(IN) :: n1 + if (.not. n1) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + print *, 'program terminated by assert1' + stop 1 + end if + END SUBROUTINE assert1 + !BL + SUBROUTINE assert2(n1,n2,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, INTENT(IN) :: n1,n2 + if (.not. (n1 .and. n2)) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + print *, 'program terminated by assert2' + stop 1 + end if + END SUBROUTINE assert2 + !BL + SUBROUTINE assert3(n1,n2,n3,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, INTENT(IN) :: n1,n2,n3 + if (.not. (n1 .and. n2 .and. n3)) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + print *, 'program terminated by assert3' + stop 1 + end if + END SUBROUTINE assert3 + !BL + SUBROUTINE assert4(n1,n2,n3,n4,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, INTENT(IN) :: n1,n2,n3,n4 + if (.not. (n1 .and. n2 .and. n3 .and. n4)) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + print *, 'program terminated by assert4' + stop 1 + end if + END SUBROUTINE assert4 + !BL + SUBROUTINE assert_v(n,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, DIMENSION(:), INTENT(IN) :: n + if (.not. all(n)) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + print *, 'program terminated by assert_v' + stop 1 + end if + END SUBROUTINE assert_v + +END MODULE assert_m Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/formcoord.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/formcoord.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/formcoord.F (revision 1280) @@ -0,0 +1,54 @@ +! +! $Header$ +! + subroutine formcoord(unit,n,x,a,rev,text) + implicit none + integer n,unit,ndec + logical rev + real x(n),a + character*4 text + + integer i,id,i1,i2,in + real dx,dxmin + + if(rev) then + id=-1 + i1=n + i2=n-1 + in=1 + write(unit,3000) text(1:1) + else + id=1 + i1=1 + i2=2 + in=n + endif + + if (n.lt.2) then + ndec=1 + write(unit,1000) text,n,x(1)*a + else + dxmin=abs(x(2)-x(1)) + do i=2,n-1 + dx=abs(x(i+1)-x(i)) + if (dx.lt.dxmin) dxmin=dx + enddo + + ndec=-log10(dxmin)+2 + if(mod(n,6).eq.1) then + write(unit,1000) text,n,x(i1)*a + write(unit,2000) (x(i)*a,i=i2,in,id) + else + write(unit,1000) text,n + write(unit,2000) (x(i)*a,i=i1,in,id) + endif + endif + +1000 format(a4,2x,i4,' LEVELS',43x,f12.2) +2000 format(6f12.2) +c1000 format(a4,2x,i4,' LEVELS',43x,f12.) +c2000 format(6f12.) +3000 format('FORMAT ',a1,'REV') + return + + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/handle_err_m.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/handle_err_m.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/handle_err_m.F90 (revision 1280) @@ -0,0 +1,46 @@ +! $Id$ +module handle_err_m + + implicit none + +contains + + subroutine handle_err(message, ncerr, ncid, varid) + + use netcdf, only: nf90_strerror, nf90_noerr, nf90_close + + character(len=*), intent(in):: message + ! (should include name of calling procedure) + + integer, intent(in):: ncerr + + integer, intent(in), optional :: ncid + ! (Provide this argument if you want "handle_err" to try to close + ! the file.) + + integer, intent(in), optional :: varid + + ! Variable local to the procedure: + integer ncerr_close + + !------------------- + + if (ncerr /= nf90_noerr) then + print *, message, ":" + if (present(varid)) print *, "varid = ", varid + print *, trim(nf90_strerror(ncerr)) + if (present(ncid)) then + ! Try to close, to leave the file in a consistent state: + ncerr_close = nf90_close(ncid) + ! (do not call "nf95_close", we do not want to recurse) + if (ncerr_close /= nf90_noerr) then + print *, "nf90_close:" + print *, trim(nf90_strerror(ncerr_close)) + end if + end if + stop 1 + end if + + end subroutine handle_err + +end module handle_err_m Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/initdynav.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/initdynav.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/initdynav.F (revision 1280) @@ -0,0 +1,173 @@ +! +! $Id$ +! + subroutine initdynav(infile,day0,anne0,tstep,t_ops,t_wrt + . ,fileid) + +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + USE infotrac, ONLY : nqtot, ttext + + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL. Initialisation du fichier histoire moyenne. +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C infile: nom du fichier histoire a creer +C day0,anne0: date de reference +C tstep : frequence d'ecriture +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C +C Sortie: +C fileid: ID du fichier netcdf cree +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C Arguments +C + character*(*) infile + integer day0, anne0 + real tstep, t_ops, t_wrt + integer fileid + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL to work +C Variables locales +C + integer thoriid, zvertiid + integer tau0 + real zjulian + integer iq + real rlong(iip1,jjp1), rlat(iip1,jjp1) + integer ii,jj + integer zan, dayref +C +C Initialisations +C + pi = 4. * atan (1.) +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = anne0 + dayref = day0 + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + call histbeg(infile, iip1, rlong(:,1), jjp1, rlat(1,:), + . 1, iip1, 1, jjp1, + . tau0, zjulian, tstep, thoriid, fileid) + +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'sigss', 'Niveaux sigma','Pa', + . llm, nivsigs, zvertiid) +C +C Appels a histdef pour la definition des variables a sauvegarder +C +C Vents U +C + write(6,*)'inithistave',tstep + call histdef(fileid, 'u', 'vents u scalaires moyennes', + . 'm/s', iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + +C +C Vents V +C + call histdef(fileid, 'v', 'vents v scalaires moyennes', + . 'm/s', iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + +C +C Temperature +C + call histdef(fileid, 'temp', 'temperature moyennee', 'K', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Temperature potentielle +C + call histdef(fileid, 'theta', 'temperature potentielle', 'K', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + + +C +C Geopotentiel +C + call histdef(fileid, 'phi', 'geopotentiel moyenne', '-', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Traceurs +C + DO iq=1,nqtot + call histdef(fileid, ttext(iq), ttext(iq), '-', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + enddo +C +C Masse +C + call histdef(fileid, 'masse', 'masse', 'kg', + . iip1, jjp1, thoriid, 1, 1, 1, -99, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa', + . iip1, jjp1, thoriid, 1, 1, 1, -99, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(fileid, 'phis', 'geopotentiel au sol', '-', + . iip1, jjp1, thoriid, 1, 1, 1, -99, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Fin +C + call histend(fileid) +#else +! tell the user this routine should be run with ioipsl + write(lunout,*)"initdynav: Warning this routine should not be", + & " used without ioipsl" +#endif +! of #ifdef CPP_IOIPSL + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/initfluxsto.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/initfluxsto.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/initfluxsto.F (revision 1280) @@ -0,0 +1,233 @@ +! +! $Id$ +! + subroutine initfluxsto + . (infile,tstep,t_ops,t_wrt, + . fileid,filevid,filedid) + +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C infile: nom du fichier histoire a creer +C day0,anne0: date de reference +C tstep: duree du pas de temps en seconde +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C +C Sortie: +C fileid: ID du fichier netcdf cree +C filevid:ID du fichier netcdf pour la grille v +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C Arguments +C + character*(*) infile + real tstep, t_ops, t_wrt + integer fileid, filevid,filedid + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL to work +C Variables locales +C + real nivd(1) + integer tau0 + real zjulian + character*3 str + character*10 ctrac + integer iq + real rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1) + integer uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid + integer ii,jj + integer zan, idayref + logical ok_sync +C +C Initialisations +C + pi = 4. * atan (1.) + str='q ' + ctrac = 'traceur ' + ok_sync = .true. +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = annee_ref + idayref = day_ref + CALL ymds2ju(zan, 1, idayref, 0.0, zjulian) + tau0 = itau_dyn + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonu(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + call histbeg(infile, iip1, rlong(:,1), jjp1, rlat(1,:), + . 1, iip1, 1, jjp1, + . tau0, zjulian, tstep, uhoriid, fileid) +C +C Creation du fichier histoire pour la grille en V (oblige pour l'instant, +C IOIPSL ne permet pas de grilles avec des nombres de point differents dans +C un meme fichier) + + + do jj = 1, jjm + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatv(jj) * 180. / pi + enddo + enddo + + call histbeg('fluxstokev.nc', iip1, rlong(:,1), jjm, rlat(1,:), + . 1, iip1, 1, jjm, + . tau0, zjulian, tstep, vhoriid, filevid) + + rl(1,1) = 1. + call histbeg('defstoke.nc', 1, rl, 1, rl, + . 1, 1, 1, 1, + . tau0, zjulian, tstep, dhoriid, filedid) + +C +C Appel a histhori pour rajouter les autres grilles horizontales +C + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + call histhori(fileid, iip1, rlong, jjp1, rlat, 'scalar', + . 'Grille points scalaires', thoriid) + +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'sig_s', 'Niveaux sigma', + . 'sigma_level', + . llm, nivsigs, zvertiid) +C Pour le fichier V + call histvert(filevid, 'sig_s', 'Niveaux sigma', + . 'sigma_level', + . llm, nivsigs, zvertiid) +c pour le fichier def + nivd(1) = 1 + call histvert(filedid, 'sig_s', 'Niveaux sigma', + . 'sigma_level', + . 1, nivd, dvertiid) + +C +C Appels a histdef pour la definition des variables a sauvegarder + + CALL histdef(fileid, "phis", "Surface geop. height", "-", + . iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(fileid, "aire", "Grid area", "-", + . iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(filedid, "dtvr", "tps dyn", "s", + . 1,1,dhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(filedid, "istdyn", "tps stock", "s", + . 1,1,dhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(filedid, "istphy", "tps stock phy", "s", + . 1,1,dhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + +C +C Masse +C + call histdef(fileid, 'masse', 'Masse', 'kg', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Pbaru +C + call histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s', + . iip1, jjp1, uhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +C +C Pbarv +C + call histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s', + . iip1, jjm, vhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C w +C + call histdef(fileid, 'w', 'flx de masse vert', 'kg m/s', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +C +C Temperature potentielle +C + call histdef(fileid, 'teta', 'temperature potentielle', '-', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C + +C +C Geopotentiel +C + call histdef(fileid, 'phi', 'geopotentiel instantane', '-', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Fin +C + call histend(fileid) + call histend(filevid) + call histend(filedid) + if (ok_sync) then + call histsync(fileid) + call histsync(filevid) + call histsync(filedid) + endif + +#else +! tell the user this routine should be run with ioipsl + write(lunout,*)"initfluxsto: Warning this routine should not be", + & " used without ioipsl" +#endif +! of #ifdef CPP_IOIPSL + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/inithist.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/inithist.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/inithist.F (revision 1280) @@ -0,0 +1,195 @@ +! +! $Id$ +! + subroutine inithist(infile,day0,anne0,tstep,t_ops,t_wrt,fileid, + . filevid) + +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + USE infotrac, ONLY : nqtot, ttext + + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C infile: nom du fichier histoire a creer +C day0,anne0: date de reference +C tstep: duree du pas de temps en seconde +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C nq: nombre de traceurs +C +C Sortie: +C fileid: ID du fichier netcdf cree +C filevid:ID du fichier netcdf pour la grille v +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C Arguments +C + character*(*) infile + integer day0, anne0 + real tstep, t_ops, t_wrt + integer fileid, filevid + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL to work +C Variables locales +C + integer tau0 + real zjulian + integer iq + real rlong(iip1,jjp1), rlat(iip1,jjp1) + integer uhoriid, vhoriid, thoriid, zvertiid + integer ii,jj + integer zan, dayref +C +C Initialisations +C + pi = 4. * atan (1.) +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = anne0 + dayref = day0 + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonu(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + call histbeg(infile, iip1, rlong(:,1), jjp1, rlat(1,:), + . 1, iip1, 1, jjp1, + . tau0, zjulian, tstep, uhoriid, fileid) +C +C Creation du fichier histoire pour la grille en V (oblige pour l'instant, +C IOIPSL ne permet pas de grilles avec des nombres de point differents dans +C un meme fichier) + + do jj = 1, jjm + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatv(jj) * 180. / pi + enddo + enddo + + call histbeg('dyn_histv.nc', iip1, rlong(:,1), jjm, rlat(1,:), + . 1, iip1, 1, jjm, + . tau0, zjulian, tstep, vhoriid, filevid) +C +C Appel a histhori pour rajouter les autres grilles horizontales +C + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + call histhori(fileid, iip1, rlong, jjp1, rlat, 'scalar', + . 'Grille points scalaires', thoriid) +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'sig_s', 'Niveaux sigma','-', + . llm, nivsigs, zvertiid) +C Pour le fichier V + call histvert(filevid, 'sig_s', 'Niveaux sigma','-', + . llm, nivsigs, zvertiid) +C +C Appels a histdef pour la definition des variables a sauvegarder +C +C Vents U +C + call histdef(fileid, 'ucov', 'vents u covariants', 'm/s', + . iip1, jjp1, uhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Vents V +C + call histdef(filevid, 'vcov', 'vents v covariants', 'm/s', + . iip1, jjm, vhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +C +C Temperature potentielle +C + call histdef(fileid, 'teta', 'temperature potentielle', '-', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Geopotentiel +C + call histdef(fileid, 'phi', 'geopotentiel instantane', '-', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Traceurs +C + DO iq=1,nqtot + call histdef(fileid, ttext(iq), ttext(iq), '-', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + enddo +C +C Masse +C + call histdef(fileid, 'masse', 'masse', 'kg', + . iip1, jjp1, thoriid, 1, 1, 1, -99, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa', + . iip1, jjp1, thoriid, 1, 1, 1, -99, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(fileid, 'phis', 'geopotentiel au sol', '-', + . iip1, jjp1, thoriid, 1, 1, 1, -99, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Fin +C + call histend(fileid) + call histend(filevid) +#else +! tell the user this routine should be run with ioipsl + write(lunout,*)"inithist: Warning this routine should not be", + & " used without ioipsl" +#endif +! of #ifdef CPP_IOIPSL + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/interpolation.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/interpolation.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/interpolation.F90 (revision 1280) @@ -0,0 +1,138 @@ +! $Id$ +module interpolation + + ! From Press et al., 1996, version 2.10a + ! B3 Interpolation and Extrapolation + + IMPLICIT NONE + +contains + + pure FUNCTION locate(xx,x) + + REAL, DIMENSION(:), INTENT(IN) :: xx + REAL, INTENT(IN) :: x + INTEGER locate + + ! Given an array xx(1:N), and given a value x, returns a value j, + ! between 0 and N, such that x is between xx(j) and xx(j + 1). xx + ! must be monotonic, either increasing or decreasing. j = 0 or j = + ! N is returned to indicate that x is out of range. This + ! procedure should not be called with a zero-sized array argument. + ! See notes. + + INTEGER n,jl,jm,ju + LOGICAL ascnd + + !---------------------------- + + n=size(xx) + ascnd = (xx(n) >= xx(1)) + ! (True if ascending order of table, false otherwise.) + ! Initialize lower and upper limits: + jl=0 + ju=n+1 + do while (ju-jl > 1) + jm=(ju+jl)/2 ! Compute a midpoint, + if (ascnd .eqv. (x >= xx(jm))) then + jl=jm ! and replace either the lower limit + else + ju=jm ! or the upper limit, as appropriate. + end if + end do + ! {ju == jl + 1} + + ! {(ascnd .and. xx(jl) <= x < xx(jl+1)) + ! .neqv. + ! (.not. ascnd .and. xx(jl+1) <= x < xx(jl))} + + ! Then set the output, being careful with the endpoints: + if (x == xx(1)) then + locate=1 + else if (x == xx(n)) then + locate=n-1 + else + locate=jl + end if + + END FUNCTION locate + + !*************************** + + pure SUBROUTINE hunt(xx,x,jlo) + + ! Given an array xx(1:N ), and given a value x, returns a value + ! jlo such that x is between xx(jlo) and xx(jlo+1). xx must be + ! monotonic, either increasing or decreasing. jlo = 0 or jlo = N is + ! returned to indicate that x is out of range. jlo on input is taken as + ! the initial guess for jlo on output. + ! Modified so that it uses the information "jlo = 0" on input. + + INTEGER, INTENT(INOUT) :: jlo + REAL, INTENT(IN) :: x + REAL, DIMENSION(:), INTENT(IN) :: xx + INTEGER n,inc,jhi,jm + LOGICAL ascnd, hunt_up + + !----------------------------------------------------- + + n=size(xx) + ascnd = (xx(n) >= xx(1)) + ! (True if ascending order of table, false otherwise.) + if (jlo < 0 .or. jlo > n) then + ! Input guess not useful. Go immediately to bisection. + jlo=0 + jhi=n+1 + else + inc=1 ! Set the hunting increment. + if (jlo == 0) then + hunt_up = .true. + else + hunt_up = x >= xx(jlo) .eqv. ascnd + end if + if (hunt_up) then ! Hunt up: + do + jhi=jlo+inc + if (jhi > n) then ! Done hunting, since off end of table. + jhi=n+1 + exit + else + if (x < xx(jhi) .eqv. ascnd) exit + jlo=jhi ! Not done hunting, + inc=inc+inc ! so double the increment + end if + end do ! and try again. + else ! Hunt down: + jhi=jlo + do + jlo=jhi-inc + if (jlo < 1) then ! Done hunting, since off end of table. + jlo=0 + exit + else + if (x >= xx(jlo) .eqv. ascnd) exit + jhi=jlo ! Not done hunting, + inc=inc+inc ! so double the increment + end if + end do ! and try again. + end if + end if ! Done hunting, value bracketed. + + do ! Hunt is done, so begin the final bisection phase: + if (jhi-jlo <= 1) then + if (x == xx(n)) jlo=n-1 + if (x == xx(1)) jlo=1 + exit + else + jm=(jhi+jlo)/2 + if (x >= xx(jm) .eqv. ascnd) then + jlo=jm + else + jhi=jm + end if + end if + end do + + END SUBROUTINE hunt + +end module interpolation Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/ioipsl_errioipsl.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/ioipsl_errioipsl.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/ioipsl_errioipsl.F90 (revision 1280) @@ -0,0 +1,219 @@ +! +! $Id$ +! +! Module/Routines extracted from IOIPSL v2_1_8 +! +MODULE ioipsl_errioipsl +!- +!$Id: errioipsl.f90 386 2008-09-04 08:38:48Z bellier $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +IMPLICIT NONE +!- +PRIVATE +!- +PUBLIC :: ipslnlf, ipslerr, ipslerr_act, ipslerr_inq, histerr, ipsldbg +!- + INTEGER :: n_l=6, ilv_cur=0, ilv_max=0 + LOGICAL :: ioipsl_debug=.FALSE., lact_mode=.TRUE. +!- +!=== +CONTAINS +!=== +SUBROUTINE ipslnlf (new_number,old_number) +!!-------------------------------------------------------------------- +!! The "ipslnlf" routine allows to know and modify +!! the current logical number for the messages. +!! +!! SUBROUTINE ipslnlf (new_number,old_number) +!! +!! Optional INPUT argument +!! +!! (I) new_number : new logical number of the file +!! +!! Optional OUTPUT argument +!! +!! (I) old_number : current logical number of the file +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,OPTIONAL,INTENT(IN) :: new_number + INTEGER,OPTIONAL,INTENT(OUT) :: old_number +!--------------------------------------------------------------------- + IF (PRESENT(old_number)) THEN + old_number = n_l + ENDIF + IF (PRESENT(new_number)) THEN + n_l = new_number + ENDIF +!--------------------- +END SUBROUTINE ipslnlf +!=== +SUBROUTINE ipslerr (plev,pcname,pstr1,pstr2,pstr3) +!--------------------------------------------------------------------- +!! The "ipslerr" routine +!! allows to handle the messages to the user. +!! +!! INPUT +!! +!! plev : Category of message to be reported to the user +!! 1 = Note to the user +!! 2 = Warning to the user +!! 3 = Fatal error +!! pcname : Name of subroutine which has called ipslerr +!! pstr1 +!! pstr2 : Strings containing the explanations to the user +!! pstr3 +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: plev + CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3 +!- + CHARACTER(LEN=30),DIMENSION(3) :: pemsg = & + & (/ "NOTE TO THE USER FROM ROUTINE ", & + & "WARNING FROM ROUTINE ", & + & "FATAL ERROR FROM ROUTINE " /) +!--------------------------------------------------------------------- + IF ( (plev >= 1).AND.(plev <= 3) ) THEN + ilv_cur = plev + ilv_max = MAX(ilv_max,plev) + WRITE(n_l,'(/,A," ",A)') TRIM(pemsg(plev)),TRIM(pcname) + WRITE(n_l,'(3(" --> ",A,/))') TRIM(pstr1),TRIM(pstr2),TRIM(pstr3) + ENDIF + IF ( (plev == 3).AND.lact_mode) THEN + STOP 'Fatal error from IOIPSL. See stdout for more details' + ENDIF +!--------------------- +END SUBROUTINE ipslerr +!=== +SUBROUTINE ipslerr_act (new_mode,old_mode) +!!-------------------------------------------------------------------- +!! The "ipslerr_act" routine allows to know and modify +!! the current "action mode" for the error messages, +!! and reinitialize the error level values. +!! +!! SUBROUTINE ipslerr_act (new_mode,old_mode) +!! +!! Optional INPUT argument +!! +!! (I) new_mode : new error action mode +!! .TRUE. -> STOP in case of fatal error +!! .FALSE. -> CONTINUE in case of fatal error +!! +!! Optional OUTPUT argument +!! +!! (I) old_mode : current error action mode +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + LOGICAL,OPTIONAL,INTENT(IN) :: new_mode + LOGICAL,OPTIONAL,INTENT(OUT) :: old_mode +!--------------------------------------------------------------------- + IF (PRESENT(old_mode)) THEN + old_mode = lact_mode + ENDIF + IF (PRESENT(new_mode)) THEN + lact_mode = new_mode + ENDIF + ilv_cur = 0 + ilv_max = 0 +!------------------------- +END SUBROUTINE ipslerr_act +!=== +SUBROUTINE ipslerr_inq (current_level,maximum_level) +!!-------------------------------------------------------------------- +!! The "ipslerr_inq" routine allows to know +!! the current level of the error messages +!! and the maximum level encountered since the +!! last call to "ipslerr_act". +!! +!! SUBROUTINE ipslerr_inq (current_level,maximum_level) +!! +!! Optional OUTPUT argument +!! +!! (I) current_level : current error level +!! (I) maximum_level : maximum error level +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,OPTIONAL,INTENT(OUT) :: current_level,maximum_level +!--------------------------------------------------------------------- + IF (PRESENT(current_level)) THEN + current_level = ilv_cur + ENDIF + IF (PRESENT(maximum_level)) THEN + maximum_level = ilv_max + ENDIF +!------------------------- +END SUBROUTINE ipslerr_inq +!=== +SUBROUTINE histerr (plev,pcname,pstr1,pstr2,pstr3) +!--------------------------------------------------------------------- +!- INPUT +!- plev : Category of message to be reported to the user +!- 1 = Note to the user +!- 2 = Warning to the user +!- 3 = Fatal error +!- pcname : Name of subroutine which has called histerr +!- pstr1 +!- pstr2 : String containing the explanations to the user +!- pstr3 +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: plev + CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3 +!- + CHARACTER(LEN=30),DIMENSION(3) :: pemsg = & + & (/ "NOTE TO THE USER FROM ROUTINE ", & + & "WARNING FROM ROUTINE ", & + & "FATAL ERROR FROM ROUTINE " /) +!--------------------------------------------------------------------- + IF ( (plev >= 1).AND.(plev <= 3) ) THEN + WRITE(*,'(" ")') + WRITE(*,'(A," ",A)') TRIM(pemsg(plev)),TRIM(pcname) + WRITE(*,'(" --> ",A)') pstr1 + WRITE(*,'(" --> ",A)') pstr2 + WRITE(*,'(" --> ",A)') pstr3 + ENDIF + IF (plev == 3) THEN + STOP 'Fatal error from IOIPSL. See stdout for more details' + ENDIF +!--------------------- +END SUBROUTINE histerr +!=== +SUBROUTINE ipsldbg (new_status,old_status) +!!-------------------------------------------------------------------- +!! The "ipsldbg" routine +!! allows to activate or deactivate the debug, +!! and to know the current status of the debug. +!! +!! SUBROUTINE ipsldbg (new_status,old_status) +!! +!! Optional INPUT argument +!! +!! (L) new_status : new status of the debug +!! +!! Optional OUTPUT argument +!! +!! (L) old_status : current status of the debug +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + LOGICAL,OPTIONAL,INTENT(IN) :: new_status + LOGICAL,OPTIONAL,INTENT(OUT) :: old_status +!--------------------------------------------------------------------- + IF (PRESENT(old_status)) THEN + old_status = ioipsl_debug + ENDIF + IF (PRESENT(new_status)) THEN + ioipsl_debug = new_status + ENDIF +!--------------------- +END SUBROUTINE ipsldbg +!=== +!------------------- +END MODULE ioipsl_errioipsl Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/ioipsl_getincom.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/ioipsl_getincom.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/ioipsl_getincom.F90 (revision 1280) @@ -0,0 +1,1980 @@ +! +! $Id$ +! +! Module/Routines extracted from IOIPSL v2_1_8 +! +MODULE ioipsl_getincom +!- +!$Id: getincom.f90 536 2009-01-30 11:46:27Z bellier $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +USE ioipsl_errioipsl, ONLY : ipslerr +USE ioipsl_stringop, & + & ONLY : nocomma,cmpblank,strlowercase +!- +IMPLICIT NONE +!- +PRIVATE +PUBLIC :: getin, getin_dump +!- +INTERFACE getin +!!-------------------------------------------------------------------- +!! The "getin" routines get a variable. +!! We first check if we find it in the database +!! and if not we get it from the run.def file. +!! +!! SUBROUTINE getin (target,ret_val) +!! +!! INPUT +!! +!! (C) target : Name of the variable +!! +!! OUTPUT +!! +!! (I/R/C/L) ret_val : scalar, vector or matrix that will contain +!! that will contain the (standard) +!! integer/real/character/logical values +!!-------------------------------------------------------------------- + MODULE PROCEDURE getinrs, getinr1d, getinr2d, & + & getinis, getini1d, getini2d, & + & getincs, getinc1d, getinc2d, & + & getinls, getinl1d, getinl2d +END INTERFACE +!- +!!-------------------------------------------------------------------- +!! The "getin_dump" routine will dump the content of the database +!! into a file which has the same format as the run.def file. +!! The idea is that the user can see which parameters were used +!! and re-use the file for another run. +!! +!! SUBROUTINE getin_dump (fileprefix) +!! +!! OPTIONAL INPUT argument +!! +!! (C) fileprefix : allows the user to change the name of the file +!! in which the data will be archived +!!-------------------------------------------------------------------- +!- + INTEGER,PARAMETER :: max_files=100 + CHARACTER(LEN=100),DIMENSION(max_files),SAVE :: filelist + INTEGER,SAVE :: nbfiles +!- + INTEGER,PARAMETER :: i_txtslab=1000,l_n=30 + INTEGER,SAVE :: nb_lines,i_txtsize=0 + CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: fichier + CHARACTER(LEN=l_n),SAVE,ALLOCATABLE,DIMENSION(:) :: targetlist + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: fromfile,compline +!- + INTEGER,PARAMETER :: n_d_fmt=5,max_msgs=15 + CHARACTER(LEN=6),SAVE :: c_i_fmt = '(I5.5)' +!- +! The data base of parameters +!- + INTEGER,PARAMETER :: memslabs=200 + INTEGER,PARAMETER :: compress_lim=20 +!- + INTEGER,SAVE :: nb_keys=0 + INTEGER,SAVE :: keymemsize=0 +!- +! keystr definition +! name of a key +!- +! keystatus definition +! keystatus = 1 : Value comes from run.def +! keystatus = 2 : Default value is used +! keystatus = 3 : Some vector elements were taken from default +!- +! keytype definition +! keytype = 1 : Integer +! keytype = 2 : Real +! keytype = 3 : Character +! keytype = 4 : Logical +!- + INTEGER,PARAMETER :: k_i=1, k_r=2, k_c=3, k_l=4 +!- +! Allow compression for keys (only for integer and real) +! keycompress < 0 : not compressed +! keycompress > 0 : number of repeat of the value +!- +TYPE :: t_key + CHARACTER(LEN=l_n) :: keystr + INTEGER :: keystatus, keytype, keycompress, & + & keyfromfile, keymemstart, keymemlen +END TYPE t_key +!- + TYPE(t_key),SAVE,ALLOCATABLE,DIMENSION(:) :: key_tab +!- + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: i_mem + INTEGER,SAVE :: i_memsize=0, i_mempos=0 + REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: r_mem + INTEGER,SAVE :: r_memsize=0, r_mempos=0 + CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: c_mem + INTEGER,SAVE :: c_memsize=0, c_mempos=0 + LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:) :: l_mem + INTEGER,SAVE :: l_memsize=0, l_mempos=0 +!- +CONTAINS +!- +!=== INTEGER INTERFACE +!- +SUBROUTINE getinis (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER :: ret_val +!- + INTEGER,DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,i_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,i_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getinis +!=== +SUBROUTINE getini1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER,DIMENSION(:) :: ret_val +!- + INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF + tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,i_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val) + ENDIF + ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) +!---------------------- +END SUBROUTINE getini1d +!=== +SUBROUTINE getini2d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER,DIMENSION(:,:) :: ret_val +!- + INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + size_1 = SIZE(ret_val,1) + size_2 = SIZE(ret_val,2) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + tmp_ret_val(jl) = ret_val(ji,jj) + ENDDO + ENDDO +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,i_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val) + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + ret_val(ji,jj) = tmp_ret_val(jl) + ENDDO + ENDDO +!---------------------- +END SUBROUTINE getini2d +!- +!=== REAL INTERFACE +!- +SUBROUTINE getinrs (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + REAL :: ret_val +!- + REAL,DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,r_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,r_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getinrs +!=== +SUBROUTINE getinr1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + REAL,DIMENSION(:) :: ret_val +!- + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF + tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,r_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val) + ENDIF + ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) +!---------------------- +END SUBROUTINE getinr1d +!=== +SUBROUTINE getinr2d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + REAL,DIMENSION(:,:) :: ret_val +!- + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + size_1 = SIZE(ret_val,1) + size_2 = SIZE(ret_val,2) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + tmp_ret_val(jl) = ret_val(ji,jj) + ENDDO + ENDDO +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,r_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val) + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + ret_val(ji,jj) = tmp_ret_val(jl) + ENDDO + ENDDO +!---------------------- +END SUBROUTINE getinr2d +!- +!=== CHARACTER INTERFACE +!- +SUBROUTINE getincs (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + CHARACTER(LEN=*) :: ret_val +!- + CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,c_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,c_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getincs +!=== +SUBROUTINE getinc1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + CHARACTER(LEN=*),DIMENSION(:) :: ret_val +!- + CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF + tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,c_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val) + ENDIF + ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) +!---------------------- +END SUBROUTINE getinc1d +!=== +SUBROUTINE getinc2d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val +!- + CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + size_1 = SIZE(ret_val,1) + size_2 = SIZE(ret_val,2) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + tmp_ret_val(jl) = ret_val(ji,jj) + ENDDO + ENDDO +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,c_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val) + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + ret_val(ji,jj) = tmp_ret_val(jl) + ENDDO + ENDDO +!---------------------- +END SUBROUTINE getinc2d +!- +!=== LOGICAL INTERFACE +!- +SUBROUTINE getinls (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + LOGICAL :: ret_val +!- + LOGICAL,DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,l_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,l_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getinls +!=== +SUBROUTINE getinl1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + LOGICAL,DIMENSION(:) :: ret_val +!- + LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF + tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,l_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val) + ENDIF + ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) +!---------------------- +END SUBROUTINE getinl1d +!=== +SUBROUTINE getinl2d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + LOGICAL,DIMENSION(:,:) :: ret_val +!- + LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + size_1 = SIZE(ret_val,1) + size_2 = SIZE(ret_val,2) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + tmp_ret_val(jl) = ret_val(ji,jj) + ENDDO + ENDDO +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,l_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val) + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + ret_val(ji,jj) = tmp_ret_val(jl) + ENDDO + ENDDO +!---------------------- +END SUBROUTINE getinl2d +!- +!=== Generic file/database INTERFACE +!- +SUBROUTINE get_fil (target,status,fileorig,i_val,r_val,c_val,l_val) +!--------------------------------------------------------------------- +!- Subroutine that will extract from the file the values +!- attributed to the keyword target +!- +!- (C) target : target for which we will look in the file +!- (I) status : tells us from where we obtained the data +!- (I) fileorig : index of the file from which the key comes +!- (I) i_val(:) : INTEGER(nb_to_ret) values +!- (R) r_val(:) : REAL(nb_to_ret) values +!- (L) l_val(:) : LOGICAL(nb_to_ret) values +!- (C) c_val(:) : CHARACTER(nb_to_ret) values +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER,INTENT(OUT) :: status,fileorig + INTEGER,DIMENSION(:),OPTIONAL :: i_val + REAL,DIMENSION(:),OPTIONAL :: r_val + LOGICAL,DIMENSION(:),OPTIONAL :: l_val + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val +!- + INTEGER :: k_typ,nb_to_ret,it,pos,len_str,status_cnt,io_err + CHARACTER(LEN=n_d_fmt) :: cnt + CHARACTER(LEN=80) :: str_READ,str_READ_lower + CHARACTER(LEN=9) :: c_vtyp + LOGICAL,DIMENSION(:),ALLOCATABLE :: found + LOGICAL :: def_beha,compressed + CHARACTER(LEN=10) :: c_fmt + INTEGER :: i_cmpval + REAL :: r_cmpval + INTEGER :: ipos_tr,ipos_fl +!--------------------------------------------------------------------- +!- +! Get the type of the argument + CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) + SELECT CASE (k_typ) + CASE(k_i) + nb_to_ret = SIZE(i_val) + CASE(k_r) + nb_to_ret = SIZE(r_val) + CASE(k_c) + nb_to_ret = SIZE(c_val) + CASE(k_l) + nb_to_ret = SIZE(l_val) + CASE DEFAULT + CALL ipslerr (3,'get_fil', & + & 'Internal error','Unknown type of data',' ') + END SELECT +!- +! Read the file(s) + CALL getin_read +!- +! Allocate and initialize the memory we need + ALLOCATE(found(nb_to_ret)) + found(:) = .FALSE. +!- +! See what we find in the files read + DO it=1,nb_to_ret +!--- +!-- First try the target as it is + CALL get_findkey (2,target,pos) +!--- +!-- Another try +!--- + IF (pos < 0) THEN + WRITE(UNIT=cnt,FMT=c_i_fmt) it + CALL get_findkey (2,TRIM(target)//'__'//cnt,pos) + ENDIF +!--- +!-- We dont know from which file the target could come. +!-- Thus by default we attribute it to the first file : + fileorig = 1 +!--- + IF (pos > 0) THEN +!----- + found(it) = .TRUE. + fileorig = fromfile(pos) +!----- +!---- DECODE +!----- + str_READ = ADJUSTL(fichier(pos)) + str_READ_lower = str_READ + CALL strlowercase (str_READ_lower) +!----- + IF ( (TRIM(str_READ_lower) == 'def') & + & .OR.(TRIM(str_READ_lower) == 'default') ) THEN + def_beha = .TRUE. + ELSE + def_beha = .FALSE. + len_str = LEN_TRIM(str_READ) + io_err = 0 + SELECT CASE (k_typ) + CASE(k_i) + WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') len_str + READ (UNIT=str_READ(1:len_str), & + & FMT=c_fmt,IOSTAT=io_err) i_val(it) + CASE(k_r) + READ (UNIT=str_READ(1:len_str), & + & FMT=*,IOSTAT=io_err) r_val(it) + CASE(k_c) + c_val(it) = str_READ(1:len_str) + CASE(k_l) + ipos_tr = -1 + ipos_fl = -1 + ipos_tr = MAX(INDEX(str_READ_lower,'tru'), & + & INDEX(str_READ_lower,'y')) + ipos_fl = MAX(INDEX(str_READ_lower,'fal'), & + & INDEX(str_READ_lower,'n')) + IF (ipos_tr > 0) THEN + l_val(it) = .TRUE. + ELSE IF (ipos_fl > 0) THEN + l_val(it) = .FALSE. + ELSE + io_err = 100 + ENDIF + END SELECT + IF (io_err /= 0) THEN + CALL ipslerr (3,'get_fil', & + & 'Target '//TRIM(target), & + & 'is not of '//TRIM(c_vtyp)//' type',' ') + ENDIF + ENDIF +!----- + IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN +!------- +!------ Is this the value of a compressed field ? + compressed = (compline(pos) > 0) + IF (compressed) THEN + IF (compline(pos) /= nb_to_ret) THEN + CALL ipslerr (2,'get_fil', & + & 'For key '//TRIM(target)//' we have a compressed field', & + & 'which does not have the right size.', & + & 'We will try to fix that.') + ENDIF + IF (k_typ == k_i) THEN + i_cmpval = i_val(it) + ELSE IF (k_typ == k_r) THEN + r_cmpval = r_val(it) + ENDIF + ENDIF + ENDIF + ELSE + found(it) = .FALSE. + def_beha = .FALSE. + compressed = .FALSE. + ENDIF + ENDDO +!- + IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN +!--- +!-- If this is a compressed field then we will uncompress it + IF (compressed) THEN + DO it=1,nb_to_ret + IF (.NOT.found(it)) THEN + IF (k_typ == k_i) THEN + i_val(it) = i_cmpval + ELSE IF (k_typ == k_r) THEN + ENDIF + found(it) = .TRUE. + ENDIF + ENDDO + ENDIF + ENDIF +!- +! Now we set the status for what we found + IF (def_beha) THEN + status = 2 + WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(target) + ELSE + status_cnt = 0 + DO it=1,nb_to_ret + IF (.NOT.found(it)) THEN + status_cnt = status_cnt+1 + IF (status_cnt <= max_msgs) THEN + WRITE (UNIT=*,FMT='(" USING DEFAULTS : ",A)', & + & ADVANCE='NO') TRIM(target) + IF (nb_to_ret > 1) THEN + WRITE (UNIT=*,FMT='("__")',ADVANCE='NO') + WRITE (UNIT=*,FMT=c_i_fmt,ADVANCE='NO') it + ENDIF + SELECT CASE (k_typ) + CASE(k_i) + WRITE (UNIT=*,FMT=*) "=",i_val(it) + CASE(k_r) + WRITE (UNIT=*,FMT=*) "=",r_val(it) + CASE(k_c) + WRITE (UNIT=*,FMT=*) "=",c_val(it) + CASE(k_l) + WRITE (UNIT=*,FMT=*) "=",l_val(it) + END SELECT + ELSE IF (status_cnt == max_msgs+1) THEN + WRITE (UNIT=*,FMT='(" USING DEFAULTS ... ",A)') + ENDIF + ENDIF + ENDDO +!--- + IF (status_cnt == 0) THEN + status = 1 + ELSE IF (status_cnt == nb_to_ret) THEN + status = 2 + ELSE + status = 3 + ENDIF + ENDIF +! Deallocate the memory + DEALLOCATE(found) +!--------------------- +END SUBROUTINE get_fil +!=== +SUBROUTINE get_rdb (pos,size_of_in,target,i_val,r_val,c_val,l_val) +!--------------------------------------------------------------------- +!- Read the required variable in the database +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: pos,size_of_in + CHARACTER(LEN=*) :: target + INTEGER,DIMENSION(:),OPTIONAL :: i_val + REAL,DIMENSION(:),OPTIONAL :: r_val + LOGICAL,DIMENSION(:),OPTIONAL :: l_val + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val +!- + INTEGER :: k_typ,k_beg,k_end + CHARACTER(LEN=9) :: c_vtyp +!--------------------------------------------------------------------- +!- +! Get the type of the argument + CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) + IF ( (k_typ /= k_i).AND.(k_typ /= k_r) & + & .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN + CALL ipslerr (3,'get_rdb', & + & 'Internal error','Unknown type of data',' ') + ENDIF +!- + IF (key_tab(pos)%keytype /= k_typ) THEN + CALL ipslerr (3,'get_rdb', & + & 'Wrong data type for keyword '//TRIM(target), & + & '(NOT '//TRIM(c_vtyp)//')',' ') + ENDIF +!- + IF (key_tab(pos)%keycompress > 0) THEN + IF ( (key_tab(pos)%keycompress /= size_of_in) & + & .OR.(key_tab(pos)%keymemlen /= 1) ) THEN + CALL ipslerr (3,'get_rdb', & + & 'Wrong compression length','for keyword '//TRIM(target),' ') + ELSE + SELECT CASE (k_typ) + CASE(k_i) + i_val(1:size_of_in) = i_mem(key_tab(pos)%keymemstart) + CASE(k_r) + r_val(1:size_of_in) = r_mem(key_tab(pos)%keymemstart) + END SELECT + ENDIF + ELSE + IF (key_tab(pos)%keymemlen /= size_of_in) THEN + CALL ipslerr (3,'get_rdb', & + & 'Wrong array length','for keyword '//TRIM(target),' ') + ELSE + k_beg = key_tab(pos)%keymemstart + k_end = k_beg+key_tab(pos)%keymemlen-1 + SELECT CASE (k_typ) + CASE(k_i) + i_val(1:size_of_in) = i_mem(k_beg:k_end) + CASE(k_r) + r_val(1:size_of_in) = r_mem(k_beg:k_end) + CASE(k_c) + c_val(1:size_of_in) = c_mem(k_beg:k_end) + CASE(k_l) + l_val(1:size_of_in) = l_mem(k_beg:k_end) + END SELECT + ENDIF + ENDIF +!--------------------- +END SUBROUTINE get_rdb +!=== +SUBROUTINE get_wdb & + & (target,status,fileorig,size_of_in, & + & i_val,r_val,c_val,l_val) +!--------------------------------------------------------------------- +!- Write data into the data base +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER :: status,fileorig,size_of_in + INTEGER,DIMENSION(:),OPTIONAL :: i_val + REAL,DIMENSION(:),OPTIONAL :: r_val + LOGICAL,DIMENSION(:),OPTIONAL :: l_val + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val +!- + INTEGER :: k_typ + CHARACTER(LEN=9) :: c_vtyp + INTEGER :: k_mempos,k_memsize,k_beg,k_end + LOGICAL :: l_cmp +!--------------------------------------------------------------------- +!- +! Get the type of the argument + CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) + IF ( (k_typ /= k_i).AND.(k_typ /= k_r) & + & .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN + CALL ipslerr (3,'get_wdb', & + & 'Internal error','Unknown type of data',' ') + ENDIF +!- +! First check if we have sufficiant space for the new key + IF (nb_keys+1 > keymemsize) THEN + CALL getin_allockeys () + ENDIF +!- + SELECT CASE (k_typ) + CASE(k_i) + k_mempos = i_mempos; k_memsize = i_memsize; + l_cmp = (MINVAL(i_val) == MAXVAL(i_val)) & + & .AND.(size_of_in > compress_lim) + CASE(k_r) + k_mempos = r_mempos; k_memsize = r_memsize; + l_cmp = (MINVAL(r_val) == MAXVAL(r_val)) & + & .AND.(size_of_in > compress_lim) + CASE(k_c) + k_mempos = c_mempos; k_memsize = c_memsize; + l_cmp = .FALSE. + CASE(k_l) + k_mempos = l_mempos; k_memsize = l_memsize; + l_cmp = .FALSE. + END SELECT +!- +! Fill out the items of the data base + nb_keys = nb_keys+1 + key_tab(nb_keys)%keystr = target(1:MIN(LEN_TRIM(target),l_n)) + key_tab(nb_keys)%keystatus = status + key_tab(nb_keys)%keytype = k_typ + key_tab(nb_keys)%keyfromfile = fileorig + key_tab(nb_keys)%keymemstart = k_mempos+1 + IF (l_cmp) THEN + key_tab(nb_keys)%keycompress = size_of_in + key_tab(nb_keys)%keymemlen = 1 + ELSE + key_tab(nb_keys)%keycompress = -1 + key_tab(nb_keys)%keymemlen = size_of_in + ENDIF +!- +! Before writing the actual size lets see if we have the space + IF (key_tab(nb_keys)%keymemstart+key_tab(nb_keys)%keymemlen & + & > k_memsize) THEN + CALL getin_allocmem (k_typ,key_tab(nb_keys)%keymemlen) + ENDIF +!- + k_beg = key_tab(nb_keys)%keymemstart + k_end = k_beg+key_tab(nb_keys)%keymemlen-1 + SELECT CASE (k_typ) + CASE(k_i) + i_mem(k_beg:k_end) = i_val(1:key_tab(nb_keys)%keymemlen) + i_mempos = k_end + CASE(k_r) + r_mem(k_beg:k_end) = r_val(1:key_tab(nb_keys)%keymemlen) + r_mempos = k_end + CASE(k_c) + c_mem(k_beg:k_end) = c_val(1:key_tab(nb_keys)%keymemlen) + c_mempos = k_end + CASE(k_l) + l_mem(k_beg:k_end) = l_val(1:key_tab(nb_keys)%keymemlen) + l_mempos = k_end + END SELECT +!--------------------- +END SUBROUTINE get_wdb +!- +!=== +!- +SUBROUTINE getin_read +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,SAVE :: allread=0 + INTEGER,SAVE :: current +!--------------------------------------------------------------------- + IF (allread == 0) THEN +!-- Allocate a first set of memory. + CALL getin_alloctxt () + CALL getin_allockeys () + CALL getin_allocmem (k_i,0) + CALL getin_allocmem (k_r,0) + CALL getin_allocmem (k_c,0) + CALL getin_allocmem (k_l,0) +!-- Start with reading the files + nbfiles = 1 + filelist(1) = 'run.def' + current = 1 +!-- + DO WHILE (current <= nbfiles) + CALL getin_readdef (current) + current = current+1 + ENDDO + allread = 1 + CALL getin_checkcohe () + ENDIF +!------------------------ +END SUBROUTINE getin_read +!- +!=== +!- + SUBROUTINE getin_readdef(current) +!--------------------------------------------------------------------- +!- This subroutine will read the files and only keep the +!- the relevant information. The information is kept as it +!- found in the file. The data will be analysed later. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: current +!- + CHARACTER(LEN=100) :: READ_str,NEW_str,last_key,key_str + CHARACTER(LEN=n_d_fmt) :: cnt + CHARACTER(LEN=10) :: c_fmt + INTEGER :: nb_lastkey +!- + INTEGER :: eof,ptn,len_str,i,it,iund,io_err + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + eof = 0 + ptn = 1 + nb_lastkey = 0 +!- + IF (check) THEN + WRITE(*,*) 'getin_readdef : Open file ',TRIM(filelist(current)) + ENDIF +!- + OPEN (UNIT=22,FILE=filelist(current),STATUS="OLD",IOSTAT=io_err) + IF (io_err /= 0) THEN + CALL ipslerr (2,'getin_readdef', & + & 'Could not open file '//TRIM(filelist(current)),' ',' ') + RETURN + ENDIF +!- + DO WHILE (eof /= 1) +!--- + CALL getin_skipafew (22,READ_str,eof,nb_lastkey) + len_str = LEN_TRIM(READ_str) + ptn = INDEX(READ_str,'=') +!--- + IF (ptn > 0) THEN +!---- Get the target + key_str = TRIM(ADJUSTL(READ_str(1:ptn-1))) +!---- Make sure that a vector keyword has the right length + iund = INDEX(key_str,'__') + IF (iund > 0) THEN + WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') & + & LEN_TRIM(key_str)-iund-1 + READ(UNIT=key_str(iund+2:LEN_TRIM(key_str)), & + & FMT=c_fmt,IOSTAT=io_err) it + IF ( (io_err == 0).AND.(it > 0) ) THEN + WRITE(UNIT=cnt,FMT=c_i_fmt) it + key_str = key_str(1:iund+1)//cnt + ELSE + CALL ipslerr (3,'getin_readdef', & + & 'A very strange key has just been found :', & + & TRIM(key_str),' ') + ENDIF + ENDIF +!---- Prepare the content + NEW_str = TRIM(ADJUSTL(READ_str(ptn+1:len_str))) + CALL nocomma (NEW_str) + CALL cmpblank (NEW_str) + NEW_str = TRIM(ADJUSTL(NEW_str)) + IF (check) THEN + WRITE(*,*) & + & '--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str) + ENDIF +!---- Decypher the content of NEW_str +!- +!---- This has to be a new key word, thus : + nb_lastkey = 0 +!---- + CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey) +!---- + ELSE IF (len_str > 0) THEN +!---- Prepare the key if we have an old one to which +!---- we will add the line just read + IF (nb_lastkey > 0) THEN + iund = INDEX(last_key,'__') + IF (iund > 0) THEN +!-------- We only continue a keyword, thus it is easy + key_str = last_key(1:iund-1) + ELSE + IF (nb_lastkey /= 1) THEN + CALL ipslerr (3,'getin_readdef', & + & 'We can not have a scalar keyword', & + & 'and a vector content',' ') + ENDIF +!-------- The last keyword needs to be transformed into a vector. + WRITE(UNIT=cnt,FMT=c_i_fmt) 1 + targetlist(nb_lines) = & + & last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt + key_str = last_key(1:LEN_TRIM(last_key)) + ENDIF + ENDIF +!---- Prepare the content + NEW_str = TRIM(ADJUSTL(READ_str(1:len_str))) + CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey) + ELSE +!---- If we have an empty line then the keyword finishes + nb_lastkey = 0 + IF (check) THEN + WRITE(*,*) 'getin_readdef : Have found an emtpy line ' + ENDIF + ENDIF + ENDDO +!- + CLOSE(UNIT=22) +!- + IF (check) THEN + OPEN (UNIT=22,file='run.def.test') + DO i=1,nb_lines + WRITE(UNIT=22,FMT=*) targetlist(i)," : ",fichier(i) + ENDDO + CLOSE(UNIT=22) + ENDIF +!--------------------------- +END SUBROUTINE getin_readdef +!- +!=== +!- +SUBROUTINE getin_decrypt(current,key_str,NEW_str,last_key,nb_lastkey) +!--------------------------------------------------------------------- +!- This subroutine is going to decypher the line. +!- It essentialy checks how many items are included and +!- it they can be attached to a key. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + INTEGER :: current,nb_lastkey + CHARACTER(LEN=*) :: key_str,NEW_str,last_key +!- +! LOCAL +!- + INTEGER :: len_str,blk,nbve,starpos + CHARACTER(LEN=100) :: tmp_str,new_key,mult + CHARACTER(LEN=n_d_fmt) :: cnt + CHARACTER(LEN=10) :: c_fmt +!--------------------------------------------------------------------- + len_str = LEN_TRIM(NEW_str) + blk = INDEX(NEW_str(1:len_str),' ') + tmp_str = NEW_str(1:len_str) +!- +! If the key is a new file then we take it up. Else +! we save the line and go on. +!- + IF (INDEX(key_str,'INCLUDEDEF') > 0) THEN + DO WHILE (blk > 0) + IF (nbfiles+1 > max_files) THEN + CALL ipslerr (3,'getin_decrypt', & + & 'Too many files to include',' ',' ') + ENDIF +!----- + nbfiles = nbfiles+1 + filelist(nbfiles) = tmp_str(1:blk) +!----- + tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str)))) + blk = INDEX(tmp_str(1:LEN_TRIM(tmp_str)),' ') + ENDDO +!--- + IF (nbfiles+1 > max_files) THEN + CALL ipslerr (3,'getin_decrypt', & + & 'Too many files to include',' ',' ') + ENDIF +!--- + nbfiles = nbfiles+1 + filelist(nbfiles) = TRIM(ADJUSTL(tmp_str)) +!--- + last_key = 'INCLUDEDEF' + nb_lastkey = 1 + ELSE +!- +!-- We are working on a new line of input +!- + IF (nb_lines+1 > i_txtsize) THEN + CALL getin_alloctxt () + ENDIF + nb_lines = nb_lines+1 +!- +!-- First we solve the issue of conpressed information. Once +!-- this is done all line can be handled in the same way. +!- + starpos = INDEX(NEW_str(1:len_str),'*') + IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') & + & .AND.(tmp_str(1:1) /= "'") ) THEN +!----- + IF (INDEX(key_str(1:LEN_TRIM(key_str)),'__') > 0) THEN + CALL ipslerr (3,'getin_decrypt', & + & 'We can not have a compressed field of values', & + & 'in a vector notation (TARGET__n).', & + & 'The key at fault : '//TRIM(key_str)) + ENDIF +!- +!---- Read the multiplied +!- + mult = TRIM(ADJUSTL(NEW_str(1:starpos-1))) +!---- Construct the new string and its parameters + NEW_str = TRIM(ADJUSTL(NEW_str(starpos+1:len_str))) + len_str = LEN_TRIM(NEW_str) + blk = INDEX(NEW_str(1:len_str),' ') + IF (blk > 1) THEN + CALL ipslerr (2,'getin_decrypt', & + & 'This is a strange behavior','you could report',' ') + ENDIF + WRITE (UNIT=c_fmt,FMT='("(I",I5.5,")")') LEN_TRIM(mult) + READ(UNIT=mult,FMT=c_fmt) compline(nb_lines) +!--- + ELSE + compline(nb_lines) = -1 + ENDIF +!- +!-- If there is no space wthin the line then the target is a scalar +!-- or the element of a properly written vector. +!-- (ie of the type TARGET__00001) +!- + IF ( (blk <= 1) & + & .OR.(tmp_str(1:1) == '"') & + & .OR.(tmp_str(1:1) == "'") ) THEN +!- + IF (nb_lastkey == 0) THEN +!------ Save info of current keyword as a scalar +!------ if it is not a continuation + targetlist(nb_lines) = key_str(1:MIN(LEN_TRIM(key_str),l_n)) + last_key = key_str(1:MIN(LEN_TRIM(key_str),l_n)) + nb_lastkey = 1 + ELSE +!------ We are continuing a vector so the keyword needs +!------ to get the underscores + WRITE(UNIT=cnt,FMT=c_i_fmt) nb_lastkey+1 + targetlist(nb_lines) = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + last_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + nb_lastkey = nb_lastkey+1 + ENDIF +!----- + fichier(nb_lines) = NEW_str(1:len_str) + fromfile(nb_lines) = current + ELSE +!- +!---- If there are blanks whithin the line then we are dealing +!---- with a vector and we need to split it in many entries +!---- with the TARGET__n notation. +!---- +!---- Test if the targer is not already a vector target ! +!- + IF (INDEX(TRIM(key_str),'__') > 0) THEN + CALL ipslerr (3,'getin_decrypt', & + & 'We have found a mixed vector notation (TARGET__n).', & + & 'The key at fault : '//TRIM(key_str),' ') + ENDIF +!- + nbve = nb_lastkey + nbve = nbve+1 + WRITE(UNIT=cnt,FMT=c_i_fmt) nbve +!- + DO WHILE (blk > 0) +!- +!------ Save the content of target__nbve +!- + fichier(nb_lines) = tmp_str(1:blk) + new_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n)) + fromfile(nb_lines) = current +!- + tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str)))) + blk = INDEX(TRIM(tmp_str),' ') +!- + IF (nb_lines+1 > i_txtsize) THEN + CALL getin_alloctxt () + ENDIF + nb_lines = nb_lines+1 + nbve = nbve+1 + WRITE(UNIT=cnt,FMT=c_i_fmt) nbve +!- + ENDDO +!- +!---- Save the content of the last target +!- + fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str)) + new_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n)) + fromfile(nb_lines) = current +!- + last_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + nb_lastkey = nbve +!- + ENDIF +!- + ENDIF +!--------------------------- +END SUBROUTINE getin_decrypt +!- +!=== +!- +SUBROUTINE getin_checkcohe () +!--------------------------------------------------------------------- +!- This subroutine checks for redundancies. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: line,n_k,k +!--------------------------------------------------------------------- + DO line=1,nb_lines-1 +!- + n_k = 0 + DO k=line+1,nb_lines + IF (TRIM(targetlist(line)) == TRIM(targetlist(k))) THEN + n_k = k + EXIT + ENDIF + ENDDO +!--- +!-- IF we have found it we have a problem to solve. +!--- + IF (n_k > 0) THEN + WRITE(*,*) 'COUNT : ',n_k + WRITE(*,*) & + & 'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line)) + WRITE(*,*) & + & 'getin_checkcohe : The following values were encoutered :' + WRITE(*,*) & + & ' ',TRIM(targetlist(line)),' == ',fichier(line) + WRITE(*,*) & + & ' ',TRIM(targetlist(k)),' == ',fichier(k) + WRITE(*,*) & + & 'getin_checkcohe : We will keep only the last value' + targetlist(line) = ' ' + ENDIF + ENDDO +!----------------------------- +END SUBROUTINE getin_checkcohe +!- +!=== +!- +SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: unit,eof,nb_lastkey + CHARACTER(LEN=100) :: dummy + CHARACTER(LEN=100) :: out_string + CHARACTER(LEN=1) :: first +!--------------------------------------------------------------------- + first="#" + eof = 0 + out_string = " " +!- + DO WHILE (first == "#") + READ (UNIT=unit,FMT='(A)',ERR=9998,END=7778) dummy + dummy = TRIM(ADJUSTL(dummy)) + first=dummy(1:1) + IF (first == "#") THEN + nb_lastkey = 0 + ENDIF + ENDDO + out_string=dummy +!- + RETURN +!- +9998 CONTINUE + CALL ipslerr (3,'getin_skipafew','Error while reading file',' ',' ') +!- +7778 CONTINUE + eof = 1 +!---------------------------- +END SUBROUTINE getin_skipafew +!- +!=== +!- +SUBROUTINE getin_allockeys () +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + TYPE(t_key),ALLOCATABLE,DIMENSION(:) :: tmp_key_tab + CHARACTER(LEN=100),ALLOCATABLE :: tmp_str(:) +!- + INTEGER :: ier + CHARACTER(LEN=20) :: c_tmp +!--------------------------------------------------------------------- + IF (keymemsize == 0) THEN +!--- +!-- Nothing exists in memory arrays and it is easy to do. +!--- + WRITE (UNIT=c_tmp,FMT=*) memslabs + ALLOCATE(key_tab(memslabs),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_allockeys', & + & 'Can not allocate key_tab', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + nb_keys = 0 + keymemsize = memslabs + key_tab(:)%keycompress = -1 +!--- + ELSE +!--- +!-- There is something already in the memory, +!-- we need to transfer and reallocate. +!--- + WRITE (UNIT=c_tmp,FMT=*) keymemsize + ALLOCATE(tmp_key_tab(keymemsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_allockeys', & + & 'Can not allocate tmp_key_tab', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + WRITE (UNIT=c_tmp,FMT=*) keymemsize+memslabs + tmp_key_tab(1:keymemsize) = key_tab(1:keymemsize) + DEALLOCATE(key_tab) + ALLOCATE(key_tab(keymemsize+memslabs),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_allockeys', & + & 'Can not allocate key_tab', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + key_tab(:)%keycompress = -1 + key_tab(1:keymemsize) = tmp_key_tab(1:keymemsize) + DEALLOCATE(tmp_key_tab) + keymemsize = keymemsize+memslabs + ENDIF +!----------------------------- +END SUBROUTINE getin_allockeys +!- +!=== +!- +SUBROUTINE getin_allocmem (type,len_wanted) +!--------------------------------------------------------------------- +!- Allocate the memory of the data base for all 4 types of memory +!- INTEGER / REAL / CHARACTER / LOGICAL +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: type,len_wanted +!- + INTEGER,ALLOCATABLE :: tmp_int(:) + REAL,ALLOCATABLE :: tmp_real(:) + CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:) + LOGICAL,ALLOCATABLE :: tmp_logic(:) + INTEGER :: ier + CHARACTER(LEN=20) :: c_tmp +!--------------------------------------------------------------------- + SELECT CASE (type) + CASE(k_i) + IF (i_memsize == 0) THEN + ALLOCATE(i_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + i_memsize=memslabs + ELSE + ALLOCATE(tmp_int(i_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) i_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_int', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_int(1:i_memsize) = i_mem(1:i_memsize) + DEALLOCATE(i_mem) + ALLOCATE(i_mem(i_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) i_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + i_mem(1:i_memsize) = tmp_int(1:i_memsize) + i_memsize = i_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_int) + ENDIF + CASE(k_r) + IF (r_memsize == 0) THEN + ALLOCATE(r_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + r_memsize = memslabs + ELSE + ALLOCATE(tmp_real(r_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) r_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_real', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_real(1:r_memsize) = r_mem(1:r_memsize) + DEALLOCATE(r_mem) + ALLOCATE(r_mem(r_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) r_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + r_mem(1:r_memsize) = tmp_real(1:r_memsize) + r_memsize = r_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_real) + ENDIF + CASE(k_c) + IF (c_memsize == 0) THEN + ALLOCATE(c_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + c_memsize = memslabs + ELSE + ALLOCATE(tmp_char(c_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) c_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_char', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_char(1:c_memsize) = c_mem(1:c_memsize) + DEALLOCATE(c_mem) + ALLOCATE(c_mem(c_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) c_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + c_mem(1:c_memsize) = tmp_char(1:c_memsize) + c_memsize = c_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_char) + ENDIF + CASE(k_l) + IF (l_memsize == 0) THEN + ALLOCATE(l_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + l_memsize = memslabs + ELSE + ALLOCATE(tmp_logic(l_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) l_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_logic', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_logic(1:l_memsize) = l_mem(1:l_memsize) + DEALLOCATE(l_mem) + ALLOCATE(l_mem(l_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) l_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + l_mem(1:l_memsize) = tmp_logic(1:l_memsize) + l_memsize = l_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_logic) + ENDIF + CASE DEFAULT + CALL ipslerr (3,'getin_allocmem','Unknown type of data',' ',' ') + END SELECT +!---------------------------- +END SUBROUTINE getin_allocmem +!- +!=== +!- +SUBROUTINE getin_alloctxt () +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=100),ALLOCATABLE :: tmp_fic(:) + CHARACTER(LEN=l_n),ALLOCATABLE :: tmp_tgl(:) + INTEGER,ALLOCATABLE :: tmp_int(:) +!- + INTEGER :: ier + CHARACTER(LEN=20) :: c_tmp1,c_tmp2 +!--------------------------------------------------------------------- + IF (i_txtsize == 0) THEN +!--- +!-- Nothing exists in memory arrays and it is easy to do. +!--- + WRITE (UNIT=c_tmp1,FMT=*) i_txtslab + ALLOCATE(fichier(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fichier', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + ALLOCATE(targetlist(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate targetlist', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + ALLOCATE(fromfile(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fromfile', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + ALLOCATE(compline(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate compline', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + nb_lines = 0 + i_txtsize = i_txtslab + ELSE +!--- +!-- There is something already in the memory, +!-- we need to transfer and reallocate. +!--- + WRITE (UNIT=c_tmp1,FMT=*) i_txtsize + WRITE (UNIT=c_tmp2,FMT=*) i_txtsize+i_txtslab + ALLOCATE(tmp_fic(i_txtsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate tmp_fic', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF + tmp_fic(1:i_txtsize) = fichier(1:i_txtsize) + DEALLOCATE(fichier) + ALLOCATE(fichier(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fichier', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + fichier(1:i_txtsize) = tmp_fic(1:i_txtsize) + DEALLOCATE(tmp_fic) +!--- + ALLOCATE(tmp_tgl(i_txtsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate tmp_tgl', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF + tmp_tgl(1:i_txtsize) = targetlist(1:i_txtsize) + DEALLOCATE(targetlist) + ALLOCATE(targetlist(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate targetlist', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + targetlist(1:i_txtsize) = tmp_tgl(1:i_txtsize) + DEALLOCATE(tmp_tgl) +!--- + ALLOCATE(tmp_int(i_txtsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate tmp_int', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF + tmp_int(1:i_txtsize) = fromfile(1:i_txtsize) + DEALLOCATE(fromfile) + ALLOCATE(fromfile(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fromfile', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + fromfile(1:i_txtsize) = tmp_int(1:i_txtsize) +!--- + tmp_int(1:i_txtsize) = compline(1:i_txtsize) + DEALLOCATE(compline) + ALLOCATE(compline(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate compline', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + compline(1:i_txtsize) = tmp_int(1:i_txtsize) + DEALLOCATE(tmp_int) +!--- + i_txtsize = i_txtsize+i_txtslab + ENDIF +!---------------------------- +END SUBROUTINE getin_alloctxt +!- +!=== +!- +SUBROUTINE getin_dump (fileprefix) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(*),OPTIONAL :: fileprefix +!- + CHARACTER(LEN=80) :: usedfileprefix + INTEGER :: ikey,if,iff,iv + CHARACTER(LEN=20) :: c_tmp + CHARACTER(LEN=100) :: tmp_str,used_filename + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (PRESENT(fileprefix)) THEN + usedfileprefix = fileprefix(1:MIN(LEN_TRIM(fileprefix),80)) + ELSE + usedfileprefix = "used" + ENDIF +!- + DO if=1,nbfiles +!--- + used_filename = TRIM(usedfileprefix)//'_'//TRIM(filelist(if)) + IF (check) THEN + WRITE(*,*) & + & 'GETIN_DUMP : opens file : ',TRIM(used_filename),' if = ',if + WRITE(*,*) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys + ENDIF + OPEN (UNIT=22,FILE=used_filename) +!--- +!-- If this is the first file we need to add the list +!-- of file which belong to it + IF ( (if == 1).AND.(nbfiles > 1) ) THEN + WRITE(22,*) '# ' + WRITE(22,*) '# This file is linked to the following files :' + WRITE(22,*) '# ' + DO iff=2,nbfiles + WRITE(22,*) 'INCLUDEDEF = ',TRIM(filelist(iff)) + ENDDO + WRITE(22,*) '# ' + ENDIF +!--- + DO ikey=1,nb_keys +!----- +!---- Is this key from this file ? + IF (key_tab(ikey)%keyfromfile == if) THEN +!------- +!------ Write some comments + WRITE(22,*) '#' + SELECT CASE (key_tab(ikey)%keystatus) + CASE(1) + WRITE(22,*) '# Values of ', & + & TRIM(key_tab(ikey)%keystr),' comes from the run.def.' + CASE(2) + WRITE(22,*) '# Values of ', & + & TRIM(key_tab(ikey)%keystr),' are all defaults.' + CASE(3) + WRITE(22,*) '# Values of ', & + & TRIM(key_tab(ikey)%keystr), & + & ' are a mix of run.def and defaults.' + CASE DEFAULT + WRITE(22,*) '# Dont know from where the value of ', & + & TRIM(key_tab(ikey)%keystr),' comes.' + END SELECT + WRITE(22,*) '#' +!------- +!------ Write the values + SELECT CASE (key_tab(ikey)%keytype) + CASE(k_i) + IF (key_tab(ikey)%keymemlen == 1) THEN + IF (key_tab(ikey)%keycompress < 0) THEN + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',i_mem(key_tab(ikey)%keymemstart) + ELSE + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',key_tab(ikey)%keycompress, & + & ' * ',i_mem(key_tab(ikey)%keymemstart) + ENDIF + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & '__',TRIM(ADJUSTL(c_tmp)), & + & ' = ',i_mem(key_tab(ikey)%keymemstart+iv) + ENDDO + ENDIF + CASE(k_r) + IF (key_tab(ikey)%keymemlen == 1) THEN + IF (key_tab(ikey)%keycompress < 0) THEN + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',r_mem(key_tab(ikey)%keymemstart) + ELSE + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',key_tab(ikey)%keycompress, & + & ' * ',r_mem(key_tab(ikey)%keymemstart) + ENDIF + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr),'__',TRIM(ADJUSTL(c_tmp)), & + & ' = ',r_mem(key_tab(ikey)%keymemstart+iv) + ENDDO + ENDIF + CASE(k_c) + IF (key_tab(ikey)%keymemlen == 1) THEN + tmp_str = c_mem(key_tab(ikey)%keymemstart) + WRITE(22,*) TRIM(key_tab(ikey)%keystr), & + & ' = ',TRIM(tmp_str) + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + tmp_str = c_mem(key_tab(ikey)%keymemstart+iv) + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & '__',TRIM(ADJUSTL(c_tmp)), & + & ' = ',TRIM(tmp_str) + ENDDO + ENDIF + CASE(k_l) + IF (key_tab(ikey)%keymemlen == 1) THEN + IF (l_mem(key_tab(ikey)%keymemstart)) THEN + WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = TRUE ' + ELSE + WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = FALSE ' + ENDIF + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + IF (l_mem(key_tab(ikey)%keymemstart+iv)) THEN + WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', & + & TRIM(ADJUSTL(c_tmp)),' = TRUE ' + ELSE + WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', & + & TRIM(ADJUSTL(c_tmp)),' = FALSE ' + ENDIF + ENDDO + ENDIF + CASE DEFAULT + CALL ipslerr (3,'getin_dump', & + & 'Unknown type for variable '//TRIM(key_tab(ikey)%keystr), & + & ' ',' ') + END SELECT + ENDIF + ENDDO +!- + CLOSE(UNIT=22) +!- + ENDDO +!------------------------ +END SUBROUTINE getin_dump +!=== +SUBROUTINE get_qtyp (k_typ,c_vtyp,i_v,r_v,c_v,l_v) +!--------------------------------------------------------------------- +!- Returns the type of the argument (mutually exclusive) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(OUT) :: k_typ + CHARACTER(LEN=*),INTENT(OUT) :: c_vtyp + INTEGER,DIMENSION(:),OPTIONAL :: i_v + REAL,DIMENSION(:),OPTIONAL :: r_v + LOGICAL,DIMENSION(:),OPTIONAL :: l_v + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_v +!--------------------------------------------------------------------- + k_typ = 0 + IF (COUNT((/PRESENT(i_v),PRESENT(r_v),PRESENT(c_v),PRESENT(l_v)/)) & + & /= 1) THEN + CALL ipslerr (3,'get_qtyp', & + & 'Invalid number of optional arguments','(/= 1)',' ') + ENDIF +!- + IF (PRESENT(i_v)) THEN + k_typ = k_i + c_vtyp = 'INTEGER' + ELSEIF (PRESENT(r_v)) THEN + k_typ = k_r + c_vtyp = 'REAL' + ELSEIF (PRESENT(c_v)) THEN + k_typ = k_c + c_vtyp = 'CHARACTER' + ELSEIF (PRESENT(l_v)) THEN + k_typ = k_l + c_vtyp = 'LOGICAL' + ENDIF +!---------------------- +END SUBROUTINE get_qtyp +!=== +SUBROUTINE get_findkey (i_tab,c_key,pos) +!--------------------------------------------------------------------- +!- This subroutine looks for a key in a table +!--------------------------------------------------------------------- +!- INPUT +!- i_tab : 1 -> search in key_tab(1:nb_keys)%keystr +!- 2 -> search in targetlist(1:nb_lines) +!- c_key : Name of the key we are looking for +!- OUTPUT +!- pos : -1 if key not found, else value in the table +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(in) :: i_tab + CHARACTER(LEN=*),INTENT(in) :: c_key + INTEGER,INTENT(out) :: pos +!- + INTEGER :: ikey_max,ikey + CHARACTER(LEN=l_n) :: c_q_key +!--------------------------------------------------------------------- + pos = -1 + IF (i_tab == 1) THEN + ikey_max = nb_keys + ELSEIF (i_tab == 2) THEN + ikey_max = nb_lines + ELSE + ikey_max = 0 + ENDIF + IF ( ikey_max > 0 ) THEN + DO ikey=1,ikey_max + IF (i_tab == 1) THEN + c_q_key = key_tab(ikey)%keystr + ELSE + c_q_key = targetlist(ikey) + ENDIF + IF (TRIM(c_q_key) == TRIM(c_key)) THEN + pos = ikey + EXIT + ENDIF + ENDDO + ENDIF +!------------------------- +END SUBROUTINE get_findkey +!=== +!------------------ +END MODULE ioipsl_getincom Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/ioipsl_stringop.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/ioipsl_stringop.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/ioipsl_stringop.F90 (revision 1280) @@ -0,0 +1,243 @@ +! +! $Id$ +! +! Module/Routines extracted from IOIPSL v2_1_8 +! +MODULE ioipsl_stringop +!- +!$Id: stringop.f90 386 2008-09-04 08:38:48Z bellier $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +!- + INTEGER,DIMENSION(30) :: & + & prime=(/1,2,3,5,7,11,13,17,19,23,29,31,37,41,43, & + & 47,53,59,61,67,71,73,79,83,89,97,101,103,107,109/) +!- +!--------------------------------------------------------------------- +CONTAINS +!= +SUBROUTINE cmpblank (str) +!--------------------------------------------------------------------- +!- Compact blanks +!--------------------------------------------------------------------- + CHARACTER(LEN=*),INTENT(inout) :: str +!- + INTEGER :: lcc,ipb +!--------------------------------------------------------------------- + lcc = LEN_TRIM(str) + ipb = 1 + DO + IF (ipb >= lcc) EXIT + IF (str(ipb:ipb+1) == ' ') THEN + str(ipb+1:) = str(ipb+2:lcc) + lcc = lcc-1 + ELSE + ipb = ipb+1 + ENDIF + ENDDO +!---------------------- +END SUBROUTINE cmpblank +!=== +INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r) +!--------------------------------------------------------------------- +!- Finds number of occurences of c_r in c_c +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(in) :: c_c + INTEGER,INTENT(IN) :: l_c + CHARACTER(LEN=*),INTENT(in) :: c_r + INTEGER,INTENT(IN) :: l_r +!- + INTEGER :: ipos,indx +!--------------------------------------------------------------------- + cntpos = 0 + ipos = 1 + DO + indx = INDEX(c_c(ipos:l_c),c_r(1:l_r)) + IF (indx > 0) THEN + cntpos = cntpos+1 + ipos = ipos+indx+l_r-1 + ELSE + EXIT + ENDIF + ENDDO +!------------------ +END FUNCTION cntpos +!=== +INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r) +!--------------------------------------------------------------------- +!- Finds position of c_r in c_c +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(in) :: c_c + INTEGER,INTENT(IN) :: l_c + CHARACTER(LEN=*),INTENT(in) :: c_r + INTEGER,INTENT(IN) :: l_r +!--------------------------------------------------------------------- + findpos = INDEX(c_c(1:l_c),c_r(1:l_r)) + IF (findpos == 0) findpos=-1 +!------------------- +END FUNCTION findpos +!=== +SUBROUTINE find_str (str_tab,str,pos) +!--------------------------------------------------------------------- +!- This subroutine looks for a string in a table +!--------------------------------------------------------------------- +!- INPUT +!- str_tab : Table of strings +!- str : Target we are looking for +!- OUTPUT +!- pos : -1 if str not found, else value in the table +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab + CHARACTER(LEN=*),INTENT(in) :: str + INTEGER,INTENT(out) :: pos +!- + INTEGER :: nb_str,i +!--------------------------------------------------------------------- + pos = -1 + nb_str=SIZE(str_tab) + IF ( nb_str > 0 ) THEN + DO i=1,nb_str + IF ( TRIM(str_tab(i)) == TRIM(str) ) THEN + pos = i + EXIT + ENDIF + ENDDO + ENDIF +!---------------------- +END SUBROUTINE find_str +!=== +SUBROUTINE nocomma (str) +!--------------------------------------------------------------------- +!- Replace commas with blanks +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: str +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,LEN_TRIM(str) + IF (str(i:i) == ',') str(i:i) = ' ' + ENDDO +!--------------------- +END SUBROUTINE nocomma +!=== +SUBROUTINE strlowercase (str) +!--------------------------------------------------------------------- +!- Converts a string into lowercase +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: str +!- + INTEGER :: i,ic +!--------------------------------------------------------------------- + DO i=1,LEN_TRIM(str) + ic = IACHAR(str(i:i)) + IF ( (ic >= 65).AND.(ic <= 90) ) str(i:i) = ACHAR(ic+32) + ENDDO +!-------------------------- +END SUBROUTINE strlowercase +!=== +SUBROUTINE struppercase (str) +!--------------------------------------------------------------------- +!- Converts a string into uppercase +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: str +!- + INTEGER :: i,ic +!--------------------------------------------------------------------- + DO i=1,LEN_TRIM(str) + ic = IACHAR(str(i:i)) + IF ( (ic >= 97).AND.(ic <= 122) ) str(i:i) = ACHAR(ic-32) + ENDDO +!-------------------------- +END SUBROUTINE struppercase +!=== +SUBROUTINE gensig (str,sig) +!--------------------------------------------------------------------- +!- Generate a signature from the first 30 characters of the string +!- This signature is not unique and thus when one looks for the +!- one needs to also verify the string. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: str + INTEGER :: sig +!- + INTEGER :: i +!--------------------------------------------------------------------- + sig = 0 + DO i=1,MIN(LEN_TRIM(str),30) + sig = sig + prime(i)*IACHAR(str(i:i)) + ENDDO +!-------------------- +END SUBROUTINE gensig +!=== +SUBROUTINE find_sig (nb_sig,str_tab,str,sig_tab,sig,pos) +!--------------------------------------------------------------------- +!- Find the string signature in a list of signatures +!--------------------------------------------------------------------- +!- INPUT +!- nb_sig : length of table of signatures +!- str_tab : Table of strings +!- str : Target string we are looking for +!- sig_tab : Table of signatures +!- sig : Target signature we are looking for +!- OUTPUT +!- pos : -1 if str not found, else value in the table +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb_sig + CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab + CHARACTER(LEN=*) :: str + INTEGER,DIMENSION(nb_sig) :: sig_tab + INTEGER :: sig +!- + INTEGER :: pos + INTEGER,DIMENSION(nb_sig) :: loczeros +!- + INTEGER :: il,len + INTEGER,DIMENSION(1) :: minpos +!--------------------------------------------------------------------- + pos = -1 + il = LEN_TRIM(str) +!- + IF ( nb_sig > 0 ) THEN + loczeros = ABS(sig_tab(1:nb_sig)-sig) + IF ( COUNT(loczeros < 1) == 1 ) THEN + minpos = MINLOC(loczeros) + len = LEN_TRIM(str_tab(minpos(1))) + IF ( (INDEX(str_tab(minpos(1)),str(1:il)) > 0) & + .AND.(len == il) ) THEN + pos = minpos(1) + ENDIF + ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN + DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 ) + minpos = MINLOC(loczeros) + len = LEN_TRIM(str_tab(minpos(1))) + IF ( (INDEX(str_tab(minpos(1)),str(1:il)) > 0) & + .AND.(len == il) ) THEN + pos = minpos(1) + ELSE + loczeros(minpos(1)) = 99999 + ENDIF + ENDDO + ENDIF + ENDIF +!----------------------- + END SUBROUTINE find_sig +!=== +!------------------ +END MODULE ioipsl_stringop Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/lnblnk.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/lnblnk.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/lnblnk.F (revision 1280) @@ -0,0 +1,39 @@ +! +! $Header$ +! + INTEGER FUNCTION lnblnk (letter) + +C-------------------------------------------------------- +C Fonction qui determine la longeur d'un string sans les +C blancs qui suivent. Le critere pour determiner la fin du +C string est, trois blancs de suite +C--------------------------------------------------------- +C ARGUMENTS +C +++++++++ +C letter: CHARACTER*xxx (xxx < imax) +C le string dont on determine la longuer +C lnblnk: INTEGER +C le nombre de characteres +C +C PARAMETER +C +++++++++ +C imax : INTEGER +C le nombre maximale de character que peut contenir le string +C a traiter + + IMPLICIT NONE + INTEGER i,imax + PARAMETER (imax = 256) + CHARACTER*256 letter + + i=0 + +10 i=i+1 + IF (letter(i:i+3) . EQ . ' ') GOTO 20 + GOTO 10 + +20 lnblnk=i-1 + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/misc_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/misc_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/misc_mod.F90 (revision 1280) @@ -0,0 +1,6 @@ +module misc_mod + integer,save :: itaumax + logical,save :: adjust + integer,save :: ItCount + logical,save :: debug +end module misc_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/netcdf95.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/netcdf95.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/netcdf95.F90 (revision 1280) @@ -0,0 +1,45 @@ +! $Id$ +module netcdf95 + + ! Author: Lionel GUEZ + + ! Three criticisms may be made about the Fortran 90 NetCDF interface: + + ! -- NetCDF procedures are usually functions with side effects. + ! First, they have "intent(out)" arguments. + ! Furthermore, there is obviously data transfer inside the procedures. + ! Any data transfer inside a function is considered as a side effect. + + ! -- The caller of a NetCDF procedure usually has to handle the error + ! status. NetCDF procedures would be much friendlier if they behaved + ! like the Fortran input/output statements. That is, the error status + ! should be an optional output argument. + ! If the caller does not request the error status and there is an + ! error then the NetCDF procedure should produce an error message + ! and stop the program. + + ! -- Some procedures use array arguments with assumed size. + ! It would be better to use the pointer attribute. + + ! This module produces a NetCDF interface that answers those three + ! criticisms for some (not all) procedures. + + ! "nf95_get_att" is more secure than "nf90_get_att" because it + ! checks that the "values" argument is long enough and removes the + ! null terminator, if any. + + ! This module replaces some of the official NetCDF procedures. + ! This module also provides the procedures "handle_err" and "nf95_gw_var". + + ! This module provides only a partial replacement for some generic + ! procedures such as "nf90_def_var". + + use nf95_def_var_m + use nf95_put_var_m + use nf95_gw_var_m + use nf95_put_att_m + use nf95_get_att_m + use simple + use handle_err_m + +end module netcdf95 Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/nf95_def_var_m.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/nf95_def_var_m.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/nf95_def_var_m.F90 (revision 1280) @@ -0,0 +1,102 @@ +! $Id$ +module nf95_def_var_m + + ! The generic procedure name "nf90_def_var" applies to + ! "nf90_def_var_Scalar" but we cannot apply the generic procedure name + ! "nf95_def_var" to "nf95_def_var_scalar" because of the additional + ! optional argument. + ! "nf95_def_var_scalar" cannot be distinguished from "nf95_def_var_oneDim". + + implicit none + + interface nf95_def_var + module procedure nf95_def_var_oneDim, nf95_def_var_ManyDims + end interface + + private + public nf95_def_var, nf95_def_var_scalar + +contains + + subroutine nf95_def_var_scalar(ncid, name, xtype, varid, ncerr) + + use netcdf, only: nf90_def_var + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid + character (len = *), intent( in) :: name + integer, intent( in) :: xtype + integer, intent(out) :: varid + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_def_var(ncid, name, xtype, varid) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_def_var_scalar " // name, ncerr_not_opt, ncid) + end if + + end subroutine nf95_def_var_scalar + + !*********************** + + subroutine nf95_def_var_oneDim(ncid, name, xtype, dimids, varid, ncerr) + + use netcdf, only: nf90_def_var + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid + character (len = *), intent( in) :: name + integer, intent( in) :: xtype + integer, intent( in) :: dimids + integer, intent(out) :: varid + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_def_var(ncid, name, xtype, dimids, varid) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_def_var_oneDim " // name, ncerr_not_opt, ncid) + end if + + end subroutine nf95_def_var_oneDim + + !*********************** + + subroutine nf95_def_var_ManyDims(ncid, name, xtype, dimids, varid, ncerr) + + use netcdf, only: nf90_def_var + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid + character (len = *), intent( in) :: name + integer, intent( in) :: xtype + integer, dimension(:), intent( in) :: dimids + integer, intent(out) :: varid + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_def_var(ncid, name, xtype, dimids, varid) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_def_var_ManyDims " // name, ncerr_not_opt, ncid) + end if + + end subroutine nf95_def_var_ManyDims + +end module nf95_def_var_m Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/nf95_get_att_m.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/nf95_get_att_m.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/nf95_get_att_m.F90 (revision 1280) @@ -0,0 +1,60 @@ +! $Id$ +module nf95_get_att_m + + implicit none + + interface nf95_get_att + module procedure nf95_get_att_text + end interface + + private + public nf95_get_att + +contains + + subroutine nf95_get_att_text(ncid, varid, name, values, ncerr) + + use netcdf, only: nf90_get_att, nf90_inquire_attribute, nf90_noerr + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid, varid + character(len = *), intent( in) :: name + character(len = *), intent(out) :: values + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + integer att_len + + !------------------- + + ! Check that the length of "values" is large enough: + ncerr_not_opt = nf90_inquire_attribute(ncid, varid, name, len=att_len) + call handle_err("nf95_get_att_text nf90_inquire_attribute " & + // trim(name), ncerr_not_opt, ncid, varid) + if (len(values) < att_len) then + print *, "nf95_get_att_text" + print *, "varid = ", varid + print *, "attribute name: ", name + print *, 'length of "values" is not large enough' + print *, "len(values) = ", len(values) + print *, "number of characters in attribute: ", att_len + stop 1 + end if + + values = "" ! useless in NetCDF version 3.6.2 or better + ncerr_not_opt = nf90_get_att(ncid, varid, name, values) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_get_att_text", ncerr_not_opt, ncid, varid) + end if + + if (att_len >= 1 .and. ncerr_not_opt == nf90_noerr) then + ! Remove null terminator, if any: + if (iachar(values(att_len:att_len)) == 0) values(att_len:att_len) = " " + end if + + end subroutine nf95_get_att_text + +end module nf95_get_att_m Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/nf95_gw_var_m.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/nf95_gw_var_m.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/nf95_gw_var_m.F90 (revision 1280) @@ -0,0 +1,338 @@ +! $Id$ +module nf95_gw_var_m + + implicit none + + interface nf95_gw_var + ! "nf95_gw_var" stands for "NetCDF 1995 get whole variable". + ! These procedures read a whole NetCDF variable (coordinate or + ! primary) into an array. + ! The difference between the procedures is the rank of the array + ! and the type of Fortran values. + ! The procedures do not check the type of the NetCDF variable. + +!!$ module procedure nf95_gw_var_real_1d, nf95_gw_var_real_2d, & +!!$ nf95_gw_var_real_3d, nf95_gw_var_real_4d, nf95_gw_var_dble_1d, & +!!$ nf95_gw_var_dble_3d, nf95_gw_var_int_1d, nf95_gw_var_int_3d + module procedure nf95_gw_var_real_1d, nf95_gw_var_real_2d, & + nf95_gw_var_real_3d, nf95_gw_var_real_4d, nf95_gw_var_int_1d, & + nf95_gw_var_int_3d + end interface + + private + public nf95_gw_var + +contains + + subroutine nf95_gw_var_real_1d(ncid, varid, values) + + ! Real type, the array has rank 1. + + use netcdf, only: NF90_GET_VAR + use simple, only: nf95_inquire_variable, nf95_inquire_dimension + use handle_err_m, only: handle_err + + integer, intent(in):: ncid + integer, intent(in):: varid + real, pointer:: values(:) + + ! Variables local to the procedure: + integer ierr, len + integer, pointer :: dimids(:) + + !--------------------- + + call nf95_inquire_variable(ncid, varid, dimids=dimids) + + if (size(dimids) /= 1) then + print *, "nf95_gw_var_real_1d: NetCDF variable is not of rank 1" + stop 1 + end if + + call nf95_inquire_dimension(ncid, dimids(1), len=len) + deallocate(dimids) ! pointer + + allocate(values(len)) + if (len /= 0) then + ierr = NF90_GET_VAR(ncid, varid, values) + call handle_err("NF90_GET_VAR", ierr, ncid, varid) + end if + + end subroutine nf95_gw_var_real_1d + + !************************************ + + subroutine nf95_gw_var_real_2d(ncid, varid, values) + + ! Real type, the array has rank 2. + + use netcdf, only: NF90_GET_VAR + use simple, only: nf95_inquire_variable, nf95_inquire_dimension + use handle_err_m, only: handle_err + + integer, intent(in):: ncid + integer, intent(in):: varid + real, pointer:: values(:, :) + + ! Variables local to the procedure: + integer ierr, len1, len2 + integer, pointer :: dimids(:) + + !--------------------- + + call nf95_inquire_variable(ncid, varid, dimids=dimids) + + if (size(dimids) /= 2) then + print *, "nf95_gw_var_real_2d: NetCDF variable is not of rank 2" + stop 1 + end if + + call nf95_inquire_dimension(ncid, dimids(1), len=len1) + call nf95_inquire_dimension(ncid, dimids(2), len=len2) + deallocate(dimids) ! pointer + + allocate(values(len1, len2)) + if (len1 /= 0 .and. len2 /= 0) then + ierr = NF90_GET_VAR(ncid, varid, values) + call handle_err("NF90_GET_VAR", ierr, ncid, varid) + end if + + end subroutine nf95_gw_var_real_2d + + !************************************ + + subroutine nf95_gw_var_real_3d(ncid, varid, values) + + ! Real type, the array has rank 3. + + use netcdf, only: NF90_GET_VAR + use simple, only: nf95_inquire_variable, nf95_inquire_dimension + use handle_err_m, only: handle_err + + integer, intent(in):: ncid + integer, intent(in):: varid + real, pointer:: values(:, :, :) + + ! Variables local to the procedure: + integer ierr, len1, len2, len3 + integer, pointer :: dimids(:) + + !--------------------- + + call nf95_inquire_variable(ncid, varid, dimids=dimids) + + if (size(dimids) /= 3) then + print *, "nf95_gw_var_real_3d: NetCDF variable is not of rank 3" + stop 1 + end if + + call nf95_inquire_dimension(ncid, dimids(1), len=len1) + call nf95_inquire_dimension(ncid, dimids(2), len=len2) + call nf95_inquire_dimension(ncid, dimids(3), len=len3) + deallocate(dimids) ! pointer + + allocate(values(len1, len2, len3)) + if (len1 * len2 * len3 /= 0) then + ierr = NF90_GET_VAR(ncid, varid, values) + call handle_err("NF90_GET_VAR", ierr, ncid, varid) + end if + + end subroutine nf95_gw_var_real_3d + + !************************************ + + subroutine nf95_gw_var_real_4d(ncid, varid, values) + + ! Real type, the array has rank 4. + + use netcdf, only: NF90_GET_VAR + use simple, only: nf95_inquire_variable, nf95_inquire_dimension + use handle_err_m, only: handle_err + + integer, intent(in):: ncid + integer, intent(in):: varid + real, pointer:: values(:, :, :, :) + + ! Variables local to the procedure: + integer ierr, len_dim(4), i + integer, pointer :: dimids(:) + + !--------------------- + + call nf95_inquire_variable(ncid, varid, dimids=dimids) + + if (size(dimids) /= 4) then + print *, "nf95_gw_var_real_4d: NetCDF variable is not of rank 4" + stop 1 + end if + + do i = 1, 4 + call nf95_inquire_dimension(ncid, dimids(i), len=len_dim(i)) + end do + deallocate(dimids) ! pointer + + allocate(values(len_dim(1), len_dim(2), len_dim(3), len_dim(4))) + if (all(len_dim /= 0)) then + ierr = NF90_GET_VAR(ncid, varid, values) + call handle_err("NF90_GET_VAR", ierr, ncid, varid) + end if + + end subroutine nf95_gw_var_real_4d + + !************************************ + +!!$ subroutine nf95_gw_var_dble_1d(ncid, varid, values) +!!$ +!!$ ! Double precision, the array has rank 1. +!!$ +!!$ use netcdf, only: NF90_GET_VAR +!!$ use simple, only: nf95_inquire_variable, nf95_inquire_dimension +!!$ use handle_err_m, only: handle_err +!!$ +!!$ integer, intent(in):: ncid +!!$ integer, intent(in):: varid +!!$ double precision, pointer:: values(:) +!!$ +!!$ ! Variables local to the procedure: +!!$ integer ierr, len +!!$ integer, pointer :: dimids(:) +!!$ +!!$ !--------------------- +!!$ +!!$ call nf95_inquire_variable(ncid, varid, dimids=dimids) +!!$ +!!$ if (size(dimids) /= 1) then +!!$ print *, "nf95_gw_var_dble_1d: NetCDF variable is not of rank 1" +!!$ stop 1 +!!$ end if +!!$ +!!$ call nf95_inquire_dimension(ncid, dimids(1), len=len) +!!$ deallocate(dimids) ! pointer +!!$ +!!$ allocate(values(len)) +!!$ if (len /= 0) then +!!$ ierr = NF90_GET_VAR(ncid, varid, values) +!!$ call handle_err("NF90_GET_VAR", ierr, ncid, varid) +!!$ end if +!!$ +!!$ end subroutine nf95_gw_var_dble_1d +!!$ +!!$ !************************************ +!!$ +!!$ subroutine nf95_gw_var_dble_3d(ncid, varid, values) +!!$ +!!$ ! Double precision, the array has rank 3. +!!$ +!!$ use netcdf, only: NF90_GET_VAR +!!$ use simple, only: nf95_inquire_variable, nf95_inquire_dimension +!!$ use handle_err_m, only: handle_err +!!$ +!!$ integer, intent(in):: ncid +!!$ integer, intent(in):: varid +!!$ double precision, pointer:: values(:, :, :) +!!$ +!!$ ! Variables local to the procedure: +!!$ integer ierr, len1, len2, len3 +!!$ integer, pointer :: dimids(:) +!!$ +!!$ !--------------------- +!!$ +!!$ call nf95_inquire_variable(ncid, varid, dimids=dimids) +!!$ +!!$ if (size(dimids) /= 3) then +!!$ print *, "nf95_gw_var_dble_3d: NetCDF variable is not of rank 3" +!!$ stop 1 +!!$ end if +!!$ +!!$ call nf95_inquire_dimension(ncid, dimids(1), len=len1) +!!$ call nf95_inquire_dimension(ncid, dimids(2), len=len2) +!!$ call nf95_inquire_dimension(ncid, dimids(3), len=len3) +!!$ deallocate(dimids) ! pointer +!!$ +!!$ allocate(values(len1, len2, len3)) +!!$ if (len1 * len2 * len3 /= 0) then +!!$ ierr = NF90_GET_VAR(ncid, varid, values) +!!$ call handle_err("NF90_GET_VAR", ierr, ncid, varid) +!!$ end if +!!$ +!!$ end subroutine nf95_gw_var_dble_3d + + !************************************ + + subroutine nf95_gw_var_int_1d(ncid, varid, values) + + ! Integer type, the array has rank 1. + + use netcdf, only: NF90_GET_VAR + use simple, only: nf95_inquire_variable, nf95_inquire_dimension + use handle_err_m, only: handle_err + + integer, intent(in):: ncid + integer, intent(in):: varid + integer, pointer:: values(:) + + ! Variables local to the procedure: + integer ierr, len + integer, pointer :: dimids(:) + + !--------------------- + + call nf95_inquire_variable(ncid, varid, dimids=dimids) + + if (size(dimids) /= 1) then + print *, "nf95_gw_var_int_1d: NetCDF variable is not of rank 1" + stop 1 + end if + + call nf95_inquire_dimension(ncid, dimids(1), len=len) + deallocate(dimids) ! pointer + + allocate(values(len)) + if (len /= 0) then + ierr = NF90_GET_VAR(ncid, varid, values) + call handle_err("NF90_GET_VAR", ierr, ncid, varid) + end if + + end subroutine nf95_gw_var_int_1d + + !************************************ + + subroutine nf95_gw_var_int_3d(ncid, varid, values) + + ! Integer type, the array has rank 3. + + use netcdf, only: NF90_GET_VAR + use simple, only: nf95_inquire_variable, nf95_inquire_dimension + use handle_err_m, only: handle_err + + integer, intent(in):: ncid + integer, intent(in):: varid + integer, pointer:: values(:, :, :) + + ! Variables local to the procedure: + integer ierr, len1, len2, len3 + integer, pointer :: dimids(:) + + !--------------------- + + call nf95_inquire_variable(ncid, varid, dimids=dimids) + + if (size(dimids) /= 3) then + print *, "nf95_gw_var_int_3d: NetCDF variable is not of rank 3" + stop 1 + end if + + call nf95_inquire_dimension(ncid, dimids(1), len=len1) + call nf95_inquire_dimension(ncid, dimids(2), len=len2) + call nf95_inquire_dimension(ncid, dimids(3), len=len3) + deallocate(dimids) ! pointer + + allocate(values(len1, len2, len3)) + if (len1 * len2 * len3 /= 0) then + ierr = NF90_GET_VAR(ncid, varid, values) + call handle_err("NF90_GET_VAR", ierr, ncid, varid) + end if + + end subroutine nf95_gw_var_int_3d + +end module nf95_gw_var_m Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/nf95_put_att_m.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/nf95_put_att_m.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/nf95_put_att_m.F90 (revision 1280) @@ -0,0 +1,67 @@ +! $Id$ +module nf95_put_att_m + + implicit none + + interface nf95_put_att + module procedure nf95_put_att_text, nf95_put_att_one_FourByteInt + end interface + + private + public nf95_put_att + +contains + + subroutine nf95_put_att_text(ncid, varid, name, values, ncerr) + + use netcdf, only: nf90_put_att + use handle_err_m, only: handle_err + + integer, intent(in) :: ncid, varid + character(len = *), intent(in) :: name + character(len = *), intent(in) :: values + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_att(ncid, varid, name, values) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_att_text", ncerr_not_opt, ncid, varid) + end if + + end subroutine nf95_put_att_text + + !************************************ + + subroutine nf95_put_att_one_FourByteInt(ncid, varid, name, values, ncerr) + + use netcdf, only: nf90_put_att + use handle_err_m, only: handle_err + use typesizes, only: FourByteInt + + integer, intent(in) :: ncid, varid + character(len = *), intent(in) :: name + integer(kind = FourByteInt), intent(in) :: values + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_att(ncid, varid, name, values) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_att_one_FourByteInt", ncerr_not_opt, ncid, & + varid) + end if + + end subroutine nf95_put_att_one_FourByteInt + +end module nf95_put_att_m Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/nf95_put_var_m.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/nf95_put_var_m.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/nf95_put_var_m.F90 (revision 1280) @@ -0,0 +1,279 @@ +! $Id$ +module nf95_put_var_m + + implicit none + + interface nf95_put_var + module procedure nf95_put_var_FourByteReal, nf95_put_var_FourByteInt, & + nf95_put_var_1D_FourByteReal, nf95_put_var_1D_FourByteInt, & + nf95_put_var_2D_FourByteReal, nf95_put_var_3D_FourByteReal, & + nf95_put_var_4D_FourByteReal +!!$ module procedure nf95_put_var_1D_FourByteReal, & +!!$ nf95_put_var_2D_FourByteReal, nf95_put_var_3D_FourByteReal, & +!!$ nf95_put_var_4D_FourByteReal, nf90_put_var_1D_EightByteReal, & +!!$ nf90_put_var_3D_EightByteReal + end interface + + private + public nf95_put_var + +contains + + subroutine nf95_put_var_FourByteReal(ncid, varid, values, start, ncerr) + + use netcdf, only: nf90_put_var + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid, varid + real, intent( in) :: values + integer, dimension(:), optional, intent( in) :: start + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_var(ncid, varid, values, start) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_var_FourByteReal", ncerr_not_opt, ncid, & + varid) + end if + + end subroutine nf95_put_var_FourByteReal + + !*********************** + + subroutine nf95_put_var_FourByteInt(ncid, varid, values, start, ncerr) + + use netcdf, only: nf90_put_var + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid, varid + integer, intent( in) :: values + integer, dimension(:), optional, intent( in) :: start + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_var(ncid, varid, values, start) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_var_FourByteInt", ncerr_not_opt, ncid, & + varid) + end if + + end subroutine nf95_put_var_FourByteInt + + !*********************** + + subroutine nf95_put_var_1D_FourByteReal(ncid, varid, values, start, count, & + stride, map, ncerr) + + use netcdf, only: nf90_put_var + use handle_err_m, only: handle_err + + integer, intent(in) :: ncid, varid + real, intent(in) :: values(:) + integer, dimension(:), optional, intent(in) :: start, count, stride, map + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, & + map) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_var_1D_FourByteReal", ncerr_not_opt, ncid, & + varid) + end if + + end subroutine nf95_put_var_1D_FourByteReal + + !*********************** + + subroutine nf95_put_var_1D_FourByteInt(ncid, varid, values, start, count, & + stride, map, ncerr) + + use netcdf, only: nf90_put_var + use handle_err_m, only: handle_err + + integer, intent(in) :: ncid, varid + integer, intent(in) :: values(:) + integer, dimension(:), optional, intent(in) :: start, count, stride, map + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, & + map) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_var_1D_FourByteInt", ncerr_not_opt, ncid, & + varid) + end if + + end subroutine nf95_put_var_1D_FourByteInt + + !*********************** + + subroutine nf95_put_var_2D_FourByteReal(ncid, varid, values, start, count, & + stride, map, ncerr) + + use netcdf, only: nf90_put_var + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid, varid + real, intent( in) :: values(:, :) + integer, dimension(:), optional, intent( in) :: start, count, stride, map + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, & + map) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_var_2D_FourByteReal", ncerr_not_opt, ncid, & + varid) + end if + + end subroutine nf95_put_var_2D_FourByteReal + + !*********************** + + subroutine nf95_put_var_3D_FourByteReal(ncid, varid, values, start, count, & + stride, map, ncerr) + + use netcdf, only: nf90_put_var + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid, varid + real, intent( in) :: values(:, :, :) + integer, dimension(:), optional, intent( in) :: start, count, stride, map + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, & + map) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_var_3D_FourByteReal", ncerr_not_opt, ncid, & + varid) + end if + + end subroutine nf95_put_var_3D_FourByteReal + + !*********************** + + subroutine nf95_put_var_4D_FourByteReal(ncid, varid, values, start, count, & + stride, map, ncerr) + + use netcdf, only: nf90_put_var + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid, varid + real, intent( in) :: values(:, :, :, :) + integer, dimension(:), optional, intent( in) :: start, count, stride, map + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, & + map) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_var_4D_FourByteReal", ncerr_not_opt, ncid, & + varid) + end if + + end subroutine nf95_put_var_4D_FourByteReal + + !*********************** + +!!$ subroutine nf90_put_var_1D_EightByteReal(ncid, varid, values, start, count, & +!!$ stride, map, ncerr) +!!$ +!!$ use typesizes, only: eightByteReal +!!$ use netcdf, only: nf90_put_var +!!$ use handle_err_m, only: handle_err +!!$ +!!$ integer, intent( in) :: ncid, varid +!!$ real (kind = EightByteReal), intent( in) :: values(:) +!!$ integer, dimension(:), optional, intent( in) :: start, count, stride, map +!!$ integer, intent(out), optional:: ncerr +!!$ +!!$ ! Variable local to the procedure: +!!$ integer ncerr_not_opt +!!$ +!!$ !------------------- +!!$ +!!$ ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, & +!!$ map) +!!$ if (present(ncerr)) then +!!$ ncerr = ncerr_not_opt +!!$ else +!!$ call handle_err("nf95_put_var_1D_eightByteReal", ncerr_not_opt, ncid, & +!!$ varid) +!!$ end if +!!$ +!!$ end subroutine nf90_put_var_1D_EightByteReal +!!$ +!!$ !*********************** +!!$ +!!$ subroutine nf90_put_var_3D_EightByteReal(ncid, varid, values, start, count, & +!!$ stride, map, ncerr) +!!$ +!!$ use typesizes, only: eightByteReal +!!$ use netcdf, only: nf90_put_var +!!$ use handle_err_m, only: handle_err +!!$ +!!$ integer, intent( in) :: ncid, varid +!!$ real (kind = EightByteReal), intent( in) :: values(:, :, :) +!!$ integer, dimension(:), optional, intent( in) :: start, count, stride, map +!!$ integer, intent(out), optional:: ncerr +!!$ +!!$ ! Variable local to the procedure: +!!$ integer ncerr_not_opt +!!$ +!!$ !------------------- +!!$ +!!$ ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, & +!!$ map) +!!$ if (present(ncerr)) then +!!$ ncerr = ncerr_not_opt +!!$ else +!!$ call handle_err("nf95_put_var_3D_eightByteReal", ncerr_not_opt, ncid, & +!!$ varid) +!!$ end if +!!$ +!!$ end subroutine nf90_put_var_3D_EightByteReal + +end module nf95_put_var_m Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/regr1_lint_m.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/regr1_lint_m.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/regr1_lint_m.F90 (revision 1280) @@ -0,0 +1,98 @@ +! $Id$ +module regr1_lint_m + + ! Author: Lionel GUEZ + + implicit none + + interface regr1_lint + ! Each procedure regrids by linear interpolation. + ! The regridding operation is done on the first dimension of the + ! input array. + ! The difference betwwen the procedures is the rank of the first argument. + module procedure regr11_lint, regr12_lint + end interface + + private + public regr1_lint + +contains + + function regr11_lint(vs, xs, xt) result(vt) + + ! "vs" has rank 1. + + use assert_eq_m, only: assert_eq + use interpolation, only: hunt !!, polint + + real, intent(in):: vs(:) + ! (values of the function at source points "xs") + + real, intent(in):: xs(:) + ! (abscissas of points in source grid, in strictly monotonic order) + + real, intent(in):: xt(:) + ! (abscissas of points in target grid) + + real vt(size(xt)) ! values of the function on the target grid + + ! Variables local to the procedure: + integer is, it, ns + integer is_b ! "is" bound between 1 and "ns - 1" + + !-------------------------------------- + + ns = assert_eq(size(vs), size(xs), "regr11_lint ns") + + is = -1 ! go immediately to bisection on first call to "hunt" + + do it = 1, size(xt) + call hunt(xs, xt(it), is) + is_b = min(max(is, 1), ns - 1) +!! call polint(xs(is_b:is_b+1), vs(is_b:is_b+1), xt(it), vt(it)) + vt(it) = ((xs(is_b+1) - xt(it)) * vs(is_b) & + + (xt(it) - xs(is_b)) * vs(is_b+1)) / (xs(is_b+1) - xs(is_b)) + end do + + end function regr11_lint + + !********************************************************* + + function regr12_lint(vs, xs, xt) result(vt) + + ! "vs" has rank 2. + + use assert_eq_m, only: assert_eq + use interpolation, only: hunt + + real, intent(in):: vs(:, :) + ! (values of the function at source points "xs") + + real, intent(in):: xs(:) + ! (abscissas of points in source grid, in strictly monotonic order) + + real, intent(in):: xt(:) + ! (abscissas of points in target grid) + + real vt(size(xt), size(vs, 2)) ! values of the function on the target grid + + ! Variables local to the procedure: + integer is, it, ns + integer is_b ! "is" bound between 1 and "ns - 1" + + !-------------------------------------- + + ns = assert_eq(size(vs, 1), size(xs), "regr12_lint ns") + + is = -1 ! go immediately to bisection on first call to "hunt" + + do it = 1, size(xt) + call hunt(xs, xt(it), is) + is_b = min(max(is, 1), ns - 1) + vt(it, :) = ((xs(is_b+1) - xt(it)) * vs(is_b, :) & + + (xt(it) - xs(is_b)) * vs(is_b+1, :)) / (xs(is_b+1) - xs(is_b)) + end do + + end function regr12_lint + +end module regr1_lint_m Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/regr1_step_av_m.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/regr1_step_av_m.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/regr1_step_av_m.F90 (revision 1280) @@ -0,0 +1,268 @@ +! $Id$ +module regr1_step_av_m + + ! Author: Lionel GUEZ + + implicit none + + interface regr1_step_av + + ! Each procedure regrids a step function by averaging it. + ! The regridding operation is done on the first dimension of the + ! input array. + ! Source grid contains edges of steps. + ! Target grid contains positions of cell edges. + ! The target grid should be included in the source grid: no + ! extrapolation is allowed. + ! The difference between the procedures is the rank of the first argument. + + module procedure regr11_step_av, regr12_step_av, regr13_step_av, & + regr14_step_av + end interface + + private + public regr1_step_av + +contains + + function regr11_step_av(vs, xs, xt) result(vt) + + ! "vs" has rank 1. + + use assert_eq_m, only: assert_eq + use assert_m, only: assert + use interpolation, only: locate + + real, intent(in):: vs(:) ! values of steps on the source grid + ! (Step "is" is between "xs(is)" and "xs(is + 1)".) + + real, intent(in):: xs(:) + ! (edges of of steps on the source grid, in strictly increasing order) + + real, intent(in):: xt(:) + ! (edges of cells of the target grid, in strictly increasing order) + + real vt(size(xt) - 1) ! average values on the target grid + ! (Cell "it" is between "xt(it)" and "xt(it + 1)".) + + ! Variables local to the procedure: + integer is, it, ns, nt + real left_edge + + !--------------------------------------------- + + ns = assert_eq(size(vs), size(xs) - 1, "regr11_step_av ns") + nt = size(xt) - 1 + ! Quick check on sort order: + call assert(xs(1) < xs(2), "regr11_step_av xs bad order") + call assert(xt(1) < xt(2), "regr11_step_av xt bad order") + + call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & + "regr11_step_av extrapolation") + + is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation + do it = 1, nt + ! 1 <= is <= ns + ! xs(is) <= xt(it) < xs(is + 1) + ! Compute "vt(it)": + left_edge = xt(it) + vt(it) = 0. + do while (xs(is + 1) < xt(it + 1)) + ! 1 <= is <= ns - 1 + vt(it) = vt(it) + (xs(is + 1) - left_edge) * vs(is) + is = is + 1 + left_edge = xs(is) + end do + ! 1 <= is <= ns + vt(it) = (vt(it) + (xt(it + 1) - left_edge) * vs(is)) & + / (xt(it + 1) - xt(it)) + if (xs(is + 1) == xt(it + 1)) is = is + 1 + ! 1 <= is <= ns .or. it == nt + end do + + end function regr11_step_av + + !******************************************** + + function regr12_step_av(vs, xs, xt) result(vt) + + ! "vs" has rank 2. + + use assert_eq_m, only: assert_eq + use assert_m, only: assert + use interpolation, only: locate + + real, intent(in):: vs(:, :) ! values of steps on the source grid + ! (Step "is" is between "xs(is)" and "xs(is + 1)".) + + real, intent(in):: xs(:) + ! (edges of steps on the source grid, in strictly increasing order) + + real, intent(in):: xt(:) + ! (edges of cells of the target grid, in strictly increasing order) + + real vt(size(xt) - 1, size(vs, 2)) ! average values on the target grid + ! (Cell "it" is between "xt(it)" and "xt(it + 1)".) + + ! Variables local to the procedure: + integer is, it, ns, nt + real left_edge + + !--------------------------------------------- + + ns = assert_eq(size(vs, 1), size(xs) - 1, "regr12_step_av ns") + nt = size(xt) - 1 + + ! Quick check on sort order: + call assert(xs(1) < xs(2), "regr12_step_av xs bad order") + call assert(xt(1) < xt(2), "regr12_step_av xt bad order") + + call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & + "regr12_step_av extrapolation") + + is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation + do it = 1, nt + ! 1 <= is <= ns + ! xs(is) <= xt(it) < xs(is + 1) + ! Compute "vt(it, :)": + left_edge = xt(it) + vt(it, :) = 0. + do while (xs(is + 1) < xt(it + 1)) + ! 1 <= is <= ns - 1 + vt(it, :) = vt(it, :) + (xs(is + 1) - left_edge) * vs(is, :) + is = is + 1 + left_edge = xs(is) + end do + ! 1 <= is <= ns + vt(it, :) = (vt(it, :) + (xt(it + 1) - left_edge) * vs(is, :)) & + / (xt(it + 1) - xt(it)) + if (xs(is + 1) == xt(it + 1)) is = is + 1 + ! 1 <= is <= ns .or. it == nt + end do + + end function regr12_step_av + + !******************************************** + + function regr13_step_av(vs, xs, xt) result(vt) + + ! "vs" has rank 3. + + use assert_eq_m, only: assert_eq + use assert_m, only: assert + use interpolation, only: locate + + real, intent(in):: vs(:, :, :) ! values of steps on the source grid + ! (Step "is" is between "xs(is)" and "xs(is + 1)".) + + real, intent(in):: xs(:) + ! (edges of steps on the source grid, in strictly increasing order) + + real, intent(in):: xt(:) + ! (edges of cells of the target grid, in strictly increasing order) + + real vt(size(xt) - 1, size(vs, 2), size(vs, 3)) + ! (average values on the target grid) + ! (Cell "it" is between "xt(it)" and "xt(it + 1)".) + + ! Variables local to the procedure: + integer is, it, ns, nt + real left_edge + + !--------------------------------------------- + + ns = assert_eq(size(vs, 1), size(xs) - 1, "regr13_step_av ns") + nt = size(xt) - 1 + + ! Quick check on sort order: + call assert(xs(1) < xs(2), "regr13_step_av xs bad order") + call assert(xt(1) < xt(2), "regr13_step_av xt bad order") + + call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & + "regr13_step_av extrapolation") + + is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation + do it = 1, nt + ! 1 <= is <= ns + ! xs(is) <= xt(it) < xs(is + 1) + ! Compute "vt(it, :, :)": + left_edge = xt(it) + vt(it, :, :) = 0. + do while (xs(is + 1) < xt(it + 1)) + ! 1 <= is <= ns - 1 + vt(it, :, :) = vt(it, :, :) + (xs(is + 1) - left_edge) * vs(is, :, :) + is = is + 1 + left_edge = xs(is) + end do + ! 1 <= is <= ns + vt(it, :, :) = (vt(it, :, :) & + + (xt(it + 1) - left_edge) * vs(is, :, :)) / (xt(it + 1) - xt(it)) + if (xs(is + 1) == xt(it + 1)) is = is + 1 + ! 1 <= is <= ns .or. it == nt + end do + + end function regr13_step_av + + !******************************************** + + function regr14_step_av(vs, xs, xt) result(vt) + + ! "vs" has rank 4. + + use assert_eq_m, only: assert_eq + use assert_m, only: assert + use interpolation, only: locate + + real, intent(in):: vs(:, :, :, :) ! values of steps on the source grid + ! (Step "is" is between "xs(is)" and "xs(is + 1)".) + + real, intent(in):: xs(:) + ! (edges of steps on the source grid, in strictly increasing order) + + real, intent(in):: xt(:) + ! (edges of cells of the target grid, in strictly increasing order) + + real vt(size(xt) - 1, size(vs, 2), size(vs, 3), size(vs, 4)) + ! (average values on the target grid) + ! (Cell "it" is between "xt(it)" and "xt(it + 1)".) + + ! Variables local to the procedure: + integer is, it, ns, nt + real left_edge + + !--------------------------------------------- + + ns = assert_eq(size(vs, 1), size(xs) - 1, "regr14_step_av ns") + nt = size(xt) - 1 + + ! Quick check on sort order: + call assert(xs(1) < xs(2), "regr14_step_av xs bad order") + call assert(xt(1) < xt(2), "regr14_step_av xt bad order") + + call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & + "regr14_step_av extrapolation") + + is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation + do it = 1, nt + ! 1 <= is <= ns + ! xs(is) <= xt(it) < xs(is + 1) + ! Compute "vt(it, :, :, :)": + left_edge = xt(it) + vt(it, :, :, :) = 0. + do while (xs(is + 1) < xt(it + 1)) + ! 1 <= is <= ns - 1 + vt(it, :, :, :) = vt(it, :, :, :) + (xs(is + 1) - left_edge) & + * vs(is, :, :, :) + is = is + 1 + left_edge = xs(is) + end do + ! 1 <= is <= ns + vt(it, :, :, :) = (vt(it, :, :, :) + (xt(it + 1) - left_edge) & + * vs(is, :, :, :)) / (xt(it + 1) - xt(it)) + if (xs(is + 1) == xt(it + 1)) is = is + 1 + ! 1 <= is <= ns .or. it == nt + end do + + end function regr14_step_av + +end module regr1_step_av_m Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/regr3_lint_m.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/regr3_lint_m.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/regr3_lint_m.F90 (revision 1280) @@ -0,0 +1,100 @@ +! $Id$ +module regr3_lint_m + + ! Author: Lionel GUEZ + + implicit none + + interface regr3_lint + ! Each procedure regrids by linear interpolation. + ! The regridding operation is done on the third dimension of the + ! input array. + ! The difference betwwen the procedures is the rank of the first argument. + module procedure regr33_lint, regr34_lint + end interface + + private + public regr3_lint + +contains + + function regr33_lint(vs, xs, xt) result(vt) + + ! "vs" has rank 3. + + use assert_eq_m, only: assert_eq + use interpolation, only: hunt + + real, intent(in):: vs(:, :, :) + ! (values of the function at source points "xs") + + real, intent(in):: xs(:) + ! (abscissas of points in source grid, in strictly monotonic order) + + real, intent(in):: xt(:) + ! (abscissas of points in target grid) + + real vt(size(vs, 1), size(vs, 2), size(xt)) + ! (values of the function on the target grid) + + ! Variables local to the procedure: + integer is, it, ns + integer is_b ! "is" bound between 1 and "ns - 1" + + !-------------------------------------- + + ns = assert_eq(size(vs, 3), size(xs), "regr33_lint ns") + + is = -1 ! go immediately to bisection on first call to "hunt" + + do it = 1, size(xt) + call hunt(xs, xt(it), is) + is_b = min(max(is, 1), ns - 1) + vt(:, :, it) = ((xs(is_b+1) - xt(it)) * vs(:, :, is_b) & + + (xt(it) - xs(is_b)) * vs(:, :, is_b+1)) / (xs(is_b+1) - xs(is_b)) + end do + + end function regr33_lint + + !********************************************************* + + function regr34_lint(vs, xs, xt) result(vt) + + ! "vs" has rank 4. + + use assert_eq_m, only: assert_eq + use interpolation, only: hunt + + real, intent(in):: vs(:, :, :, :) + ! (values of the function at source points "xs") + + real, intent(in):: xs(:) + ! (abscissas of points in source grid, in strictly monotonic order) + + real, intent(in):: xt(:) + ! (abscissas of points in target grid) + + real vt(size(vs, 1), size(vs, 2), size(xt), size(vs, 4)) + ! (values of the function on the target grid) + + ! Variables local to the procedure: + integer is, it, ns + integer is_b ! "is" bound between 1 and "ns - 1" + + !-------------------------------------- + + ns = assert_eq(size(vs, 3), size(xs), "regr34_lint ns") + + is = -1 ! go immediately to bisection on first call to "hunt" + + do it = 1, size(xt) + call hunt(xs, xt(it), is) + is_b = min(max(is, 1), ns - 1) + vt(:, :, it, :) = ((xs(is_b+1) - xt(it)) * vs(:, :, is_b, :) & + + (xt(it) - xs(is_b)) * vs(:, :, is_b+1, :)) & + / (xs(is_b+1) - xs(is_b)) + end do + + end function regr34_lint + +end module regr3_lint_m Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/simple.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/simple.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/simple.F90 (revision 1280) @@ -0,0 +1,312 @@ +! $Id$ +module simple + + implicit none + +contains + + subroutine nf95_open(path, mode, ncid, chunksize, ncerr) + + use netcdf, only: nf90_open + use handle_err_m, only: handle_err + + character(len=*), intent(in):: path + integer, intent(in):: mode + integer, intent(out):: ncid + integer, intent(inout), optional:: chunksize + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_open(path, mode, ncid, chunksize) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_open " // path, ncerr_not_opt) + end if + + end subroutine nf95_open + + !************************ + + subroutine nf95_inq_dimid(ncid, name, dimid, ncerr) + + use netcdf, only: nf90_inq_dimid + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid + character (len = *), intent( in) :: name + integer, intent(out) :: dimid + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_inq_dimid(ncid, name, dimid) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_inq_dimid", ncerr_not_opt, ncid) + end if + + end subroutine nf95_inq_dimid + + !************************ + + subroutine nf95_inquire_dimension(ncid, dimid, name, len, ncerr) + + use netcdf, only: nf90_inquire_dimension + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid, dimid + character (len = *), optional, intent(out) :: name + integer, optional, intent(out) :: len + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_inquire_dimension(ncid, dimid, name, len) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_inquire_dimension", ncerr_not_opt, ncid) + end if + + end subroutine nf95_inquire_dimension + + !************************ + + subroutine nf95_inq_varid(ncid, name, varid, ncerr) + + use netcdf, only: nf90_inq_varid + use handle_err_m, only: handle_err + + integer, intent(in) :: ncid + character (len = *), intent(in) :: name + integer, intent(out) :: varid + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_inq_varid(ncid, name, varid) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_inq_varid, name = " // name, ncerr_not_opt, ncid) + end if + + end subroutine nf95_inq_varid + + !************************ + + subroutine nf95_inquire_variable(ncid, varid, name, xtype, ndims, dimids, & + nAtts, ncerr) + + ! In "nf90_inquire_variable", "dimids" is an assumed-size array. + ! This is the classical case of an array the size of which is + ! unknown in the calling procedure, before the call. + ! Here we use a better solution: a pointer argument array. + ! This procedure associates and defines "dimids" if it is present. + + use netcdf, only: nf90_inquire_variable, nf90_max_var_dims + use handle_err_m, only: handle_err + + integer, intent(in):: ncid, varid + character(len = *), optional, intent(out):: name + integer, optional, intent(out) :: xtype, ndims + integer, dimension(:), optional, pointer :: dimids + integer, optional, intent(out) :: nAtts + integer, intent(out), optional :: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + integer dimids_local(nf90_max_var_dims) + integer ndims_not_opt + + !------------------- + + if (present(dimids)) then + ncerr_not_opt = nf90_inquire_variable(ncid, varid, name, xtype, & + ndims_not_opt, dimids_local, nAtts) + allocate(dimids(ndims_not_opt)) ! also works if ndims_not_opt == 0 + dimids = dimids_local(:ndims_not_opt) + if (present(ndims)) ndims = ndims_not_opt + else + ncerr_not_opt = nf90_inquire_variable(ncid, varid, name, xtype, ndims, & + nAtts=nAtts) + end if + + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_inquire_variable", ncerr_not_opt, ncid) + end if + + end subroutine nf95_inquire_variable + + !************************ + + subroutine nf95_create(path, cmode, ncid, initialsize, chunksize, ncerr) + + use netcdf, only: nf90_create + use handle_err_m, only: handle_err + + character (len = *), intent(in ) :: path + integer, intent(in ) :: cmode + integer, intent( out) :: ncid + integer, optional, intent(in ) :: initialsize + integer, optional, intent(inout) :: chunksize + integer, intent(out), optional :: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_create(path, cmode, ncid, initialsize, chunksize) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_create " // path, ncerr_not_opt) + end if + + end subroutine nf95_create + + !************************ + + subroutine nf95_def_dim(ncid, name, len, dimid, ncerr) + + use netcdf, only: nf90_def_dim + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid + character (len = *), intent( in) :: name + integer, intent( in) :: len + integer, intent(out) :: dimid + integer, intent(out), optional :: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_def_dim(ncid, name, len, dimid) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_def_dim", ncerr_not_opt, ncid) + end if + + end subroutine nf95_def_dim + + !*********************** + + subroutine nf95_redef(ncid, ncerr) + + use netcdf, only: nf90_redef + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid + integer, intent(out), optional :: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_redef(ncid) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_redef", ncerr_not_opt, ncid) + end if + + end subroutine nf95_redef + + !*********************** + + subroutine nf95_enddef(ncid, h_minfree, v_align, v_minfree, r_align, ncerr) + + use netcdf, only: nf90_enddef + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid + integer, optional, intent( in) :: h_minfree, v_align, v_minfree, r_align + integer, intent(out), optional :: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_enddef(ncid, h_minfree, v_align, v_minfree, r_align) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_enddef", ncerr_not_opt, ncid) + end if + + end subroutine nf95_enddef + + !*********************** + + subroutine nf95_close(ncid, ncerr) + + use netcdf, only: nf90_close + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid + integer, intent(out), optional :: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_close(ncid) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_close", ncerr_not_opt) + end if + + end subroutine nf95_close + + !*********************** + + subroutine nf95_copy_att(ncid_in, varid_in, name, ncid_out, varid_out, ncerr) + + use netcdf, only: nf90_copy_att + use handle_err_m, only: handle_err + + integer, intent( in):: ncid_in, varid_in + character(len=*), intent( in):: name + integer, intent( in):: ncid_out, varid_out + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_copy_att(ncid_in, varid_in, name, ncid_out, varid_out) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_copy_att", ncerr_not_opt, ncid_out) + end if + + end subroutine nf95_copy_att + +end module simple Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/vampir.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/vampir.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/vampir.F90 (revision 1280) @@ -0,0 +1,86 @@ +module Vampir + + INTEGER,parameter :: VTcaldyn=1 + INTEGER,parameter :: VTintegre=2 + INTEGER,parameter :: VTadvection=3 + INTEGER,parameter :: VTdissipation=4 + INTEGER,parameter :: VThallo=5 + INTEGER,parameter :: VTphysiq=6 + INTEGER,parameter :: VTinca=7 + + INTEGER,parameter :: nb_inst=7 + INTEGER :: MPE_begin(nb_inst) + INTEGER :: MPE_end(nb_inst) + +contains + + subroutine InitVampir + implicit none + +#ifdef USE_VT + include 'VT.inc' + integer :: ierr + + call VTSYMDEF(VTcaldyn,"caldyn","caldyn",ierr) + call VTSYMDEF(VTintegre,"integre","integre",ierr) + call VTSYMDEF(VTadvection,"advection","advection",ierr) + call VTSYMDEF(VTdissipation,"dissipation","dissipation",ierr) + call VTSYMDEF(VThallo,"hallo","hallo",ierr) + call VTSYMDEF(VTphysiq,"physiq","physiq",ierr) + call VTSYMDEF(VTinca,"inca","inca",ierr) +#endif + +#ifdef USE_MPE + include 'mpe_logf.h' + integer :: ierr,i + + DO i=1,nb_inst + ierr = MPE_Log_get_state_eventIDs( MPE_begin(i), MPE_end(i) ) + ENDDO + + ierr = MPE_Describe_state( MPE_begin(VTcaldyn), MPE_end(VTcaldyn),"caldyn", "yellow" ) + ierr = MPE_Describe_state( MPE_begin(VTintegre), MPE_end(VTintegre),"integre", "blue" ) + ierr = MPE_Describe_state( MPE_begin(VTadvection), MPE_end(VTadvection),"advection", "green" ) + ierr = MPE_Describe_state( MPE_begin(VTdissipation), MPE_end(VTdissipation),"dissipation", "ivory" ) + ierr = MPE_Describe_state( MPE_begin(VThallo), MPE_end(VThallo),"hallo", "orange" ) + ierr = MPE_Describe_state( MPE_begin(VTphysiq), MPE_end(VTphysiq),"physiq", "purple" ) + ierr = MPE_Describe_state( MPE_begin(VTinca), MPE_end(VTinca),"inca", "LightBlue" ) +#endif + end subroutine InitVampir + + subroutine VTb(number) + implicit none + INTEGER :: number +#ifdef USE_VT + include 'VT.inc' + integer :: ierr + + call VTBEGIN(number,ierr) +#endif +#ifdef USE_MPE + include 'mpe_logf.h' + integer :: ierr,i + ierr = MPE_Log_event( MPE_begin(number), 0, '' ) +#endif + + end subroutine VTb + + subroutine VTe(number) + implicit none + INTEGER :: Number +#ifdef USE_VT + include 'VT.inc' + integer :: ierr + + call VTEND(number,ierr) +#endif + +#ifdef USE_MPE + include 'mpe_logf.h' + integer :: ierr,i + ierr = MPE_Log_event( MPE_end(number), 0, '' ) +#endif + + end subroutine VTe + +end module Vampir Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/write_field.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/write_field.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/write_field.F90 (revision 1280) @@ -0,0 +1,326 @@ +! +! $Id$ +! +module write_field +implicit none + + integer, parameter :: MaxWriteField = 100 + integer, dimension(MaxWriteField),save :: FieldId + integer, dimension(MaxWriteField),save :: FieldVarId + integer, dimension(MaxWriteField),save :: FieldIndex + character(len=255), dimension(MaxWriteField) :: FieldName + + integer,save :: NbField = 0 + + interface WriteField + module procedure WriteField3d,WriteField2d,WriteField1d + end interface WriteField + contains + + function GetFieldIndex(name) + implicit none + integer :: GetFieldindex + character(len=*) :: name + + character(len=255) :: TrueName + integer :: i + + + TrueName=TRIM(ADJUSTL(name)) + + GetFieldIndex=-1 + do i=1,NbField + if (TrueName==FieldName(i)) then + GetFieldIndex=i + exit + endif + enddo + end function GetFieldIndex + + subroutine WriteField3d(name,Field) + implicit none + character(len=*) :: name + real, dimension(:,:,:) :: Field + integer, dimension(3) :: Dim + + Dim=shape(Field) + call WriteField_gen(name,Field,Dim(1),Dim(2),Dim(3)) + + end subroutine WriteField3d + + subroutine WriteField2d(name,Field) + implicit none + character(len=*) :: name + real, dimension(:,:) :: Field + integer, dimension(2) :: Dim + + Dim=shape(Field) + call WriteField_gen(name,Field,Dim(1),Dim(2),1) + + end subroutine WriteField2d + + subroutine WriteField1d(name,Field) + implicit none + character(len=*) :: name + real, dimension(:) :: Field + integer, dimension(1) :: Dim + + Dim=shape(Field) + call WriteField_gen(name,Field,Dim(1),1,1) + + end subroutine WriteField1d + + subroutine WriteField_gen(name,Field,dimx,dimy,dimz) + implicit none + include 'netcdf.inc' + character(len=*) :: name + integer :: dimx,dimy,dimz + real,dimension(dimx,dimy,dimz) :: Field + integer,dimension(dimx*dimy*dimz) :: ndex + integer :: status + integer :: index + integer :: start(4) + integer :: count(4) + + + Index=GetFieldIndex(name) + if (Index==-1) then + call CreateNewField(name,dimx,dimy,dimz) + Index=GetFieldIndex(name) + else + FieldIndex(Index)=FieldIndex(Index)+1. + endif + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=FieldIndex(Index) + + count(1)=dimx + count(2)=dimy + count(3)=dimz + count(4)=1 + + status = NF_PUT_VARA_DOUBLE(FieldId(Index),FieldVarId(Index),start,count,Field) + status = NF_SYNC(FieldId(Index)) + + end subroutine WriteField_gen + + subroutine CreateNewField(name,dimx,dimy,dimz) + implicit none + include 'netcdf.inc' + character(len=*) :: name + integer :: dimx,dimy,dimz + integer :: TabDim(4) + integer :: status + + + NbField=NbField+1 + FieldName(NbField)=TRIM(ADJUSTL(name)) + FieldIndex(NbField)=1 + + + status = NF_CREATE(TRIM(ADJUSTL(name))//'.nc', NF_CLOBBER, FieldId(NbField)) + status = NF_DEF_DIM(FieldId(NbField),'X',dimx,TabDim(1)) + status = NF_DEF_DIM(FieldId(NbField),'Y',dimy,TabDim(2)) + status = NF_DEF_DIM(FieldId(NbField),'Z',dimz,TabDim(3)) + status = NF_DEF_DIM(FieldId(NbField),'iter',NF_UNLIMITED,TabDim(4)) + status = NF_DEF_VAR(FieldId(NbField),FieldName(NbField),NF_DOUBLE,4,TabDim,FieldVarId(NbField)) + status = NF_ENDDEF(FieldId(NbField)) + + end subroutine CreateNewField + + + + subroutine write_field1D(name,Field) + implicit none + + integer, parameter :: MaxDim=1 + character(len=*) :: name + real, dimension(:) :: Field + real, dimension(:),allocatable :: New_Field + character(len=20) :: str + integer, dimension(MaxDim) :: Dim + integer :: i,nb + integer, parameter :: id=10 + integer, parameter :: NbCol=4 + integer :: ColumnSize + integer :: pos + character(len=255) :: form + character(len=255) :: MaxLen + + + open(unit=id,file=name//'.field',form='formatted',status='replace') + write (id,'("----- Field '//name//'",//)') + Dim=shape(Field) + MaxLen=int2str(len(trim(int2str(Dim(1))))) + ColumnSize=20+6+3+len(trim(int2str(Dim(1)))) + Nb=0 + Pos=2 + do i=1,Dim(1) + nb=nb+1 + + if (MOD(nb,NbCol)==0) then + form='(t'//trim(int2str(pos))// ',i'//trim(MaxLen) //'," ---> ",g22.16,/)' + Pos=2 + else + form='(t'//trim(int2str(pos))// ',i'//trim(MaxLen) //'," ---> ",g22.16," | ",)' + Pos=Pos+ColumnSize + endif + write (id,form,advance='no') i,Field(i) + enddo + + close(id) + + end subroutine write_field1D + + subroutine write_field2D(name,Field) + implicit none + + integer, parameter :: MaxDim=2 + character(len=*) :: name + real, dimension(:,:) :: Field + real, dimension(:,:),allocatable :: New_Field + character(len=20) :: str + integer, dimension(MaxDim) :: Dim + integer :: i,j,nb + integer, parameter :: id=10 + integer, parameter :: NbCol=4 + integer :: ColumnSize + integer :: pos,offset + character(len=255) :: form + character(len=255) :: spacing + + open(unit=id,file=name//'.field',form='formatted',status='replace') + write (id,'("----- Field '//name//'",//)') + + Dim=shape(Field) + offset=len(trim(int2str(Dim(1))))+len(trim(int2str(Dim(2))))+3 + ColumnSize=20+6+3+offset + + spacing='(t2,"'//repeat('-',ColumnSize*NbCol)//'")' + + do i=1,Dim(2) + nb=0 + Pos=2 + do j=1,Dim(1) + nb=nb+1 + + if (MOD(nb,NbCol)==0) then + form='(t'//trim(int2str(pos))// & + ',"('//trim(int2str(j))//',' & + //trim(int2str(i))//')",t' & + //trim(int2str(pos+offset)) & + //'," ---> ",g22.16,/)' + Pos=2 + else + form='(t'//trim(int2str(pos))// & + ',"('//trim(int2str(j))//',' & + //trim(int2str(i))//')",t' & + //trim(int2str(pos+offset)) & + //'," ---> ",g22.16," | ")' + Pos=Pos+ColumnSize + endif + write (id,form,advance='no') Field(j,i) + enddo + if (MOD(nb,NbCol)==0) then + write (id,spacing) + else + write (id,'("")') + write (id,spacing) + endif + enddo + + end subroutine write_field2D + + subroutine write_field3D(name,Field) + implicit none + + integer, parameter :: MaxDim=3 + character(len=*) :: name + real, dimension(:,:,:) :: Field + real, dimension(:,:,:),allocatable :: New_Field + integer, dimension(MaxDim) :: Dim + integer :: i,j,k,nb + integer, parameter :: id=10 + integer, parameter :: NbCol=4 + integer :: ColumnSize + integer :: pos,offset + character(len=255) :: form + character(len=255) :: spacing + + open(unit=id,file=name//'.field',form='formatted',status='replace') + write (id,'("----- Field '//name//'"//)') + + Dim=shape(Field) + offset=len(trim(int2str(Dim(1))))+len(trim(int2str(Dim(2))))+len(trim(int2str(Dim(3))))+4 + ColumnSize=22+6+3+offset + +! open(unit=id,file=name,form=formatted + + spacing='(t2,"'//repeat('-',ColumnSize*NbCol)//'")' + + do i=1,Dim(3) + + do j=1,Dim(2) + nb=0 + Pos=2 + + do k=1,Dim(1) + nb=nb+1 + + if (MOD(nb,NbCol)==0) then + form='(t'//trim(int2str(pos))// & + ',"('//trim(int2str(k))//',' & + //trim(int2str(j))//',' & + //trim(int2str(i))//')",t' & + //trim(int2str(pos+offset)) & + //'," ---> ",g22.16,/)' + Pos=2 + else + form='(t'//trim(int2str(pos))// & + ',"('//trim(int2str(k))//',' & + //trim(int2str(j))//',' & + //trim(int2str(i))//')",t' & + //trim(int2str(pos+offset)) & + //'," ---> ",g22.16," | ")' +! dépent de l'implémention, sur compaq, c'est necessaire +! Pos=Pos+ColumnSize + endif + write (id,form,advance='no') Field(k,j,i) + enddo + if (MOD(nb,NbCol)==0) then + write (id,spacing) + else + write (id,'("")') + write (id,spacing) + endif + enddo + write (id,spacing) + enddo + + close(id) + + end subroutine write_field3D + + function int2str(int) + implicit none + integer, parameter :: MaxLen=10 + integer,intent(in) :: int + character(len=MaxLen) :: int2str + logical :: flag + integer :: i + flag=.true. + + i=int + + int2str='' + do while (flag) + int2str=CHAR(MOD(i,10)+48)//int2str + i=i/10 + if (i==0) flag=.false. + enddo + end function int2str + +end module write_field + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/writedynav.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/writedynav.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/writedynav.F (revision 1280) @@ -0,0 +1,153 @@ +! +! $Id$ +! + subroutine writedynav( histid, time, vcov, + , ucov,teta,ppk,phi,q,masse,ps,phis) + +#ifdef CPP_IOIPSL + USE ioipsl +#endif + USE infotrac, ONLY : nqtot, ttext + implicit none + +C +C Ecriture du fichier histoire au format IOIPSL +C +C Appels succesifs des routines: histwrite +C +C Entree: +C histid: ID du fichier histoire +C time: temps de l'ecriture +C vcov: vents v covariants +C ucov: vents u covariants +C teta: temperature potentielle +C phi : geopotentiel instantane +C q : traceurs +C masse: masse +C ps :pression au sol +C phis : geopotentiel au sol +C +C +C Sortie: +C fileid: ID du fichier netcdf cree +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C +C Arguments +C + + INTEGER histid + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1*llm),phi(ip1jmp1,llm),ppk(ip1jmp1*llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL phis(ip1jmp1) + REAL q(ip1jmp1,llm,nqtot) + integer time + + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL to work +C Variables locales +C + integer ndex2d(iip1*jjp1),ndex3d(iip1*jjp1*llm),iq, ii, ll + real us(ip1jmp1*llm), vs(ip1jmp1*llm) + real tm(ip1jmp1*llm) + REAL vnat(ip1jm,llm),unat(ip1jmp1,llm) + logical ok_sync + integer itau_w +C +C Initialisations +C + ndex3d = 0 + ndex2d = 0 + ok_sync = .TRUE. + us = 999.999 + vs = 999.999 + tm = 999.999 + vnat = 999.999 + unat = 999.999 + itau_w = itau_dyn + time + +C Passage aux composantes naturelles du vent + call covnat(llm, ucov, vcov, unat, vnat) + +C +C Appels a histwrite pour l'ecriture des variables a sauvegarder +C +C Vents U scalaire +C + call gr_u_scal(llm, unat, us) + call histwrite(histid, 'u', itau_w, us, + . iip1*jjp1*llm, ndex3d) +C +C Vents V scalaire +C + call gr_v_scal(llm, vnat, vs) + call histwrite(histid, 'v', itau_w, vs, + . iip1*jjp1*llm, ndex3d) +C +C Temperature potentielle moyennee +C + call histwrite(histid, 'theta', itau_w, teta, + . iip1*jjp1*llm, ndex3d) +C +C Temperature moyennee +C + do ii = 1, ijp1llm + tm(ii) = teta(ii) * ppk(ii)/cpp + enddo + call histwrite(histid, 'temp', itau_w, tm, + . iip1*jjp1*llm, ndex3d) +C +C Geopotentiel +C + call histwrite(histid, 'phi', itau_w, phi, + . iip1*jjp1*llm, ndex3d) +C +C Traceurs +C + DO iq=1,nqtot + call histwrite(histid, ttext(iq), itau_w, q(:,:,iq), + . iip1*jjp1*llm, ndex3d) + enddo +C +C Masse +C + call histwrite(histid, 'masse', itau_w, masse, iip1*jjp1, ndex2d) +C +C Pression au sol +C + call histwrite(histid, 'ps', itau_w, ps, iip1*jjp1, ndex2d) +C +C Geopotentiel au sol +C + call histwrite(histid, 'phis', itau_w, phis, iip1*jjp1, ndex2d) +C +C Fin +C + if (ok_sync) call histsync(histid) + +#else +! tell the user this routine should be run with ioipsl + write(lunout,*)"writedynav: Warning this routine should not be", + & " used without ioipsl" +#endif +! of #ifdef CPP_IOIPSL + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/writehist.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/writehist.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/bibio/writehist.F (revision 1280) @@ -0,0 +1,138 @@ +! +! $Id$ +! + subroutine writehist( histid, histvid, time, vcov, + , ucov,teta,phi,q,masse,ps,phis) + +#ifdef CPP_IOIPSL + USE ioipsl +#endif + USE infotrac, ONLY : nqtot, ttext + implicit none + +C +C Ecriture du fichier histoire au format IOIPSL +C +C Appels succesifs des routines: histwrite +C +C Entree: +C histid: ID du fichier histoire +C histvid:ID du fichier histoire pour les vents V (appele a disparaitre) +C time: temps de l'ecriture +C vcov: vents v covariants +C ucov: vents u covariants +C teta: temperature potentielle +C phi : geopotentiel instantane +C q : traceurs +C masse: masse +C ps :pression au sol +C phis : geopotentiel au sol +C +C +C Sortie: +C fileid: ID du fichier netcdf cree +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C +C Arguments +C + + INTEGER histid, histvid + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm),phi(ip1jmp1,llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL phis(ip1jmp1) + REAL q(ip1jmp1,llm,nqtot) + integer time + + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL to work +C Variables locales +C + integer iq, ii, ll + integer ndexu(ip1jmp1*llm),ndexv(ip1jm*llm),ndex2d(ip1jmp1) + logical ok_sync + integer itau_w +C +C Initialisations +C + ndexu = 0 + ndexv = 0 + ndex2d = 0 + ok_sync =.TRUE. + itau_w = itau_dyn + time +C +C Appels a histwrite pour l'ecriture des variables a sauvegarder +C +C Vents U +C + call histwrite(histid, 'ucov', itau_w, ucov, + . iip1*jjp1*llm, ndexu) + +C +C Vents V +C + call histwrite(histvid, 'vcov', itau_w, vcov, + . iip1*jjm*llm, ndexv) + +C +C Temperature potentielle +C + call histwrite(histid, 'teta', itau_w, teta, + . iip1*jjp1*llm, ndexu) +C +C Geopotentiel +C + call histwrite(histid, 'phi', itau_w, phi, + . iip1*jjp1*llm, ndexu) +C +C Traceurs +C + DO iq=1,nqtot + call histwrite(histid, ttext(iq), itau_w, q(:,:,iq), + . iip1*jjp1*llm, ndexu) + enddo +C +C Masse +C + call histwrite(histid, 'masse', itau_w, masse, iip1*jjp1, ndex2d) +C +C Pression au sol +C + call histwrite(histid, 'ps', itau_w, ps, iip1*jjp1, ndex2d) +C +C Geopotentiel au sol +C + call histwrite(histid, 'phis', itau_w, phis, iip1*jjp1, ndex2d) +C +C Fin +C + if (ok_sync) then + call histsync(histid) + call histsync(histvid) + endif +#else +! tell the user this routine should be run with ioipsl + write(lunout,*)"writehist: Warning this routine should not be", + & " used without ioipsl" +#endif +! of #ifdef CPP_IOIPSL + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/MISR_simulator.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/MISR_simulator.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/MISR_simulator.F (revision 1280) @@ -0,0 +1,460 @@ +! +! Copyright (c) 2009, Roger Marchand, version 1.2 +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the University of Washington nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, +! BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT +! SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! + + SUBROUTINE MISR_simulator( + & npoints, + & nlev, + & ncol, + & sunlit, + & zfull, + & at, + & dtau_s, + & dtau_c, + & frac_out, + & fq_MISR_TAU_v_CTH, + & dist_model_layertops, + & MISR_mean_ztop, + & MISR_cldarea + & ) + + + implicit none + integer n_MISR_CTH + parameter(n_MISR_CTH=16) + +! ----- +! Input +! ----- + + INTEGER npoints ! if ncol ==1, the number of model points in the horizontal grid + ! else the number of GCM grid points + + INTEGER nlev ! number of model vertical levels + + INTEGER ncol ! number of model sub columns + ! (must already be generated in via scops and passed to this + ! routine via the variable frac_out ) + + INTEGER sunlit(npoints) ! 1 for day points, 0 for night time + + REAL zfull(npoints,nlev) ! height (in meters) of full model levels (i.e. midpoints) + ! zfull(npoints,1) is top level of model + ! zfull(npoints,nlev) is bottom level of model (closest point to surface) + + REAL at(npoints,nlev) ! temperature in each model level (K) + + REAL dtau_s(npoints,nlev) ! visible wavelength cloud optical depth ... for "stratiform" condensate + ! NOTE: this the cloud optical depth of only the + ! the model cell (i,j) + + REAL dtau_c(npoints,nlev) ! visible wavelength cloud optical depth ... for "convective" condensate + ! NOTE: this the cloud optical depth of only the + ! the model cell (i,j) + + REAL frac_out(npoints,ncol,nlev) ! NOTE: only need if columns>1 ... subgrid scheme in use. + +! ------ +! Outputs +! ------ + + REAL fq_MISR_TAU_v_CTH(npoints,7,n_MISR_CTH) + REAL dist_model_layertops(npoints,n_MISR_CTH) + REAL MISR_cldarea(npoints) ! fractional area coverged by clouds + REAL MISR_mean_ztop(npoints) ! mean cloud top hieght(m) MISR would observe + ! NOTE: == 0 if area ==0 + + +! ------ +! Working variables +! ------ + + REAL tau(npoints,ncol) ! total column optical depth ... + + INTEGER j,ilev,ilev2,ibox + INTEGER itau + + LOGICAL box_cloudy(npoints,ncol) + + real isccp_taumin + real boxarea + real tauchk + REAL box_MISR_ztop(npoints,ncol) ! cloud top hieght(m) MISR would observe + + integer thres_crossed_MISR + integer loop,iMISR_ztop + + real dtau, cloud_dtau, MISR_penetration_height,ztest + + real MISR_CTH_boundaries(n_MISR_CTH+1) + + DATA MISR_CTH_boundaries / -99, 0, 0.5, 1, 1.5, 2, 2.5, 3, + c 4, 5, 7, 9, 11, 13, 15, 17, 99 / + + DATA isccp_taumin / 0.3 / + + tauchk = -1.*log(0.9999999) + + ! + ! For each GCM cell or horizontal model grid point ... + ! + do j=1,npoints + + ! + ! estimate distribution of Model layer tops + ! + dist_model_layertops(j,:)=0 + + do ilev=1,nlev + + ! define location of "layer top" + if(ilev.eq.1 .or. ilev.eq.nlev) then + ztest=zfull(j,ilev) + else + ztest=0.5*(zfull(j,ilev)+zfull(j,ilev-1)) + endif + + ! find MISR layer that contains this level + ! note, the first MISR level is "no height" level + iMISR_ztop=2 + do loop=2,n_MISR_CTH + + if ( ztest .gt. + & 1000*MISR_CTH_boundaries(loop+1) ) then + + iMISR_ztop=loop+1 + endif + enddo + + dist_model_layertops(j,iMISR_ztop)= + & dist_model_layertops(j,iMISR_ztop)+1 + enddo + + + ! + ! compute total cloud optical depth for each column + ! + do ibox=1,ncol + + ! Initialize tau to zero in each subcolum + tau(j,ibox)=0. + box_cloudy(j,ibox)=.false. + box_MISR_ztop(j,ibox)=0 + + ! initialize threshold detection for each sub column + thres_crossed_MISR=0; + + do ilev=1,nlev + + dtau=0 + + if (frac_out(j,ibox,ilev).eq.1) then + dtau = dtau_s(j,ilev) + endif + + if (frac_out(j,ibox,ilev).eq.2) then + dtau = dtau_c(j,ilev) + end if + + tau(j,ibox)=tau(j,ibox)+ dtau + + + ! NOW for MISR .. + ! if there a cloud ... start the counter ... store this height + if(thres_crossed_MISR .eq. 0 .and. dtau .gt. 0.) then + + ! first encountered a "cloud" + thres_crossed_MISR=1 + cloud_dtau=0 + endif + + if( thres_crossed_MISR .lt. 99 .and. + & thres_crossed_MISR .gt. 0 ) then + + if( dtau .eq. 0.) then + + ! we have come to the end of the current cloud + ! layer without yet selecting a CTH boundary. + ! ... restart cloud tau counter + cloud_dtau=0 + else + ! add current optical depth to count for + ! the current cloud layer + cloud_dtau=cloud_dtau+dtau + endif + + ! if the cloud is continuous but optically thin (< 1) + ! from above the current layer cloud top to the current level + ! then MISR will like see a top below the top of the current + ! layer + if( dtau.gt.0 .and. (cloud_dtau-dtau) .lt. 1) then + + if(dtau .lt. 1 .or. ilev.eq.1 .or. ilev.eq.nlev) then + + ! MISR will likely penetrate to some point + ! within this layer ... the middle + MISR_penetration_height=zfull(j,ilev) + + else + ! take the OD = 1.0 level into this layer + MISR_penetration_height= + & 0.5*(zfull(j,ilev)+zfull(j,ilev-1)) - + & 0.5*(zfull(j,ilev-1)-zfull(j,ilev+1)) + & /dtau + endif + + box_MISR_ztop(j,ibox)=MISR_penetration_height + + endif + + ! check for a distinctive water layer + if(dtau .gt. 1 .and. at(j,ilev).gt.273 ) then + + ! must be a water cloud ... + ! take this as CTH level + thres_crossed_MISR=99 + endif + + ! if the total column optical depth is "large" than + ! MISR can't seen anything else ... set current point as CTH level + if(tau(j,ibox) .gt. 5) then + + thres_crossed_MISR=99 + endif + + endif ! MISR CTH booundary not set + + enddo !ilev - loop over vertical levesl + + ! written by roj 5/2006 + ! check to see if there was a cloud for which we didn't + ! set a MISR cloud top boundary + if( thres_crossed_MISR .eq. 1) then + + ! if the cloud has a total optical depth of greater + ! than ~ 0.5 MISR will still likely pick up this cloud + ! with a height near the true cloud top + ! otherwise there should be no CTH + if( tau(j,ibox) .gt. 0.5) then + + ! keep MISR detected CTH + + elseif(tau(j,ibox) .gt. 0.2) then + + ! MISR may detect but wont likley have a good height + box_MISR_ztop(j,ibox)=-1 + + else + ! MISR not likely to even detect. + ! so set as not cloudy + box_MISR_ztop(j,ibox)=0 + + endif + + endif + + enddo ! loop of subcolumns + enddo ! loop of gridpoints + + + ! + ! Modify MISR CTH for satellite spatial / pattern matcher effects + ! + ! Code in this region added by roj 5/2006 to account + ! for spatial effect of the MISR pattern matcher. + ! Basically, if a column is found between two neighbors + ! at the same CTH, and that column has no hieght or + ! a lower CTH, THEN misr will tend to but place the + ! odd column at the same height as it neighbors. + ! + ! This setup assumes the columns represent a about a 1 to 4 km scale + ! it will need to be modified significantly, otherwise + if(ncol.eq.1) then + + ! adjust based on neightboring points ... i.e. only 2D grid was input + do j=2,npoints-1 + + if(box_MISR_ztop(j-1,1).gt.0 .and. + & box_MISR_ztop(j+1,1).gt.0 ) then + + if( abs( box_MISR_ztop(j-1,1) - + & box_MISR_ztop(j+1,1) ) .lt. 500 + & .and. + & box_MISR_ztop(j,1) .lt. + & box_MISR_ztop(j+1,1) ) then + + box_MISR_ztop(j,1) = + & box_MISR_ztop(j+1,1) + endif + + endif + enddo + else + + ! adjust based on neighboring subcolumns .... + do ibox=2,ncol-1 + + if(box_MISR_ztop(1,ibox-1).gt.0 .and. + & box_MISR_ztop(1,ibox+1).gt.0 ) then + + if( abs( box_MISR_ztop(1,ibox-1) - + & box_MISR_ztop(1,ibox+1) ) .lt. 500 + & .and. + & box_MISR_ztop(1,ibox) .lt. + & box_MISR_ztop(1,ibox+1) ) then + + box_MISR_ztop(1,ibox) = + & box_MISR_ztop(1,ibox+1) + endif + + endif + enddo + + endif + + ! + ! DETERMINE CLOUD TYPE FREQUENCIES + ! + ! Now that ztop and tau have been determined, + ! determine amount of each cloud type + boxarea=1./real(ncol) + do j=1,npoints + + ! reset frequencies -- modified loop structure, roj 5/2006 + do ilev=1,7 ! "tau loop" + do ilev2=1,n_MISR_CTH + fq_MISR_TAU_v_CTH(j,ilev,ilev2)=0. + enddo + enddo + + MISR_cldarea(j)=0. + MISR_mean_ztop(j)=0. + + do ibox=1,ncol + + if (tau(j,ibox) .gt. (tauchk)) then + box_cloudy(j,ibox)=.true. + endif + + itau = 0 + + if (box_cloudy(j,ibox)) then + + !determine optical depth category + if (tau(j,ibox) .lt. isccp_taumin) then + itau=1 + else if (tau(j,ibox) .ge. isccp_taumin + & .and. tau(j,ibox) .lt. 1.3) then + itau=2 + else if (tau(j,ibox) .ge. 1.3 + & .and. tau(j,ibox) .lt. 3.6) then + itau=3 + else if (tau(j,ibox) .ge. 3.6 + & .and. tau(j,ibox) .lt. 9.4) then + itau=4 + else if (tau(j,ibox) .ge. 9.4 + & .and. tau(j,ibox) .lt. 23.) then + itau=5 + else if (tau(j,ibox) .ge. 23. + & .and. tau(j,ibox) .lt. 60.) then + itau=6 + else if (tau(j,ibox) .ge. 60.) then + itau=7 + endif + + endif + + ! update MISR histograms and summary metrics - roj 5/2005 + if (sunlit(j).eq.1) then + + !if cloudy added by roj 5/2005 + if( box_MISR_ztop(j,ibox).eq.0) then + + ! no cloud detected + iMISR_ztop=0 + + elseif( box_MISR_ztop(j,ibox).eq.-1) then + + ! cloud can be detected but too thin to get CTH + iMISR_ztop=1 + + fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)= + & fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea + + else + + ! + ! determine index for MISR bin set + ! + + iMISR_ztop=2 + + do loop=2,n_MISR_CTH + + if ( box_MISR_ztop(j,ibox) .gt. + & 1000*MISR_CTH_boundaries(loop+1) ) then + + iMISR_ztop=loop+1 + + endif + enddo + + if(box_cloudy(j,ibox)) then + + ! there is an isccp clouds so itau(j) is defined + fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)= + & fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea + + else + ! MISR CTH resolution is trying to fill in a + ! broken cloud scene where there is no condensate. + ! The MISR CTH-1D-OD product will only put in a cloud + ! if the MISR cloud mask indicates cloud. + ! therefore we will not include this column in the histogram + ! in reality aerosoal and 3D effects or bright surfaces + ! could fool the MISR cloud mask + + ! the alternative is to count as very thin cloud ?? +! fq_MISR_TAU_v_CTH(1,iMISR_ztop)= +! & fq_MISR_TAU_v_CTH(1,iMISR_ztop) + boxarea + endif + + + MISR_mean_ztop(j)=MISR_mean_ztop(j)+ + & box_MISR_ztop(j,ibox)*boxarea + + MISR_cldarea(j)=MISR_cldarea(j) + boxarea + + endif + + endif ! is sunlight ? + + enddo ! ibox - loop over subcolumns + + if( MISR_cldarea(j) .gt. 0.) then + MISR_mean_ztop(j)= MISR_mean_ztop(j) / MISR_cldarea(j) ! roj 5/2006 + endif + + enddo ! loop over grid points + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/array_lib.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/array_lib.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/array_lib.F90 (revision 1280) @@ -0,0 +1,165 @@ +! ARRAY_LIB: Array procedures for F90 +! Compiled/Modified: +! 07/01/06 John Haynes (haynes@atmos.colostate.edu) +! +! infind (function) +! lin_interpolate (function) + + module array_lib + implicit none + + contains + +! ---------------------------------------------------------------------------- +! function INFIND +! ---------------------------------------------------------------------------- + function infind(list,val,sort,dist) + use m_mrgrnk + implicit none +! +! Purpose: +! Finds the index of an array that is closest to a value, plus the +! difference between the value found and the value specified +! +! Inputs: +! [list] an array of sequential values +! [val] a value to locate +! Optional input: +! [sort] set to 1 if [list] is in unknown/non-sequential order +! +! Returns: +! index of [list] that is closest to [val] +! +! Optional output: +! [dist] set to variable containing [list([result])] - [val] +! +! Requires: +! mrgrnk library +! +! Created: +! 10/16/03 John Haynes (haynes@atmos.colostate.edu) +! Modified: +! 01/31/06 IDL to Fortran 90 + +! ----- INPUTS ----- + real*8, dimension(:), intent(in) :: list + real*8, intent(in) :: val + integer, intent(in), optional :: sort + +! ----- OUTPUTS ----- + integer*4 :: infind + real*8, intent(out), optional :: dist + +! ----- INTERNAL ----- + real*8, dimension(size(list)) :: lists + integer*4 :: nlist, result, tmp(1), sort_list + integer*4, dimension(size(list)) :: mask, idx + + if (present(sort)) then + sort_list = sort + else + sort_list = 0 + endif + + nlist = size(list) + if (sort_list == 1) then + call mrgrnk(list,idx) + lists = list(idx) + else + lists = list + endif + + if (val >= lists(nlist)) then + result = nlist + else if (val <= lists(1)) then + result = 1 + else + mask(:) = 0 + where (lists < val) mask = 1 + tmp = minloc(mask,1) + if (abs(lists(tmp(1)-1)-val) < abs(lists(tmp(1))-val)) then + result = tmp(1) - 1 + else + result = tmp(1) + endif + endif + if (present(dist)) dist = lists(result)-val + if (sort_list == 1) then + infind = idx(result) + else + infind = result + endif + + end function infind + +! ---------------------------------------------------------------------------- +! function LIN_INTERPOLATE +! ---------------------------------------------------------------------------- + subroutine lin_interpolate(yarr,xarr,yyarr,xxarr,tol) + use m_mrgrnk + implicit none +! +! Purpose: +! linearly interpolate a set of y2 values given a set of y1,x1,x2 +! +! Inputs: +! [yarr] an array of y1 values +! [xarr] an array of x1 values +! [xxarr] an array of x2 values +! [tol] maximum distance for a match +! +! Output: +! [yyarr] interpolated array of y2 values +! +! Requires: +! mrgrnk library +! +! Created: +! 06/07/06 John Haynes (haynes@atmos.colostate.edu) + +! ----- INPUTS ----- + real*8, dimension(:), intent(in) :: yarr, xarr, xxarr + real*8, intent(in) :: tol + +! ----- OUTPUTS ----- + real*8, dimension(size(xxarr)), intent(out) :: yyarr + +! ----- INTERNAL ----- + real*8, dimension(size(xarr)) :: ysort, xsort + integer*4, dimension(size(xarr)) :: ist + integer*4 :: nx, nxx, i, iloc + real*8 :: d, m + + nx = size(xarr) + nxx = size(xxarr) + +! // xsort, ysort are sorted versions of xarr, yarr + call mrgrnk(xarr,ist) + ysort = yarr(ist) + xsort = xarr(ist) + + do i=1,nxx + iloc = infind(xsort,xxarr(i),dist=d) + if (d > tol) then + print *, 'interpolation error' + stop + endif + if (iloc == nx) then +! :: set to the last value + yyarr(i) = ysort(nx) + else +! :: is there another closeby value? + if (abs(xxarr(i)-xsort(iloc+1)) < 2*tol) then +! :: yes, do a linear interpolation + m = (ysort(iloc+1)-ysort(iloc))/(xsort(iloc+1)-xsort(iloc)) + yyarr(i) = ysort(iloc) + m*(xxarr(i)-xsort(iloc)) + else +! :: no, set to the only nearby value + yyarr(i) = ysort(iloc) + endif + endif + enddo + + end subroutine lin_interpolate + + end module array_lib Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/atmos_lib.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/atmos_lib.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/atmos_lib.F90 (revision 1280) @@ -0,0 +1,135 @@ +! ATMOS_LIB: Atmospheric science procedures for F90 +! Compiled/Modified: +! 07/01/06 John Haynes (haynes@atmos.colostate.edu) +! +! mcclatchey (subroutine) + + module atmos_lib + implicit none + + contains + +! ---------------------------------------------------------------------------- +! subroutine MCCLATCHEY +! ---------------------------------------------------------------------------- + subroutine mcclatchey(stype,hgt,prs,tk,rh) + implicit none +! +! Purpose: +! returns a standard atmospheric profile +! +! Input: +! [stype] type of profile to return +! 1 = mid-latitude summer +! 2 = mid-latitude winter +! 3 = tropical +! +! Outputs: +! [hgt] height (m) +! [prs] pressure (hPa) +! [tk] temperature (K) +! [rh] relative humidity (%) +! +! Created: +! 06/01/2006 John Haynes (haynes@atmos.colostate.edu) + +! ----- INPUTS ----- + integer, intent(in) :: & + stype + + integer, parameter :: ndat = 33 + +! ----- OUTPUTS ----- + real*8, intent(out), dimension(ndat) :: & + hgt, & ! height (m) + prs, & ! pressure (hPa) + tk, & ! temperature (K) + rh ! relative humidity (%) + + hgt = (/0.00000,1000.00,2000.00,3000.00,4000.00,5000.00, & + 6000.00,7000.00,8000.00,9000.00,10000.0,11000.0, & + 12000.0,13000.0,14000.0,15000.0,16000.0,17000.0, & + 18000.0,19000.0,20000.0,21000.0,22000.0,23000.0, & + 24000.0,25000.0,30000.0,35000.0,40000.0,45000.0, & + 50000.0,70000.0,100000./) + + select case(stype) + + case(1) +! // mid-latitide summer + prs = (/1013.00, 902.000, 802.000, 710.000, 628.000, 554.000, & + 487.000, 426.000, 372.000, 324.000, 281.000, 243.000, & + 209.000, 179.000, 153.000, 130.000, 111.000, 95.0000, & + 81.2000, 69.5000, 59.5000, 51.0000, 43.7000, 37.6000, & + 32.2000, 27.7000, 13.2000, 6.52000, 3.33000, 1.76000, & + 0.951000,0.0671000,0.000300000/) + + tk = (/294.000, 290.000, 285.000, 279.000, 273.000, 267.000, & + 261.000, 255.000, 248.000, 242.000, 235.000, 229.000, & + 222.000, 216.000, 216.000, 216.000, 216.000, 216.000, & + 216.000, 217.000, 218.000, 219.000, 220.000, 222.000, & + 223.000, 224.000, 234.000, 245.000, 258.000, 270.000, & + 276.000, 218.000, 210.000/) + + rh = (/74.8384, 63.4602, 55.0485, 45.4953, 39.3805, 31.7965, & + 30.3958, 29.5966, 30.1626, 29.3624, 30.3334, 19.0768, & + 11.0450, 6.61278, 3.67379, 2.79209, 2.35123, 2.05732, & + 1.83690, 1.59930, 1.30655, 1.31890, 1.17620,0.994076, & + 0.988566,0.989143,0.188288,0.0205613,0.00271164,0.000488798, & + 0.000107066,0.000406489,7.68645e-06/) + + case(2) +! // mid-latitude winter + prs = (/1018.00, 897.300, 789.700, 693.800, 608.100, 531.300, & + 462.700, 401.600, 347.300, 299.200, 256.800, 219.900, & + 188.200, 161.000, 137.800, 117.800, 100.700, 86.1000, & + 73.5000, 62.8000, 53.7000, 45.8000, 39.1000, 33.4000, & + 28.6000, 24.3000, 11.1000, 5.18000, 2.53000, 1.29000, & + 0.682000,0.0467000,0.000300000/) + + tk = (/272.200, 268.700, 265.200, 261.700, 255.700, 249.700, & + 243.700, 237.700, 231.700, 225.700, 219.700, 219.200, & + 218.700, 218.200, 217.700, 217.200, 216.700, 216.200, & + 215.700, 215.200, 215.200, 215.200, 215.200, 215.200, & + 215.200, 215.200, 217.400, 227.800, 243.200, 258.500, & + 265.700, 230.700, 210.200/) + + rh = (/76.6175, 70.1686, 65.2478, 56.6267, 49.8755, 47.1765, & + 44.0477, 31.0565, 23.0244, 19.6510, 17.8987, 17.4376, & + 16.0621, 5.10608, 3.00679, 2.42293, 2.16406, 2.00901, & + 1.90374, 1.98072, 1.81902, 2.06155, 2.06154, 2.18280, & + 2.42531,2.70824,1.12105,0.108119,0.00944200,0.00115201, & + 0.000221094,0.000101946,7.49350e-06/) + + case(3) +! // tropical + prs = (/1013.00, 904.000, 805.000, 715.000, 633.000, 559.000, & + 492.000, 432.000, 378.000, 329.000, 286.000, 247.000, & + 213.000, 182.000, 156.000, 132.000, 111.000, 93.7000, & + 78.9000, 66.6000, 56.5000, 48.0000, 40.9000, 35.0000, & + 30.0000, 25.7000, 12.2000, 6.00000, 3.05000, 1.59000, & + 0.854000,0.0579000,0.000300000/) + + tk = (/300.000, 294.000, 288.000, 284.000, 277.000, 270.000, & + 264.000, 257.000, 250.000, 244.000, 237.000, 230.000, & + 224.000, 217.000, 210.000, 204.000, 197.000, 195.000, & + 199.000, 203.000, 207.000, 211.000, 215.000, 217.000, & + 219.000, 221.000, 232.000, 243.000, 254.000, 265.000, & + 270.000, 219.000, 210.000/) + + rh = (/71.4334, 69.4097, 71.4488, 46.7724, 34.7129, 38.3820, & + 33.7214, 32.0122, 30.2607, 24.5059, 19.5321, 13.2966, & + 8.85795, 5.87496, 7.68644, 12.8879, 29.4976, 34.9351, & + 17.1606, 9.53422, 5.10154, 3.45407, 2.11168, 1.76247, & + 1.55162,1.37966,0.229799,0.0245943,0.00373686,0.000702138, & + 0.000162076,0.000362055,7.68645e-06/) + + case default + print *, 'Must enter a profile type' + stop + + end select + + end subroutine mcclatchey + + end module atmos_lib Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/congvec.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/congvec.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/congvec.h (revision 1280) @@ -0,0 +1,54 @@ + +! *****************************COPYRIGHT**************************** +! (c) British Crown Copyright 2009, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the +! following conditions are met: +! +! * Redistributions of source code must retain the above +! copyright notice, this list of conditions and the following +! disclaimer. +! * Redistributions in binary form must reproduce the above +! copyright notice, this list of conditions and the following +! disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its +! contributors may be used to endorse or promote products +! derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! *****************************COPYRIGHT******************************* +! *****************************COPYRIGHT******************************* + + do irand = 1, npoints + ! Marsaglia CONG algorithm + seed(irand)=69069*seed(irand)+1234567 + ! mod 32 bit overflow + seed(irand)=mod(seed(irand),2**30) + ran(irand)=seed(irand)*0.931322574615479E-09 + enddo + + ! convert to range 0-1 (32 bit only) + overflow_32=i2_16*i2_16 + if ( overflow_32 .le. huge32 ) then + do irand = 1, npoints + ran(irand)=ran(irand)+1 + ran(irand)=(ran(irand))-int(ran(irand)) + enddo + endif + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp.F90 (revision 1280) @@ -0,0 +1,490 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +MODULE MOD_COSP + USE MOD_COSP_TYPES + USE MOD_COSP_SIMULATOR + IMPLICIT NONE + +CONTAINS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE COSP --------------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar) + + ! Arguments + integer,intent(in) :: overlap ! overlap type in SCOPS: 1=max, 2=rand, 3=max/rand + integer,intent(in) :: Ncolumns + type(cosp_config),intent(in) :: cfg ! Configuration options + type(cosp_vgrid),intent(in) :: vgrid ! Information on vertical grid of stats + type(cosp_gridbox),intent(inout) :: gbx + type(cosp_subgrid),intent(inout) :: sgx ! Subgrid info + type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator + type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator + type(cosp_isccp),intent(inout) :: isccp ! Output from ISCCP simulator + type(cosp_misr),intent(inout) :: misr ! Output from MISR simulator + type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator + type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator + + ! Local variables + integer :: Npoints ! Number of gridpoints + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + integer :: Niter ! Number of calls to cosp_simulator + integer :: i_first,i_last ! First and last gridbox to be processed in each iteration + integer :: i,j,k,Ni + integer,dimension(2) :: ix,iy + logical :: reff_zero + real :: minv,maxv + real :: maxp,minp + integer,dimension(:),allocatable :: & ! Dimensions nPoints + seed ! It is recommended that the seed is set to a different value for each model + ! gridbox it is called on, as it is possible that the choice of the same + ! seed value every time may introduce some statistical bias in the results, + ! particularly for low values of NCOL. + ! Types used in one iteration + type(cosp_gridbox) :: gbx_it + type(cosp_subgrid) :: sgx_it + type(cosp_vgrid) :: vgrid_it + type(cosp_sgradar) :: sgradar_it + type(cosp_sglidar) :: sglidar_it + type(cosp_isccp) :: isccp_it + type(cosp_misr) :: misr_it + type(cosp_radarstats) :: stradar_it + type(cosp_lidarstats) :: stlidar_it + + !++++++++++ Dimensions ++++++++++++ + Npoints = gbx%Npoints + Nlevels = gbx%Nlevels + Nhydro = gbx%Nhydro + +!++++++++++ Apply sanity checks to inputs ++++++++++ +! call cosp_check_input('longitude',gbx%longitude,min_val=0.0,max_val=360.0) + call cosp_check_input('longitude',gbx%longitude,min_val=-180.0,max_val=180.0) + call cosp_check_input('latitude',gbx%latitude,min_val=-90.0,max_val=90.0) + call cosp_check_input('dlev',gbx%dlev,min_val=0.0) + call cosp_check_input('p',gbx%p,min_val=0.0) + call cosp_check_input('ph',gbx%ph,min_val=0.0) + call cosp_check_input('T',gbx%T,min_val=0.0) + call cosp_check_input('q',gbx%q,min_val=0.0) + call cosp_check_input('sh',gbx%sh,min_val=0.0) + call cosp_check_input('dtau_s',gbx%dtau_s,min_val=0.0) + call cosp_check_input('dtau_c',gbx%dtau_c,min_val=0.0) + call cosp_check_input('dem_s',gbx%dem_s,min_val=0.0,max_val=1.0) + call cosp_check_input('dem_c',gbx%dem_c,min_val=0.0,max_val=1.0) + ! Point information (Npoints) + call cosp_check_input('land',gbx%land,min_val=0.0,max_val=1.0) + call cosp_check_input('psfc',gbx%psfc,min_val=0.0) + call cosp_check_input('sunlit',gbx%sunlit,min_val=0.0,max_val=1.0) + call cosp_check_input('skt',gbx%skt,min_val=0.0) + ! TOTAL and CONV cloud fraction for SCOPS + call cosp_check_input('tca',gbx%tca,min_val=0.0,max_val=1.0) + call cosp_check_input('cca',gbx%cca,min_val=0.0,max_val=1.0) + ! Precipitation fluxes on model levels + call cosp_check_input('rain_ls',gbx%rain_ls,min_val=0.0) + call cosp_check_input('rain_cv',gbx%rain_cv,min_val=0.0) + call cosp_check_input('snow_ls',gbx%snow_ls,min_val=0.0) + call cosp_check_input('snow_cv',gbx%snow_cv,min_val=0.0) + call cosp_check_input('grpl_ls',gbx%grpl_ls,min_val=0.0) + ! Hydrometeors concentration and distribution parameters + call cosp_check_input('mr_hydro',gbx%mr_hydro,min_val=0.0) + ! Effective radius [m]. (Npoints,Nlevels,Nhydro) + call cosp_check_input('Reff',gbx%Reff,min_val=0.0) + reff_zero=.true. + if (any(gbx%Reff > 1.e-8)) then + reff_zero=.false. + ! reff_zero == .false. + ! and gbx%use_reff == .true. Reff use in radar and lidar + ! and reff_zero == .false. Reff use in lidar and set to 0 for radar + endif + if ((gbx%use_reff) .and. (reff_zero)) then ! Inconsistent choice. Want to use Reff but not inputs passed + print *, '---------- COSP ERROR ------------' + print *, '' + print *, 'use_reff==.true. but Reff is always zero' + print *, '' + print *, '----------------------------------' + stop + endif + if ((.not. gbx%use_reff) .and. (reff_zero)) then ! No Reff in radar. Default in lidar + gbx%Reff = DEFAULT_LIDAR_REFF + print *, '---------- COSP WARNING ------------' + print *, '' + print *, 'Using default Reff in lidar simulations' + print *, '' + print *, '----------------------------------' + endif + + ! Aerosols concentration and distribution parameters + call cosp_check_input('conc_aero',gbx%conc_aero,min_val=0.0) + ! Checks for CRM mode + if (Ncolumns == 1) then + if (gbx%use_precipitation_fluxes) then + print *, '---------- COSP ERROR ------------' + print *, '' + print *, 'Use of precipitation fluxes not supported in CRM mode (Ncolumns=1)' + print *, '' + print *, '----------------------------------' + stop + endif + if ((maxval(gbx%dtau_c) > 0.0).or.(maxval(gbx%dem_c) > 0.0)) then + print *, '---------- COSP ERROR ------------' + print *, '' + print *, ' dtau_c > 0.0 or dem_c > 0.0. In CRM mode (Ncolumns=1), ' + print *, ' the optical depth (emmisivity) of all clouds must be ' + print *, ' passed through dtau_s (dem_s)' + print *, '' + print *, '----------------------------------' + stop + endif + endif + + + ! We base the seed in the decimal part of the surface pressure. + allocate(seed(Npoints)) + seed = int(gbx%psfc) ! This is to avoid division by zero when Npoints = 1 + ! Roj Oct/2008 ... Note: seed value of 0 caused me some problems + I want to + ! randomize for each call to COSP even when Npoints ==1 + minp = minval(gbx%psfc) + maxp = maxval(gbx%psfc) + if (Npoints .gt. 1) seed=int((gbx%psfc-minp)/(maxp-minp)*100000) + 1 + + + if (gbx%Npoints_it >= gbx%Npoints) then ! One iteration gbx%Npoints + call cosp_iter(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar) + else ! Several iterations to save memory + Niter = gbx%Npoints/gbx%Npoints_it ! Integer division + if (Niter*gbx%Npoints_it < gbx%Npoints) Niter = Niter + 1 + do i=1,Niter + i_first = (i-1)*gbx%Npoints_it + 1 + i_last = i_first + gbx%Npoints_it - 1 + i_last = min(i_last,gbx%Npoints) + Ni = i_last - i_first + 1 + if (i == 1) then + ! Allocate types for all but last iteration + call construct_cosp_gridbox(gbx%time,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables,gbx%use_gas_abs, & + gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels,Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, & + gbx%Naero,gbx%Nprmts_max_aero,Ni,gbx%lidar_ice_type,gbx%isccp_top_height, & + gbx%isccp_top_height_direction,gbx%isccp_overlap,gbx%isccp_emsfc_lw, & + gbx%use_precipitation_fluxes,gbx%use_reff, & + gbx%plat,gbx%sat,gbx%inst,gbx%nchan,gbx%ZenAng, & + gbx%Ichan(1:gbx%nchan),gbx%surfem(1:gbx%nchan), & + gbx%co2,gbx%ch4,gbx%n2o,gbx%co, & + gbx_it) + call construct_cosp_vgrid(gbx_it,vgrid%Nlvgrid,vgrid%use_vgrid,vgrid%csat_vgrid,vgrid_it) + call construct_cosp_subgrid(Ni, Ncolumns, Nlevels, sgx_it) + call construct_cosp_sgradar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,sgradar_it) + call construct_cosp_sglidar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar_it) + call construct_cosp_isccp(cfg,Ni,Ncolumns,Nlevels,isccp_it) + call construct_cosp_misr(cfg,Ni,misr_it) + call construct_cosp_radarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar_it) + call construct_cosp_lidarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar_it) + elseif (i == Niter) then ! last iteration + call free_cosp_gridbox(gbx_it,.true.) + call free_cosp_subgrid(sgx_it) + call free_cosp_vgrid(vgrid_it) + call free_cosp_sgradar(sgradar_it) + call free_cosp_sglidar(sglidar_it) + call free_cosp_isccp(isccp_it) + call free_cosp_misr(misr_it) + call free_cosp_radarstats(stradar_it) + call free_cosp_lidarstats(stlidar_it) + ! Allocate types for iterations + call construct_cosp_gridbox(gbx%time,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables,gbx%use_gas_abs, & + gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels,Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, & + gbx%Naero,gbx%Nprmts_max_aero,Ni,gbx%lidar_ice_type,gbx%isccp_top_height, & + gbx%isccp_top_height_direction,gbx%isccp_overlap,gbx%isccp_emsfc_lw, & + gbx%use_precipitation_fluxes,gbx%use_reff, & + gbx%plat,gbx%sat,gbx%inst,gbx%nchan,gbx%ZenAng, & + gbx%Ichan(1:gbx%nchan),gbx%surfem(1:gbx%nchan), & + gbx%co2,gbx%ch4,gbx%n2o,gbx%co, & + gbx_it) + ! --- Copy arrays without Npoints as dimension --- + gbx_it%dist_prmts_hydro = gbx%dist_prmts_hydro + gbx_it%dist_type_aero = gbx_it%dist_type_aero + call construct_cosp_vgrid(gbx_it,vgrid%Nlvgrid,vgrid%use_vgrid,vgrid%csat_vgrid,vgrid_it) + call construct_cosp_subgrid(Ni, Ncolumns, Nlevels, sgx_it) + call construct_cosp_sgradar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,sgradar_it) + call construct_cosp_sglidar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar_it) + call construct_cosp_isccp(cfg,Ni,Ncolumns,Nlevels,isccp_it) + call construct_cosp_misr(cfg,Ni,misr_it) + call construct_cosp_radarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar_it) + call construct_cosp_lidarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar_it) + endif + ! --- Copy sections of arrays with Npoints as dimension --- + ix=(/i_first,i_last/) + iy=(/1,Ni/) + call cosp_gridbox_cpsection(ix,iy,gbx,gbx_it) + ! These serve as initialisation of *_it types + call cosp_subgrid_cpsection(ix,iy,sgx,sgx_it) + if (cfg%Lradar_sim) call cosp_sgradar_cpsection(ix,iy,sgradar,sgradar_it) + if (cfg%Llidar_sim) call cosp_sglidar_cpsection(ix,iy,sglidar,sglidar_it) + if (cfg%Lisccp_sim) call cosp_isccp_cpsection(ix,iy,isccp,isccp_it) + if (cfg%Lmisr_sim) call cosp_misr_cpsection(ix,iy,misr,misr_it) + if (cfg%Lradar_sim) call cosp_radarstats_cpsection(ix,iy,stradar,stradar_it) + if (cfg%Llidar_sim) call cosp_lidarstats_cpsection(ix,iy,stlidar,stlidar_it) + print *,'---------ix: ',ix + call cosp_iter(overlap,seed(ix(1):ix(2)),cfg,vgrid_it,gbx_it,sgx_it,sgradar_it, & + sglidar_it,isccp_it,misr_it,stradar_it,stlidar_it) + + ! --- Copy results to output structures --- +! call cosp_gridbox_cphp(gbx_it,gbx) + ix=(/1,Ni/) + iy=(/i_first,i_last/) + call cosp_subgrid_cpsection(ix,iy,sgx_it,sgx) + if (cfg%Lradar_sim) call cosp_sgradar_cpsection(ix,iy,sgradar_it,sgradar) + if (cfg%Llidar_sim) call cosp_sglidar_cpsection(ix,iy,sglidar_it,sglidar) + if (cfg%Lisccp_sim) call cosp_isccp_cpsection(ix,iy,isccp_it,isccp) + if (cfg%Lmisr_sim) call cosp_misr_cpsection(ix,iy,misr_it,misr) + if (cfg%Lradar_sim) call cosp_radarstats_cpsection(ix,iy,stradar_it,stradar) + if (cfg%Llidar_sim) call cosp_lidarstats_cpsection(ix,iy,stlidar_it,stlidar) + enddo + ! Deallocate types + call free_cosp_gridbox(gbx_it,.true.) + call free_cosp_subgrid(sgx_it) + call free_cosp_vgrid(vgrid_it) + call free_cosp_sgradar(sgradar_it) + call free_cosp_sglidar(sglidar_it) + call free_cosp_isccp(isccp_it) + call free_cosp_misr(misr_it) + call free_cosp_radarstats(stradar_it) + call free_cosp_lidarstats(stlidar_it) + endif + deallocate(seed) + + +END SUBROUTINE COSP + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE COSP_ITER ---------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_ITER(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar) + + ! Arguments + integer,intent(in) :: overlap ! overlap type in SCOPS: 1=max, 2=rand, 3=max/rand + integer,dimension(:),intent(in) :: seed + type(cosp_config),intent(in) :: cfg ! Configuration options + type(cosp_vgrid),intent(in) :: vgrid ! Information on vertical grid of stats + type(cosp_gridbox),intent(inout) :: gbx + type(cosp_subgrid),intent(inout) :: sgx ! Subgrid info + type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator + type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator + type(cosp_isccp),intent(inout) :: isccp ! Output from ISCCP simulator + type(cosp_misr),intent(inout) :: misr ! Output from MISR simulator + type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator + type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator + + ! Local variables + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of subcolumns + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + integer :: Niter ! Number of calls to cosp_simulator + integer :: i,j,k + real,dimension(:,:),pointer :: column_frac_out ! Array with one column of frac_out + integer :: scops_debug=0 ! set to non-zero value to print out inputs for debugging in SCOPS + real,dimension(:, :),allocatable :: cca_scops,ls_p_rate,cv_p_rate, & + tca_scops ! Cloud cover in each model level (HORIZONTAL gridbox fraction) of total cloud. + ! Levels are from TOA to SURFACE. (nPoints, nLev) + real,dimension(:,:),allocatable :: frac_ls,prec_ls,frac_cv,prec_cv ! Cloud/Precipitation fraction in each model level + ! Levels are from SURFACE to TOA + type(cosp_sghydro) :: sghydro ! Subgrid info for hydrometeors en each iteration + + + !++++++++++ Dimensions ++++++++++++ + Npoints = gbx%Npoints + Ncolumns = gbx%Ncolumns + Nlevels = gbx%Nlevels + Nhydro = gbx%Nhydro + + + !++++++++++ Climate/NWP mode ++++++++++ + if (Ncolumns > 1) then + !++++++++++ Subgrid sampling ++++++++++ + ! Allocate arrays before calling SCOPS + allocate(frac_ls(Npoints,Nlevels),frac_cv(Npoints,Nlevels),prec_ls(Npoints,Nlevels),prec_cv(Npoints,Nlevels)) + allocate(tca_scops(Npoints,Nlevels),cca_scops(Npoints,Nlevels), & + ls_p_rate(Npoints,Nlevels),cv_p_rate(Npoints,Nlevels)) + ! Initialize to zero + frac_ls=0.0 + prec_ls=0.0 + frac_cv=0.0 + prec_cv=0.0 + ! Cloud fractions for SCOPS from TOA to SFC + tca_scops = gbx%tca(:,Nlevels:1:-1) + cca_scops = gbx%cca(:,Nlevels:1:-1) + + ! Call to SCOPS + ! strat and conv arrays are passed with levels from TOA to SURFACE. + call scops(Npoints,Nlevels,Ncolumns,seed,tca_scops,cca_scops,overlap,sgx%frac_out,scops_debug) + + ! temporarily use prec_ls/cv to transfer information about precipitation flux into prec_scops + if(gbx%use_precipitation_fluxes) then + ls_p_rate(:,Nlevels:1:-1)=gbx%rain_ls(:,1:Nlevels)+gbx%snow_ls(:,1:Nlevels)+gbx%grpl_ls(:,1:Nlevels) + cv_p_rate(:,Nlevels:1:-1)=gbx%rain_cv(:,1:Nlevels)+gbx%snow_cv(:,1:Nlevels) + else + ls_p_rate(:,Nlevels:1:-1)=gbx%mr_hydro(:,1:Nlevels,I_LSRAIN)+ & + gbx%mr_hydro(:,1:Nlevels,I_LSSNOW)+ & + gbx%mr_hydro(:,1:Nlevels,I_LSGRPL) + cv_p_rate(:,Nlevels:1:-1)=gbx%mr_hydro(:,1:Nlevels,I_CVRAIN)+ & + gbx%mr_hydro(:,1:Nlevels,I_CVSNOW) + endif + + call prec_scops(Npoints,Nlevels,Ncolumns,ls_p_rate,cv_p_rate,sgx%frac_out,sgx%prec_frac) + + ! Precipitation fraction + do j=1,Npoints,1 + do k=1,Nlevels,1 + do i=1,Ncolumns,1 + if (sgx%frac_out (j,i,Nlevels+1-k) .eq. 1) frac_ls(j,k)=frac_ls(j,k)+1. + if (sgx%frac_out (j,i,Nlevels+1-k) .eq. 2) frac_cv(j,k)=frac_cv(j,k)+1. + if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 1) prec_ls(j,k)=prec_ls(j,k)+1. + if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 2) prec_cv(j,k)=prec_cv(j,k)+1. + if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 3) then + prec_cv(j,k)=prec_cv(j,k)+1. + prec_ls(j,k)=prec_ls(j,k)+1. + endif + enddo !i + frac_ls(j,k)=frac_ls(j,k)/Ncolumns + frac_cv(j,k)=frac_cv(j,k)/Ncolumns + prec_ls(j,k)=prec_ls(j,k)/Ncolumns + prec_cv(j,k)=prec_cv(j,k)/Ncolumns + enddo !k + enddo !j + + ! Levels from SURFACE to TOA. + if (Npoints*Ncolumns*Nlevels < 10000) then + sgx%frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1) + sgx%prec_frac(1:Npoints,:,1:Nlevels) = sgx%prec_frac(1:Npoints,:,Nlevels:1:-1) + else + ! This is done within a loop (unvectorized) over nPoints to save memory + do j=1,Npoints + sgx%frac_out(j,:,1:Nlevels) = sgx%frac_out(j,:,Nlevels:1:-1) + sgx%prec_frac(j,:,1:Nlevels) = sgx%prec_frac(j,:,Nlevels:1:-1) + enddo + endif + + ! Deallocate arrays that will no longer be used + deallocate(tca_scops,cca_scops,ls_p_rate,cv_p_rate) + + ! Populate the subgrid arrays + call construct_cosp_sghydro(Npoints,Ncolumns,Nlevels,Nhydro,sghydro) + do k=1,Ncolumns + !--------- Mixing ratios for clouds and Reff for Clouds and precip ------- + column_frac_out => sgx%frac_out(:,k,:) + where (column_frac_out == 1) !+++++++++++ LS clouds ++++++++ + sghydro%mr_hydro(:,k,:,I_LSCLIQ) = gbx%mr_hydro(:,:,I_LSCLIQ) + sghydro%mr_hydro(:,k,:,I_LSCICE) = gbx%mr_hydro(:,:,I_LSCICE) + + sghydro%Reff(:,k,:,I_LSCLIQ) = gbx%Reff(:,:,I_LSCLIQ) + sghydro%Reff(:,k,:,I_LSCICE) = gbx%Reff(:,:,I_LSCICE) + sghydro%Reff(:,k,:,I_LSRAIN) = gbx%Reff(:,:,I_LSRAIN) + sghydro%Reff(:,k,:,I_LSSNOW) = gbx%Reff(:,:,I_LSSNOW) + sghydro%Reff(:,k,:,I_LSGRPL) = gbx%Reff(:,:,I_LSGRPL) + elsewhere (column_frac_out == 2) !+++++++++++ CONV clouds ++++++++ + sghydro%mr_hydro(:,k,:,I_CVCLIQ) = gbx%mr_hydro(:,:,I_CVCLIQ) + sghydro%mr_hydro(:,k,:,I_CVCICE) = gbx%mr_hydro(:,:,I_CVCICE) + + sghydro%Reff(:,k,:,I_CVCLIQ) = gbx%Reff(:,:,I_CVCLIQ) + sghydro%Reff(:,k,:,I_CVCICE) = gbx%Reff(:,:,I_CVCICE) + sghydro%Reff(:,k,:,I_CVRAIN) = gbx%Reff(:,:,I_CVRAIN) + sghydro%Reff(:,k,:,I_CVSNOW) = gbx%Reff(:,:,I_CVSNOW) + end where + !--------- Precip ------- + if (.not. gbx%use_precipitation_fluxes) then + where (column_frac_out == 1) !+++++++++++ LS Precipitation ++++++++ + sghydro%mr_hydro(:,k,:,I_LSRAIN) = gbx%mr_hydro(:,:,I_LSRAIN) + sghydro%mr_hydro(:,k,:,I_LSSNOW) = gbx%mr_hydro(:,:,I_LSSNOW) + sghydro%mr_hydro(:,k,:,I_LSGRPL) = gbx%mr_hydro(:,:,I_LSGRPL) + elsewhere (column_frac_out == 2) !+++++++++++ CONV Precipitation ++++++++ + sghydro%mr_hydro(:,k,:,I_CVRAIN) = gbx%mr_hydro(:,:,I_CVRAIN) + sghydro%mr_hydro(:,k,:,I_CVSNOW) = gbx%mr_hydro(:,:,I_CVSNOW) + end where + endif + enddo + ! convert the mixing ratio and precipitation flux from gridbox mean to the fraction-based values + do k=1,Nlevels + do j=1,Npoints + !--------- Clouds ------- + if (frac_ls(j,k) .ne. 0.) then + sghydro%mr_hydro(j,:,k,I_LSCLIQ) = sghydro%mr_hydro(j,:,k,I_LSCLIQ)/frac_ls(j,k) + sghydro%mr_hydro(j,:,k,I_LSCICE) = sghydro%mr_hydro(j,:,k,I_LSCICE)/frac_ls(j,k) + endif + if (frac_cv(j,k) .ne. 0.) then + sghydro%mr_hydro(j,:,k,I_CVCLIQ) = sghydro%mr_hydro(j,:,k,I_CVCLIQ)/frac_cv(j,k) + sghydro%mr_hydro(j,:,k,I_CVCICE) = sghydro%mr_hydro(j,:,k,I_CVCICE)/frac_cv(j,k) + endif + !--------- Precip ------- + if (gbx%use_precipitation_fluxes) then + if (prec_ls(j,k) .ne. 0.) then + gbx%rain_ls(j,k) = gbx%rain_ls(j,k)/prec_ls(j,k) + gbx%snow_ls(j,k) = gbx%snow_ls(j,k)/prec_ls(j,k) + gbx%grpl_ls(j,k) = gbx%grpl_ls(j,k)/prec_ls(j,k) + endif + if (prec_cv(j,k) .ne. 0.) then + gbx%rain_cv(j,k) = gbx%rain_cv(j,k)/prec_cv(j,k) + gbx%snow_cv(j,k) = gbx%snow_cv(j,k)/prec_cv(j,k) + endif + else + if (prec_ls(j,k) .ne. 0.) then + sghydro%mr_hydro(j,:,k,I_LSRAIN) = sghydro%mr_hydro(j,:,k,I_LSRAIN)/prec_ls(j,k) + sghydro%mr_hydro(j,:,k,I_LSSNOW) = sghydro%mr_hydro(j,:,k,I_LSSNOW)/prec_ls(j,k) + sghydro%mr_hydro(j,:,k,I_LSGRPL) = sghydro%mr_hydro(j,:,k,I_LSGRPL)/prec_ls(j,k) + endif + if (prec_cv(j,k) .ne. 0.) then + sghydro%mr_hydro(j,:,k,I_CVRAIN) = sghydro%mr_hydro(j,:,k,I_CVRAIN)/prec_cv(j,k) + sghydro%mr_hydro(j,:,k,I_CVSNOW) = sghydro%mr_hydro(j,:,k,I_CVSNOW)/prec_cv(j,k) + endif + endif + enddo !k + enddo !j + deallocate(frac_ls,prec_ls,frac_cv,prec_cv) + + if (gbx%use_precipitation_fluxes) then + ! convert precipitation flux into mixing ratio + call pf_to_mr(Npoints,Nlevels,Ncolumns,gbx%rain_ls,gbx%snow_ls,gbx%grpl_ls, & + gbx%rain_cv,gbx%snow_cv,sgx%prec_frac,gbx%p,gbx%T, & + sghydro%mr_hydro(:,:,:,I_LSRAIN),sghydro%mr_hydro(:,:,:,I_LSSNOW),sghydro%mr_hydro(:,:,:,I_LSGRPL), & + sghydro%mr_hydro(:,:,:,I_CVRAIN),sghydro%mr_hydro(:,:,:,I_CVSNOW)) + endif + !++++++++++ CRM mode ++++++++++ + else + sghydro%mr_hydro(:,1,:,:) = gbx%mr_hydro + sghydro%Reff(:,1,:,:) = gbx%Reff + !--------- Clouds ------- + where ((gbx%dtau_s > 0.0)) + sgx%frac_out(:,1,:) = 1 ! Subgrid cloud array. Dimensions (Npoints,Ncolumns,Nlevels) + endwhere + endif ! Ncolumns > 1 + + + !++++++++++ Simulator ++++++++++ + call cosp_simulator(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,stradar,stlidar) + + ! Deallocate subgrid arrays + call free_cosp_sghydro(sghydro) +END SUBROUTINE COSP_ITER + +END MODULE MOD_COSP Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_constants.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_constants.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_constants.F90 (revision 1280) @@ -0,0 +1,124 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! Jul 2008 - A. Bodas-Salcedo - Added definitions of ISCCP axes +! Oct 2008 - H. Chepfer - Added PARASOL_NREFL +! +! +MODULE MOD_COSP_CONSTANTS +! use netcdf, only: nf90_fill_rea + IMPLICIT NONE + + ! Indices to address arrays of LS and CONV hydrometeors + integer,parameter :: I_LSCLIQ = 1 + integer,parameter :: I_LSCICE = 2 + integer,parameter :: I_LSRAIN = 3 + integer,parameter :: I_LSSNOW = 4 + integer,parameter :: I_CVCLIQ = 5 + integer,parameter :: I_CVCICE = 6 + integer,parameter :: I_CVRAIN = 7 + integer,parameter :: I_CVSNOW = 8 + integer,parameter :: I_LSGRPL = 9 + + ! Missing value +!! real,parameter :: R_UNDEF = -1.0E30 + real,parameter :: R_UNDEF = 9.96921e+36 +! real,parameter :: R_UNDEF = nf90_fill_rea + ! Number of possible output variables + integer,parameter :: N_OUT_LIST = 27 + + !--- Radar constants + ! CFAD constants + integer,parameter :: DBZE_BINS = 15 ! Number of dBZe bins in histogram (cfad) + real,parameter :: DBZE_MIN = -100.0 ! Minimum value for radar reflectivity + real,parameter :: DBZE_MAX = 30.0 ! Maximum value for radar reflectivity + real,parameter :: CFAD_ZE_MIN = -50.0 ! Lower value of the first CFAD Ze bin + real,parameter :: CFAD_ZE_WIDTH = 5.0 ! Bin width (dBZe) + + + !--- Lidar constants + ! CFAD constants + integer,parameter :: SR_BINS = 15 + integer,parameter :: DPOL_BINS = 6 + real,parameter :: LIDAR_UNDEF = 999.999 + ! Other constants + integer,parameter :: LIDAR_NCAT = 4 + integer,parameter :: PARASOL_NREFL = 5 ! parasol +! real,parameter,dimension(PARASOL_NREFL) :: PARASOL_SZA = (/0.0, 15.0, 30.0, 45.0, 60.0/) + real,parameter,dimension(PARASOL_NREFL) :: PARASOL_SZA = (/1.0, 2.0, 3.0, 4.0, 5.0/) + real,parameter :: DEFAULT_LIDAR_REFF = 30.0e-6 ! Default lidar effective radius + + !--- MISR constants + integer,parameter :: MISR_N_CTH = 16 + + !--- RTTOV constants + integer,parameter :: RTTOV_MAX_CHANNELS = 20 + + ! ISCCP tau-Pc axes + real,parameter,dimension(7) :: ISCCP_TAU = (/0.15, 0.80, 2.45, 6.5, 16.2, 41.5, 50000.0/) + real,parameter,dimension(2,7) :: ISCCP_TAU_BNDS = reshape(source=(/0.0,0.3,0.3,1.30,1.30,3.6,3.6,9.4, & + 9.4,23.0,23.0,60.0,60.0,100000.0/), shape=(/2,7/)) + +! real,parameter,dimension(7) :: ISCCP_PC = (/9000., 24500., 37500., 50000., 62000., 74000., 90000./) +! real,parameter,dimension(2,7) :: ISCCP_PC_BNDS = reshape(source=(/0.0,18000.0,18000.0,31000.0,31000.0, & +! 44000.0,44000.0,56000.0,56000.0,68000.0,68000.0,80000.0,80000.0,100000.0/), shape=(/2,7/)) + + real,parameter,dimension(7) :: ISCCP_PC = (/90000., 74000., 62000., 50000., 37500., 24500., 9000./) + real,parameter,dimension(2,7) :: ISCCP_PC_BNDS = reshape(source=(/100000.0,80000.0,80000.0,68000.0,68000.0,56000.0 & + ,56000.0,44000.0,44000.0,31000.0,31000.0,18000.0,18000.0,0.0/), shape=(/2,7/)) + + real,parameter,dimension(MISR_N_CTH) :: MISR_CTH = (/ 0., 0.25, 0.75, 1.25, 1.75, 2.25, 2.75, 3.5, & + 4.5, 6., 8., 10., 12., 14.5, 16., 18./) + real,parameter,dimension(2,MISR_N_CTH) :: MISR_CTH_BNDS = reshape(source=(/ & + -99.0, 0.0, 0.0, 0.5, 0.5, 1.0, 1.0, 1.5, & + 1.5, 2.0, 2.0, 2.5, 2.5, 3.0, 3.0, 4.0, & + 4.0, 5.0, 5.0, 7.0, 7.0, 9.0, 9.0, 11.0, & + 11.0, 13.0, 13.0, 15.0, 15.0, 17.0, 17.0, 99.0/), & + shape=(/2,MISR_N_CTH/)) + + ! Table hclass for quickbeam + integer,parameter :: N_HYDRO = 9 + real :: HCLASS_TYPE(N_HYDRO),HCLASS_COL(N_HYDRO),HCLASS_PHASE(N_HYDRO), & + HCLASS_CP(N_HYDRO),HCLASS_DMIN(N_HYDRO),HCLASS_DMAX(N_HYDRO) + real :: HCLASS_APM(N_HYDRO),HCLASS_BPM(N_HYDRO),HCLASS_RHO(N_HYDRO), & + HCLASS_P1(N_HYDRO),HCLASS_P2(N_HYDRO),HCLASS_P3(N_HYDRO) + data HCLASS_TYPE/5,1,2,2,5,1,2,2,2/ + data HCLASS_COL/1,2,3,4,5,6,7,8,9/ + data HCLASS_PHASE/0,1,0,1,0,1,0,1,1/ + data HCLASS_CP/0,0,1,1,0,0,1,1,1/ + data HCLASS_DMIN/-1,-1,-1,-1,-1,-1,-1,-1,-1/ + data HCLASS_DMAX/-1,-1,-1,-1,-1,-1,-1,-1,-1/ + data HCLASS_APM/524,110.8,524,-1,524,110.8,524,-1,-1/ + data HCLASS_BPM/3,2.91,3,-1,3,2.91,3,-1,-1/ + data HCLASS_RHO/-1,-1,-1,100,-1,-1,-1,100,400/ + data HCLASS_P1/-1,-1,8000000.,3000000.,-1,-1,8000000.,3000000.,4000000./ + data HCLASS_P2/6,40,-1,-1,6,40,-1,-1,-1/ + data HCLASS_P3/0.3,2,-1,-1,0.3,2,-1,-1,-1/ + + + +END MODULE MOD_COSP_CONSTANTS Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_isccp_simulator.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_isccp_simulator.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_isccp_simulator.F90 (revision 1280) @@ -0,0 +1,96 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +MODULE MOD_COSP_ISCCP_SIMULATOR + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + IMPLICIT NONE + +CONTAINS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!-------------- SUBROUTINE COSP_ISCCP_SIMULATOR ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_ISCCP_SIMULATOR(gbx,sgx,y) + + ! Arguments + type(cosp_gridbox),intent(in) :: gbx ! Gridbox info + type(cosp_subgrid),intent(in) :: sgx ! Subgridbox info + type(cosp_isccp),intent(inout) :: y ! ISCCP simulator output + + ! Local variables + integer :: i,Nlevels,Npoints + real :: pfull(gbx%Npoints, gbx%Nlevels) + real :: phalf(gbx%Npoints, gbx%Nlevels + 1) + real :: qv(gbx%Npoints, gbx%Nlevels) + real :: cc(gbx%Npoints, gbx%Nlevels) + real :: conv(gbx%Npoints, gbx%Nlevels) + real :: dtau_s(gbx%Npoints, gbx%Nlevels) + real :: dtau_c(gbx%Npoints, gbx%Nlevels) + real :: at(gbx%Npoints, gbx%Nlevels) + real :: dem_s(gbx%Npoints, gbx%Nlevels) + real :: dem_c(gbx%Npoints, gbx%Nlevels) + real :: frac_out(gbx%Npoints, gbx%Ncolumns, gbx%Nlevels) + integer :: sunlit(gbx%Npoints) + + Nlevels = gbx%Nlevels + Npoints = gbx%Npoints + ! Flip inputs. Levels from TOA to surface + pfull = gbx%p(:,Nlevels:1:-1) + phalf(:,1) = 0.0 ! Top level + phalf(:,2:Nlevels+1) = gbx%ph(:,Nlevels:1:-1) + qv = gbx%sh(:,Nlevels:1:-1) + cc = 0.999999*gbx%tca(:,Nlevels:1:-1) + conv = 0.999999*gbx%cca(:,Nlevels:1:-1) + dtau_s = gbx%dtau_s(:,Nlevels:1:-1) + dtau_c = gbx%dtau_c(:,Nlevels:1:-1) + at = gbx%T(:,Nlevels:1:-1) + dem_s = gbx%dem_s(:,Nlevels:1:-1) + dem_c = gbx%dem_c(:,Nlevels:1:-1) + frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1) + sunlit = int(gbx%sunlit) + call icarus(0,0,gbx%npoints,sunlit,gbx%nlevels,gbx%ncolumns, & + pfull,phalf,qv,cc,conv,dtau_s,dtau_c, & + gbx%isccp_top_height,gbx%isccp_top_height_direction, & + gbx%isccp_overlap,frac_out, & + gbx%skt,gbx%isccp_emsfc_lw,at,dem_s,dem_c,y%fq_isccp,y%totalcldarea, & + y%meanptop,y%meantaucld,y%meanalbedocld, & + y%meantb,y%meantbclr,y%boxtau,y%boxptop) + + ! Flip outputs. Levels from surface to TOA + ! --- (npoints,tau=7,pressure=7) + y%fq_isccp(:,:,:) = y%fq_isccp(:,:,7:1:-1) + + ! Change boxptop from hPa to Pa. This avoids using UDUNITS in CMOR + y%boxptop = y%boxptop*100.0 + + ! Check if there is any value slightly greater than 1 + where ((y%totalcldarea > 1.0-1.e-5) .and. (y%totalcldarea < 1.0+1.e-5)) + y%totalcldarea = 1.0 + endwhere + +END SUBROUTINE COSP_ISCCP_SIMULATOR + +END MODULE MOD_COSP_ISCCP_SIMULATOR Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_lidar.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_lidar.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_lidar.F90 (revision 1280) @@ -0,0 +1,86 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! Oct 2008 - S. Bony - Instructions "Call for large-scale cloud" removed -> sgx%frac_out is used instead. +! Call lidar_simulator changed (lsca, gbx%cca and depol removed; +! frac_out changed in sgx%frac_out) +! +! +MODULE MOD_COSP_LIDAR + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + IMPLICIT NONE + +CONTAINS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE COSP_LIDAR ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_LIDAR(gbx,sgx,sghydro,y) + + ! Arguments + type(cosp_gridbox),intent(in) :: gbx ! Gridbox info + type(cosp_subgrid),intent(in) :: sgx ! Subgrid info + type(cosp_sghydro),intent(in) :: sghydro ! Subgrid info for hydrometeors + type(cosp_sglidar),intent(inout) :: y ! Subgrid output + + ! Local variables + integer :: i + real :: presf(sgx%Npoints, sgx%Nlevels + 1) + real :: frac_out(sgx%Npoints, sgx%Nlevels) + real,dimension(sgx%Npoints, sgx%Nlevels) :: lsca,mr_ll,mr_li,mr_cl,mr_ci + real,dimension(sgx%Npoints, sgx%Nlevels) :: beta_tot,tau_tot + real,dimension(sgx%Npoints, PARASOL_NREFL) :: refle + + + presf(:,1:sgx%Nlevels) = gbx%ph + presf(:,sgx%Nlevels + 1) = 0.0 +! presf(:,sgx%Nlevels + 1) = gbx%p(:,sgx%Nlevels) - (presf(:,sgx%Nlevels) - gbx%p(:,sgx%Nlevels)) + lsca = gbx%tca-gbx%cca + do i=1,sgx%Ncolumns + ! Temporary arrays for simulator call + mr_ll(:,:) = sghydro%mr_hydro(:,i,:,I_LSCLIQ) + mr_li(:,:) = sghydro%mr_hydro(:,i,:,I_LSCICE) + mr_cl(:,:) = sghydro%mr_hydro(:,i,:,I_CVCLIQ) + mr_ci(:,:) = sghydro%mr_hydro(:,i,:,I_CVCICE) + call lidar_simulator(sgx%Npoints, sgx%Nlevels, 4 & + , PARASOL_NREFL, LIDAR_UNDEF & + , gbx%p, presf, gbx%T & + , mr_ll, mr_li, mr_cl, mr_ci & + , gbx%Reff(:,:,I_LSCLIQ), gbx%Reff(:,:,I_LSCICE), gbx%Reff(:,:,I_CVCLIQ), gbx%Reff(:,:,I_CVCICE) & + , sgx%frac_out, gbx%lidar_ice_type, y%beta_mol, beta_tot, tau_tot & + , refle ) ! reflectance + + y%beta_tot(:,i,:) = beta_tot(:,:) + y%tau_tot(:,i,:) = tau_tot(:,:) + y%refl(:,i,:) = refle(:,:) + enddo + +END SUBROUTINE COSP_LIDAR + +END MODULE MOD_COSP_LIDAR Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_misr_simulator.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_misr_simulator.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_misr_simulator.F90 (revision 1280) @@ -0,0 +1,80 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Nov 2008 - A. Bodas-Salcedo - Initial version +! +! + +MODULE MOD_COSP_MISR_SIMULATOR + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + IMPLICIT NONE + +CONTAINS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!-------------- SUBROUTINE COSP_MISR_SIMULATOR ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_MISR_SIMULATOR(gbx,sgx,y) + + ! Arguments + type(cosp_gridbox),intent(in) :: gbx ! Gridbox info + type(cosp_subgrid),intent(in) :: sgx ! Subgridbox info + type(cosp_misr),intent(inout) :: y ! MISR simulator output + + ! Local variables + integer :: i,Nlevels,Npoints + real :: dtau_s(gbx%Npoints, gbx%Nlevels) + real :: dtau_c(gbx%Npoints, gbx%Nlevels) + real :: at(gbx%Npoints, gbx%Nlevels) + real :: frac_out(gbx%Npoints, gbx%Ncolumns, gbx%Nlevels) + integer :: sunlit(gbx%Npoints) + + real :: zfull(gbx%Npoints, gbx%Nlevels) ! height (in meters) of full model levels (i.e. midpoints) + ! zfull(npoints,1) is top level of model + ! zfull(npoints,nlev) is bottom level of model + real :: phy_t0p1_mean_ztop ! mean cloud top height(m) of 0.1 tau treshold + real :: fq_phy_t0p1_TAU_v_CTH(7,16) + + + Nlevels = gbx%Nlevels + Npoints = gbx%Npoints + ! Levels from TOA to surface + zfull = gbx%zlev(:,Nlevels:1:-1) + at = gbx%T(:,Nlevels:1:-1) + dtau_s = gbx%dtau_s(:,Nlevels:1:-1) + dtau_c = gbx%dtau_c(:,Nlevels:1:-1) + frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1) + sunlit = int(gbx%sunlit) + + call MISR_simulator(gbx%npoints,gbx%nlevels,gbx%ncolumns,& + sunlit,zfull,at,dtau_s,dtau_c,frac_out, & + y%fq_MISR,y%MISR_dist_model_layertops,y%MISR_meanztop,y%MISR_cldarea) + +END SUBROUTINE COSP_MISR_SIMULATOR + +END MODULE MOD_COSP_MISR_SIMULATOR Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_radar.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_radar.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_radar.F90 (revision 1280) @@ -0,0 +1,212 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +MODULE MOD_COSP_RADAR + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + use radar_simulator_types + use array_lib + use atmos_lib + use format_input + IMPLICIT NONE + + INTERFACE + subroutine radar_simulator(freq,k2,do_ray,use_gas_abs,use_mie_table,mt, & + nhclass,hp,nprof,ngate,nsizes,D,hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix, & + rh_matrix,Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe, & + g_to_vol_in,g_to_vol_out) + + use m_mrgrnk + use array_lib + use math_lib + use optics_lib + use radar_simulator_types + implicit none + ! ----- INPUTS ----- + type(mie), intent(in) :: mt + type(class_param) :: hp + real*8, intent(in) :: freq,k2 + integer, intent(in) :: do_ray,use_gas_abs,use_mie_table, & + nhclass,nprof,ngate,nsizes + real*8, dimension(nsizes), intent(in) :: D + real*8, dimension(nprof,ngate), intent(in) :: hgt_matrix, p_matrix, & + t_matrix,rh_matrix + real*8, dimension(nhclass,nprof,ngate), intent(in) :: hm_matrix + real*8, dimension(nhclass,nprof,ngate), intent(inout) :: re_matrix + ! ----- OUTPUTS ----- + real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, & + g_atten_to_vol,dBZe,h_atten_to_vol + ! ----- OPTIONAL ----- + real*8, optional, dimension(ngate,nprof) :: & + g_to_vol_in,g_to_vol_out + end subroutine radar_simulator + END INTERFACE + +CONTAINS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE COSP_RADAR ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_RADAR(gbx,sgx,sghydro,z) + IMPLICIT NONE + + ! Arguments + type(cosp_gridbox),intent(in) :: gbx ! Gridbox info + type(cosp_subgrid),intent(in) :: sgx ! Subgrid info + type(cosp_sghydro),intent(in) :: sghydro ! Subgrid info for hydrometeors + type(cosp_sgradar),intent(inout) :: z ! Output from simulator, subgrid + + ! Local variables + integer :: & + nsizes ! num of discrete drop sizes + + real*8 :: & + freq, & ! radar frequency (GHz) + k2 ! |K|^2, -1=use frequency dependent default + + real*8, dimension(:,:), allocatable :: & + g_to_vol ! integrated atten due to gases, r>v (dB) + + real*8, dimension(:,:), allocatable :: & + Ze_non, & ! radar reflectivity withOUT attenuation (dBZ) + Ze_ray, & ! Rayleigh reflectivity (dBZ) + h_atten_to_vol, & ! attenuation by hydromets, radar to vol (dB) + g_atten_to_vol, & ! gaseous atteunation, radar to vol (dB) + dBZe, & ! effective radar reflectivity factor (dBZ) + hgt_matrix, & ! height of hydrometeors (km) + t_matrix, & !temperature (k) + p_matrix, & !pressure (hPa) + rh_matrix !relative humidity (%) + + real*8, dimension(:,:,:), allocatable :: & + hm_matrix, & ! hydrometeor mixing ratio (g kg^-1) + re_matrix + + integer, parameter :: one = 1 + logical :: hgt_reversed + integer :: pr,i,j,k,unt + +! ----- main program settings ------ + + freq = gbx%radar_freq + k2 = gbx%k2 + + ! + ! note: intitialization section that was here has been relocated to SUBROUTINE CONSTRUCT_COSP_GRIDBOX by roj, Feb 2008 + ! + mt_ttl=gbx%mt_ttl ! these variables really should be moved into the mt structure rather than kept as global arrays. + mt_tti=gbx%mt_tti + + ! Inputs to Quickbeam + allocate(hgt_matrix(gbx%Npoints,gbx%Nlevels),p_matrix(gbx%Npoints,gbx%Nlevels), & + t_matrix(gbx%Npoints,gbx%Nlevels),rh_matrix(gbx%Npoints,gbx%Nlevels)) + allocate(hm_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels)) + allocate(re_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels)) + + ! Outputs from Quickbeam + allocate(Ze_non(gbx%Npoints,gbx%Nlevels)) + allocate(Ze_ray(gbx%Npoints,gbx%Nlevels)) + allocate(h_atten_to_vol(gbx%Npoints,gbx%Nlevels)) + allocate(g_atten_to_vol(gbx%Npoints,gbx%Nlevels)) + allocate(dBZe(gbx%Npoints,gbx%Nlevels)) + + ! Optional argument. It is computed and returned in the first call to + ! radar_simulator, and passed as input in the rest + allocate(g_to_vol(gbx%Nlevels,gbx%Npoints)) + + p_matrix = gbx%p/100.0 ! From Pa to hPa + hgt_matrix = gbx%zlev/1000.0 ! From m to km + t_matrix = gbx%T-273.15 ! From K to C + rh_matrix = gbx%q + re_matrix = 0.0 + + ! Quickbeam assumes the first row is closest to the radar + call order_data(hgt_matrix,hm_matrix,p_matrix,t_matrix, & + rh_matrix,gbx%surface_radar,hgt_reversed) + + ! ----- loop over subcolumns ----- + do pr=1,sgx%Ncolumns + ! atmospheric profiles are the same within the same gridbox + ! only hydrometeor profiles will be different + if (hgt_reversed) then + do i=1,gbx%Nhydro + hm_matrix(i,:,:) = sghydro%mr_hydro(:,pr,gbx%Nlevels:1:-1,i)*1000.0 ! Units from kg/kg to g/kg + if (gbx%use_reff) then + re_matrix(i,:,:) = sghydro%Reff(:,pr,gbx%Nlevels:1:-1,i)*1.e6 ! Units from m to micron + endif + enddo + else + do i=1,gbx%Nhydro + hm_matrix(i,:,:) = sghydro%mr_hydro(:,pr,:,i)*1000.0 ! Units from kg/kg to g/kg + if (gbx%use_reff) then + re_matrix(i,:,:) = sghydro%Reff(:,pr,:,i)*1.e6 ! Units from m to micron + endif + enddo + endif + + ! ----- call radar simulator ----- + if (pr == 1) then ! Compute gaseous attenuation for all profiles + j=0 + if (gbx%Npoints == 53) then + unt=10 + j=1 + endif + if (gbx%Npoints == 153) then + unt=11 + j=101 + endif + call radar_simulator(freq,k2,gbx%do_ray,gbx%use_gas_abs,gbx%use_mie_tables,gbx%mt, & ! v0.2: mt changed to gbx%mt, roj + gbx%Nhydro,gbx%hp,gbx%Npoints,gbx%Nlevels,gbx%nsizes,gbx%D, & ! v0.2: hp->gbx%hp, D->gbx%d, nsizes->gbx%nsizes, roj + hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix,rh_matrix, & + Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_out=g_to_vol) + else ! Use gaseous atteunuation for pr = 1 + call radar_simulator(freq,k2,gbx%do_ray,gbx%use_gas_abs,gbx%use_mie_tables,gbx%mt, & + gbx%Nhydro,gbx%hp,gbx%Npoints,gbx%Nlevels,gbx%nsizes,gbx%D, & + hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix,rh_matrix, & + Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_in=g_to_vol) + endif + ! ----- BEGIN output section ----- + ! spaceborne radar : from TOA to SURFACE + if (gbx%surface_radar == 1) then + z%Ze_tot(:,pr,:)=dBZe(:,:) + else if (gbx%surface_radar == 0) then ! Spaceborne + z%Ze_tot(:,pr,:)=dBZe(:,gbx%Nlevels:1:-1) + endif + + enddo !pr + + ! Change undefined value to one defined in COSP + where (z%Ze_tot == -999.0) z%Ze_tot = R_UNDEF + + deallocate(hgt_matrix,p_matrix,t_matrix,rh_matrix) + deallocate(hm_matrix,re_matrix, & + Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe) + deallocate(g_to_vol) + + ! deallocate(mt_ttl,mt_tti) !v0.2: roj feb 2008 can not be done here, + !these variables now part of gbx structure and dealocated later + +END SUBROUTINE COSP_RADAR + +END MODULE MOD_COSP_RADAR Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_simulator.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_simulator.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_simulator.F90 (revision 1280) @@ -0,0 +1,127 @@ +! (c) British Crown Copyright 2008, the Met Office. + +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! +! + +MODULE MOD_COSP_SIMULATOR + USE MOD_COSP_TYPES + USE MOD_COSP_RADAR + USE MOD_COSP_LIDAR + USE MOD_COSP_ISCCP_SIMULATOR + USE MOD_COSP_MISR_SIMULATOR + USE MOD_COSP_STATS + IMPLICIT NONE + +CONTAINS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE COSP_SIMULATOR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_SIMULATOR(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,stradar,stlidar) + + ! Arguments + type(cosp_gridbox),intent(in) :: gbx ! Grid-box inputs + type(cosp_subgrid),intent(in) :: sgx ! Subgrid inputs + type(cosp_sghydro),intent(in) :: sghydro ! Subgrid info for hydrometeors + type(cosp_config),intent(in) :: cfg ! Configuration options + type(cosp_vgrid),intent(in) :: vgrid ! Information on vertical grid of stats + type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator + type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator + type(cosp_isccp),intent(inout) :: isccp ! Output from ISCCP simulator + type(cosp_misr),intent(inout) :: misr ! Output from MISR simulator + type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator + type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator + ! Local variables + ! ***Timing variables (to be deleted in final version) + integer :: t0,t1,count_rate,count_max + + !+++++++++ Radar model ++++++++++ + if (cfg%Lradar_sim) then + call system_clock(t0,count_rate,count_max) + call cosp_radar(gbx,sgx,sghydro,sgradar) + call system_clock(t1,count_rate,count_max) + print *, '%%%%%% Radar:', (t1-t0)*1.0/count_rate, ' s' + else + print *, '%%%%%% Radar not used' + endif + + !+++++++++ Lidar model ++++++++++ + if (cfg%Llidar_sim) then + call system_clock(t0,count_rate,count_max) + call cosp_lidar(gbx,sgx,sghydro,sglidar) + call system_clock(t1,count_rate,count_max) + print *, '%%%%%% Lidar:', (t1-t0)*1.0/count_rate, ' s' + else + print *, '%%%%%% Lidar not used' + endif + + + !+++++++++ ISCCP simulator ++++++++++ + if (cfg%Lisccp_sim) then + call system_clock(t0,count_rate,count_max) + call cosp_isccp_simulator(gbx,sgx,isccp) + call system_clock(t1,count_rate,count_max) + print *, '%%%%%% ISCCP:', (t1-t0)*1.0/count_rate, ' s' + else + print *, '%%%%%% ISCCP not used' + endif + + !+++++++++ MISR simulator ++++++++++ + if (cfg%Lmisr_sim) then + call system_clock(t0,count_rate,count_max) + call cosp_misr_simulator(gbx,sgx,misr) + call system_clock(t1,count_rate,count_max) + print *, '%%%%%% MISR:', (t1-t0)*1.0/count_rate, ' s' + else + print *, '%%%%%% MISR not used' + endif + + + !+++++++++++ Summary statistics +++++++++++ +! write(*,*) 'Stats:' +! read(*,*) c + if (cfg%Lstats) then + call system_clock(t0,count_rate,count_max) + call cosp_stats(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar) + call system_clock(t1,count_rate,count_max) + print *, '%%%%%% Stats:', (t1-t0)*1.0/count_rate, ' s' + endif + !+++++++++++ change of units after computation of statistics +++++++++++ + if (cfg%Llidar_sim) then + where((sglidar%beta_tot > 0.0) .and. (sglidar%beta_tot /= R_UNDEF)) + sglidar%beta_tot = log10(sglidar%beta_tot) + elsewhere + sglidar%beta_tot = R_UNDEF + end where + endif + +END SUBROUTINE COSP_SIMULATOR + +END MODULE MOD_COSP_SIMULATOR Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_stats.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_stats.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_stats.F90 (revision 1280) @@ -0,0 +1,236 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! Jul 2008 - A. Bodas-Salcedo - Added capability of producing outputs in standard grid +! Oct 2008 - J.-L. Dufresne - Bug fixed. Assignment of Npoints,Nlevels,Nhydro,Ncolumns in COSP_STATS +! Oct 2008 - H. Chepfer - Added PARASOL reflectance arguments +! +! +MODULE MOD_COSP_STATS + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + USE MOD_LLNL_STATS + USE MOD_LMD_IPSL_STATS + IMPLICIT NONE + +CONTAINS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE COSP_STATS ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_STATS(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar) + + ! Input arguments + type(cosp_gridbox),intent(in) :: gbx + type(cosp_subgrid),intent(in) :: sgx + type(cosp_config),intent(in) :: cfg + type(cosp_sgradar),intent(in) :: sgradar + type(cosp_sglidar),intent(in) :: sglidar + type(cosp_vgrid),intent(in) :: vgrid + ! Output arguments + type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics for radar + type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics for lidar + + ! Local variables + integer :: Npoints !# of grid points + integer :: Nlevels !# of levels + integer :: Nhydro !# of hydrometeors + integer :: Ncolumns !# of columns + integer :: Nlr + logical :: ok_lidar_cfad = .false. + real,dimension(:,:,:),allocatable :: Ze_out,betatot_out,betamol_in,betamol_out,ph_in,ph_out + real,dimension(:,:),allocatable :: ph_c,betamol_c + + Npoints = gbx%Npoints + Nlevels = gbx%Nlevels + Nhydro = gbx%Nhydro + Ncolumns = gbx%Ncolumns + Nlr = vgrid%Nlvgrid + + if (cfg%Lcfad_lidarsr532) ok_lidar_cfad=.true. + + if (vgrid%use_vgrid) then ! Statistics in a different vertical grid + allocate(Ze_out(Npoints,Ncolumns,Nlr),betatot_out(Npoints,Ncolumns,Nlr), & + betamol_in(Npoints,1,Nlevels),betamol_out(Npoints,1,Nlr),betamol_c(Npoints,Nlr), & + ph_in(Npoints,1,Nlevels),ph_out(Npoints,1,Nlr),ph_c(Npoints,Nlr)) + Ze_out = 0.0 + betatot_out = 0.0 + betamol_in(:,1,:) = sglidar%beta_mol(:,:) + betamol_out= 0.0 + betamol_c = 0.0 + ph_in(:,1,:) = gbx%ph(:,:) + ph_out = 0.0 + ph_c = 0.0 + !++++++++++++ Radar CFAD ++++++++++++++++ + if (cfg%Lradar_sim) then + call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sgradar%Ze_tot, & + Nlr,vgrid%zl,vgrid%zu,Ze_out,log_units=.true.) + stradar%cfad_ze = cosp_cfad(Npoints,Ncolumns,Nlr,DBZE_BINS,Ze_out, & + DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH) + endif + !++++++++++++ Lidar CFAD ++++++++++++++++ + if (cfg%Llidar_sim) then + call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,betamol_in, & + Nlr,vgrid%zl,vgrid%zu,betamol_out) + call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sglidar%beta_tot, & + Nlr,vgrid%zl,vgrid%zu,betatot_out) + call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,ph_in, & + Nlr,vgrid%zl,vgrid%zu,ph_out) + ph_c(:,:) = ph_out(:,1,:) + betamol_c(:,:) = betamol_out(:,1,:) + ! Stats from lidar_stat_summary + call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL & + ,betatot_out,betamol_c,sglidar%refl,gbx%land,ph_c & + ,LIDAR_UNDEF,ok_lidar_cfad & + ,stlidar%cfad_sr,stlidar%srbval & + ,LIDAR_NCAT,stlidar%lidarcld,stlidar%cldlayer,stlidar%parasolrefl) + endif + !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++ + if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, & + betatot_out,betamol_c,Ze_out, & + stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc) + ! Deallocate arrays at coarse resolution + deallocate(Ze_out,betatot_out,betamol_in,betamol_out,betamol_c,ph_in,ph_out,ph_c) + else ! Statistics in model levels + !++++++++++++ Radar CFAD ++++++++++++++++ + if (cfg%Lradar_sim) stradar%cfad_ze = cosp_cfad(Npoints,Ncolumns,Nlr,DBZE_BINS,sgradar%Ze_tot, & + DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH) + !++++++++++++ Lidar CFAD ++++++++++++++++ + ! Stats from lidar_stat_summary + if (cfg%Llidar_sim) call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL & + ,sglidar%beta_tot,sglidar%beta_mol,sglidar%refl,gbx%land,gbx%ph & + ,LIDAR_UNDEF,ok_lidar_cfad & + ,stlidar%cfad_sr,stlidar%srbval & + ,LIDAR_NCAT,stlidar%lidarcld,stlidar%cldlayer,stlidar%parasolrefl) + !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++ + if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, & + sglidar%beta_tot,sglidar%beta_mol,sgradar%Ze_tot, & + stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc) + endif + ! Replace undef + where (stlidar%cfad_sr == LIDAR_UNDEF) stlidar%cfad_sr = R_UNDEF + where (stlidar%lidarcld == LIDAR_UNDEF) stlidar%lidarcld = R_UNDEF + where (stlidar%cldlayer == LIDAR_UNDEF) stlidar%cldlayer = R_UNDEF + where (stlidar%parasolrefl == LIDAR_UNDEF) stlidar%parasolrefl = R_UNDEF + +END SUBROUTINE COSP_STATS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!---------- SUBROUTINE COSP_CHANGE_VERTICAL_GRID ---------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_CHANGE_VERTICAL_GRID(Npoints,Ncolumns,Nlevels,zfull,zhalf,y,M,zl,zu,r,log_units) + implicit none + ! Input arguments + integer,intent(in) :: Npoints !# of grid points + integer,intent(in) :: Nlevels !# of levels + integer,intent(in) :: Ncolumns !# of columns + real,dimension(Npoints,Nlevels),intent(in) :: zfull ! Height at model levels [m] (Bottom of model layer) + real,dimension(Npoints,Nlevels),intent(in) :: zhalf ! Height at half model levels [m] (Bottom of model layer) + real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: y ! Variable to be changed to a different grid + integer,intent(in) :: M !# levels in the new grid + real,dimension(M),intent(in) :: zl ! Lower boundary of new levels [m] + real,dimension(M),intent(in) :: zu ! Upper boundary of new levels [m] + logical,optional,intent(in) :: log_units ! log units, need to convert to linear units + ! Output + real,dimension(Npoints,Ncolumns,M),intent(out) :: r ! Variable on new grid + + ! Local variables + integer :: i,j,k + logical :: lunits + real :: ws + real,dimension(Nlevels) :: xl,xu ! Lower and upper boundaries of model grid + real,dimension(M) :: dz ! Layer depth + real,dimension(Nlevels,M) :: w ! Weights to do the mean at each point + real,dimension(Ncolumns,Nlevels) :: yp ! Variable to be changed to a different grid. + ! Local copy at a particular point. + ! This allows for change of units. + + lunits=.false. + if (present(log_units)) lunits=log_units + + r = 0.0 + do i=1,Npoints + ! Vertical grid at that point + xl = zhalf(i,:) + xu(1:Nlevels-1) = xl(2:Nlevels) + xu(Nlevels) = zfull(i,Nlevels) + zfull(i,Nlevels) - zhalf(i,Nlevels) ! Top level symmetric + dz = zu - zl + yp = y(i,:,:) ! Temporary variable to regrid + ! Find weights + w = 0.0 + do k=1,M + do j=1,Nlevels + if ((xl(j) < zl(k)).and.(xu(j) > zl(k)).and.(xu(j) <= zu(k))) then + !xl(j)-----------------xu(j) + ! zl(k)------------------------------zu(k) + w(j,k) = xu(j) - zl(k) + else if ((xl(j) >= zl(k)).and.(xu(j) <= zu(k))) then + ! xl(j)-----------------xu(j) + ! zl(k)------------------------------zu(k) + w(j,k) = xu(j) - xl(j) + else if ((xl(j) >= zl(k)).and.(xl(j) < zu(k)).and.(xu(j) >= zu(k))) then + ! xl(j)-----------------xu(j) + ! zl(k)------------------------------zu(k) + w(j,k) = zu(k) - xl(j) + else if ((xl(j) <= zl(k)).and.(xu(j) >= zu(k))) then + ! xl(j)---------------------------xu(j) + ! zl(k)--------------zu(k) + w(j,k) = dz(j) + endif + enddo + enddo + ! Check for dBZ and change if necessary + if (lunits) then + where (yp /= R_UNDEF) + yp = 10.0**(yp/10.0) + elsewhere + yp = 0.0 + end where + endif + ! Do the weighted mean + do j=1,Ncolumns + do k=1,M + ws = sum(w(:,k)) + if (ws > 0.0) r(i,j,k) = sum(w(:,k)*yp(j,:))/ws + enddo + enddo + ! Check for dBZ and change if necessary + if (lunits) then + where (r(i,:,:) <= 0.0) + r(i,:,:) = R_UNDEF + elsewhere + r(i,:,:) = 10.0*log10(r(i,:,:)) + end where + endif + enddo + + + +END SUBROUTINE COSP_CHANGE_VERTICAL_GRID + +END MODULE MOD_COSP_STATS Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_types.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_types.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_types.F90 (revision 1280) @@ -0,0 +1,1379 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! Feb 2008 - R. Marchand - Added Quickbeam types and initialisation +! Oct 2008 - H. Chepfer - Added PARASOL reflectance diagnostic +! Nov 2008 - R. Marchand - Added MISR diagnostics +! Nov 2008 - V. John - Added RTTOV diagnostics +! +! +MODULE MOD_COSP_TYPES + USE MOD_COSP_CONSTANTS + USE MOD_COSP_UTILS + + use radar_simulator_types, only: class_param, mie, nd, mt_nd, dmax, dmin, mt_ttl, mt_tti, cnt_liq, cnt_ice ! added by roj Feb 2008 + + IMPLICIT NONE + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------------------- DERIVED TYPES ---------------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! Configuration choices (simulators, variables) + TYPE COSP_CONFIG + logical :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim,Lstats,Lwrite_output, & + Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, & + Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2,Lcllcalipso, & + Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp,Ltclisccp, & + Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, & + Lfrac_out,Lbeta_mol532,Ltbrttov + character(len=32) :: out_list(N_OUT_LIST) + END TYPE COSP_CONFIG + + ! Outputs from RTTOV + TYPE COSP_RTTOV + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Nchan ! Number of channels + + ! Brightness temperatures (Npoints,Nchan) + real,pointer :: tbs(:,:) + + END TYPE COSP_RTTOV + + ! Outputs from MISR simulator + TYPE COSP_MISR + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ntau ! Number of tau intervals + integer :: Nlevels ! Number of cth levels + + ! --- (npoints,ntau,nlevels) + ! the fraction of the model grid box covered by each of the MISR cloud types + real,pointer :: fq_MISR(:,:,:) + + ! --- (npoints) + real,pointer :: MISR_meanztop(:), MISR_cldarea(:) + ! --- (npoints,nlevels) + real,pointer :: MISR_dist_model_layertops(:,:) + END TYPE COSP_MISR + + ! Outputs from ISCCP simulator + TYPE COSP_ISCCP + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of columns + integer :: Nlevels ! Number of levels + + + ! --- (npoints,tau=7,pressure=7) + ! the fraction of the model grid box covered by each of the 49 ISCCP D level cloud types + real,pointer :: fq_isccp(:,:,:) + + ! --- (npoints) --- + ! The fraction of model grid box columns with cloud somewhere in them. + ! This should equal the sum over all entries of fq_isccp + real,pointer :: totalcldarea(:) + ! mean all-sky 10.5 micron brightness temperature + real,pointer :: meantb(:) + ! mean clear-sky 10.5 micron brightness temperature + real,pointer :: meantbclr(:) + + ! The following three means are averages over the cloudy areas only. If no + ! clouds are in grid box all three quantities should equal zero. + + ! mean cloud top pressure (mb) - linear averaging in cloud top pressure. + real,pointer :: meanptop(:) + ! mean optical thickness linear averaging in albedo performed. + real,pointer :: meantaucld(:) + ! mean cloud albedo. linear averaging in albedo performed + real,pointer :: meanalbedocld(:) + + !--- (npoints,ncol) --- + ! optical thickness in each column + real,pointer :: boxtau(:,:) + ! cloud top pressure (mb) in each column + real,pointer :: boxptop(:,:) + END TYPE COSP_ISCCP + + ! Summary statistics from radar + TYPE COSP_VGRID + logical :: use_vgrid ! Logical flag that indicates change of grid + logical :: csat_vgrid ! Flag for Cloudsat grid + integer :: Npoints ! Number of sampled points + integer :: Ncolumns ! Number of subgrid columns + integer :: Nlevels ! Number of model levels + integer :: Nlvgrid ! Number of levels of new grid + ! Array with dimensions (Nlvgrid) + real, dimension(:), pointer :: z,zl,zu ! Height and lower and upper boundaries of new levels + ! Array with dimensions (Nlevels) + real, dimension(:), pointer :: mz,mzl,mzu ! Height and lower and upper boundaries of model levels + END TYPE COSP_VGRID + + ! Output data from lidar code + TYPE COSP_SGLIDAR + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of columns + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + integer :: Nrefl ! Number of parasol reflectances + ! Arrays with dimensions (Npoints,Nlevels) + real,dimension(:,:),pointer :: beta_mol ! Molecular backscatter + ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) + real,dimension(:,:,:),pointer :: beta_tot ! Total backscattered signal + real,dimension(:,:,:),pointer :: tau_tot ! Optical thickness integrated from top to level z + ! Arrays with dimensions (Npoints,Ncolumns,Nrefl) + real,dimension(:,:,:),pointer :: refl ! parasol reflectances + END TYPE COSP_SGLIDAR + + ! Output data from radar code + TYPE COSP_SGRADAR + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of columns + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + ! output vertical levels: spaceborne radar -> from TOA to SURFACE + ! Arrays with dimensions (Npoints,Nlevels) + real,dimension(:,:),pointer :: att_gas ! 2-way attenuation by gases [dBZ] + ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) + real,dimension(:,:,:),pointer :: Ze_tot ! Effective reflectivity factor [dBZ] + + END TYPE COSP_SGRADAR + + + ! Summary statistics from radar + TYPE COSP_RADARSTATS + integer :: Npoints ! Number of sampled points + integer :: Ncolumns ! Number of subgrid columns + integer :: Nlevels ! Number of model levels + integer :: Nhydro ! Number of hydrometeors + ! Array with dimensions (Npoints,dBZe_bins,Nlevels) + real, dimension(:,:,:), pointer :: cfad_ze ! Ze CFAD + ! Array with dimensions (Npoints) + real,dimension(:),pointer :: radar_lidar_tcc ! Radar&lidar total cloud amount, grid-box scale + ! Arrays with dimensions (Npoints,Nlevels) + real, dimension(:,:),pointer :: lidar_only_freq_cloud + END TYPE COSP_RADARSTATS + + ! Summary statistics from lidar + TYPE COSP_LIDARSTATS + integer :: Npoints ! Number of sampled points + integer :: Ncolumns ! Number of subgrid columns + integer :: Nlevels ! Number of model levels + integer :: Nhydro ! Number of hydrometeors + integer :: Nrefl ! Number of parasol reflectances + + ! Arrays with dimensions (SR_BINS) + real, dimension(:),pointer :: srbval ! SR bins in cfad_sr + ! Arrays with dimensions (Npoints,SR_BINS,Nlevels) + real, dimension(:,:,:),pointer :: cfad_sr ! CFAD of scattering ratio + ! Arrays with dimensions (Npoints,Nlevels) + real, dimension(:,:),pointer :: lidarcld ! 3D "lidar" cloud fraction + ! Arrays with dimensions (Npoints,LIDAR_NCAT) + real, dimension(:,:),pointer :: cldlayer ! low, mid, high-level lidar cloud cover + ! Arrays with dimensions (Npoints,PARASOL_NREFL) + real, dimension(:,:),pointer :: parasolrefl ! mean parasol reflectance + + END TYPE COSP_LIDARSTATS + + + ! Input data for simulator. Subgrid scale. + ! Input data from SURFACE to TOA + TYPE COSP_SUBGRID + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of columns + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + + real,dimension(:,:,:),pointer :: prec_frac ! Subgrid precip array. Dimensions (Npoints,Ncolumns,Nlevels) + real,dimension(:,:,:),pointer :: frac_out ! Subgrid cloud array. Dimensions (Npoints,Ncolumns,Nlevels) + END TYPE COSP_SUBGRID + + ! Input data for simulator at Subgrid scale. + ! Used on a reduced number of points + TYPE COSP_SGHYDRO + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of columns + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + real,dimension(:,:,:,:),pointer :: mr_hydro ! Mixing ratio of each hydrometeor + ! (Npoints,Ncolumns,Nlevels,Nhydro) [kg/kg] + real,dimension(:,:,:,:),pointer :: Reff ! Effective Radius of each hydrometeor + ! (Reff==0 means use default size) + ! (Npoints,Ncolumns,Nlevels,Nhydro) [m] + END TYPE COSP_SGHYDRO + + ! Input data for simulator. Gridbox scale. + TYPE COSP_GRIDBOX + ! Scalars and dimensions + integer :: Npoints ! Number of gridpoints + integer :: Nlevels ! Number of levels + integer :: Ncolumns ! Number of columns + integer :: Nhydro ! Number of hydrometeors + integer :: Nprmts_max_hydro ! Max number of parameters for hydrometeor size distributions + integer :: Naero ! Number of aerosol species + integer :: Nprmts_max_aero ! Max number of parameters for aerosol size distributions + integer :: Npoints_it ! Max number of gridpoints to be processed in one iteration + + ! Time [days] + double precision :: time + + ! Radar ancillary info + real :: radar_freq, & ! Radar frequency [GHz] + k2 ! |K|^2, -1=use frequency dependent default + integer :: surface_radar, & ! surface=1, spaceborne=0 + use_mie_tables, & ! use a precomputed loopup table? yes=1,no=0 + use_gas_abs, & ! include gaseous absorption? yes=1,no=0 + do_ray, & ! calculate/output Rayleigh refl=1, not=0 + melt_lay ! melting layer model off=0, on=1 + + ! structures used by radar simulator that need to be set only ONCE per radar configuration (e.g. freq, pointing direction) ... added by roj Feb 2008 + type(class_param) :: hp ! structure used by radar simulator to store Ze and N scaling constants and other information + type(mie):: mt ! structure used by radar simulator to store mie LUT information + integer :: nsizes ! number of discrete drop sizes (um) used to represent the distribution + real*8, dimension(:), pointer :: D ! array of discrete drop sizes (um) used to represent the distribution + real*8, dimension(:), pointer :: mt_ttl, mt_tti ! array of temperatures used with Ze_scaling (also build into mie LUT) + + ! Lidar + integer :: lidar_ice_type !ice particle shape hypothesis in lidar calculations + !(ice_type=0 for spheres, ice_type=1 for non spherical particles) + + ! Radar + logical :: use_precipitation_fluxes ! True if precipitation fluxes are input to the algorithm + logical :: use_reff ! True if Reff is to be used by radar + + ! Geolocation (Npoints) + real,dimension(:),pointer :: longitude ! longitude [degrees East] + real,dimension(:),pointer :: latitude ! latitude [deg North] + ! Gridbox information (Npoints,Nlevels) + real,dimension(:,:),pointer :: zlev ! Height of model levels [m] + real,dimension(:,:),pointer :: zlev_half ! Height at half model levels [m] (Bottom of model layer) + real,dimension(:,:),pointer :: dlev ! Depth of model levels [m] + real,dimension(:,:),pointer :: p ! Pressure at full model levels [Pa] + real,dimension(:,:),pointer :: ph ! Pressure at half model levels [Pa] + real,dimension(:,:),pointer :: T ! Temperature at model levels [K] + real,dimension(:,:),pointer :: q ! Relative humidity to water (%) + real,dimension(:,:),pointer :: sh ! Specific humidity to water [kg/kg] + real,dimension(:,:),pointer :: dtau_s ! mean 0.67 micron optical depth of stratiform + ! clouds in each model level + ! NOTE: this the cloud optical depth of only the + ! cloudy part of the grid box, it is not weighted + ! with the 0 cloud optical depth of the clear + ! part of the grid box + real,dimension(:,:),pointer :: dtau_c ! mean 0.67 micron optical depth of convective + ! clouds in each model level. Same note applies as in dtau_s. + real,dimension(:,:),pointer :: dem_s ! 10.5 micron longwave emissivity of stratiform + ! clouds in each model level. Same note applies as in dtau_s. + real,dimension(:,:),pointer :: dem_c ! 10.5 micron longwave emissivity of convective + ! clouds in each model level. Same note applies as in dtau_s. + real,dimension(:,:),pointer :: mr_ozone ! Ozone mass mixing ratio [kg/kg] + + ! Point information (Npoints) + real,dimension(:),pointer :: land !Landmask [0 - Ocean, 1 - Land] + real,dimension(:),pointer :: psfc !Surface pressure [Pa] + real,dimension(:),pointer :: sunlit ! (npoints) 1 for day points, 0 for nightime + real,dimension(:),pointer :: skt ! Skin temperature (K) + real,dimension(:),pointer :: sfc_height ! Surface height [m] + real,dimension(:),pointer :: u_wind ! eastward wind [m s-1] + real,dimension(:),pointer :: v_wind ! northward wind [m s-1] + + ! TOTAL and CONV cloud fraction for SCOPS + real,dimension(:,:),pointer :: tca ! Total cloud fraction + real,dimension(:,:),pointer :: cca ! Convective cloud fraction + ! Precipitation fluxes on model levels + real,dimension(:,:),pointer :: rain_ls ! large-scale precipitation flux of rain [kg/m2.s] + real,dimension(:,:),pointer :: rain_cv ! convective precipitation flux of rain [kg/m2.s] + real,dimension(:,:),pointer :: snow_ls ! large-scale precipitation flux of snow [kg/m2.s] + real,dimension(:,:),pointer :: snow_cv ! convective precipitation flux of snow [kg/m2.s] + real,dimension(:,:),pointer :: grpl_ls ! large-scale precipitation flux of graupel [kg/m2.s] + ! Hydrometeors concentration and distribution parameters +! real,dimension(:,:,:),pointer :: fr_hydro ! Fraction of the gridbox occupied by each hydrometeor (Npoints,Nlevels,Nhydro) + real,dimension(:,:,:),pointer :: mr_hydro ! Mixing ratio of each hydrometeor (Npoints,Nlevels,Nhydro) [kg/kg] + real,dimension(:,:),pointer :: dist_prmts_hydro !Distributional parameters for hydrometeors (Nprmts_max_hydro,Nhydro) + ! Effective radius [m]. (Npoints,Nlevels,Nhydro) + real,dimension(:,:,:),pointer :: Reff + ! Aerosols concentration and distribution parameters + real,dimension(:,:,:),pointer :: conc_aero ! Aerosol concentration for each species (Npoints,Nlevels,Naero) + integer,dimension(:),pointer :: dist_type_aero ! Particle size distribution type for each aerosol species (Naero) + real,dimension(:,:,:,:),pointer :: dist_prmts_aero ! Distributional parameters for aerosols + ! (Npoints,Nlevels,Nprmts_max_aero,Naero) + ! ISCCP simulator inputs + integer :: isccp_top_height ! 1 = adjust top height using both a computed + ! infrared brightness temperature and the visible + ! optical depth to adjust cloud top pressure. Note + ! that this calculation is most appropriate to compare + ! to ISCCP data during sunlit hours. + ! 2 = do not adjust top height, that is cloud top + ! pressure is the actual cloud top pressure + ! in the model + ! 3 = adjust top height using only the computed + ! infrared brightness temperature. Note that this + ! calculation is most appropriate to compare to ISCCP + ! IR only algortihm (i.e. you can compare to nighttime + ! ISCCP data with this option) + integer :: isccp_top_height_direction ! direction for finding atmosphere pressure level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! 1 = find the *lowest* altitude (highest pressure) level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! 2 = find the *highest* altitude (lowest pressure) level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! ONLY APPLICABLE IF top_height EQUALS 1 or 3 + ! 1 = default setting, and matches all versions of + ! ISCCP simulator with versions numbers 3.5.1 and lower + ! 2 = experimental setting + integer :: isccp_overlap ! overlap type (1=max, 2=rand, 3=max/rand) + real :: isccp_emsfc_lw ! 10.5 micron emissivity of surface (fraction) + + ! RTTOV inputs/options + integer :: plat ! satellite platform + integer :: sat ! satellite + integer :: inst ! instrument + integer :: Nchan ! Number of channels to be computed + integer, dimension(:), pointer :: Ichan ! Channel numbers + real, dimension(:), pointer :: Surfem ! Surface emissivity + real :: ZenAng ! Satellite Zenith Angles + real :: co2,ch4,n2o,co ! Mixing ratios of trace gases + + END TYPE COSP_GRIDBOX + +CONTAINS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_RTTOV ------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_RTTOV(Npoints,Nchan,x) + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Nchan ! Number of channels + type(cosp_rttov),intent(out) :: x + + ! Dimensions + x%Npoints = Npoints + x%Nchan = Nchan + + ! --- Allocate arrays --- + allocate(x%tbs(Npoints, Nchan)) + ! --- Initialise to zero --- + x%tbs = 0.0 + END SUBROUTINE CONSTRUCT_COSP_RTTOV + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_RTTOV ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_RTTOV(x) + type(cosp_rttov),intent(inout) :: x + + ! --- Deallocate arrays --- + deallocate(x%tbs) + END SUBROUTINE FREE_COSP_RTTOV + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_MISR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_MISR(cfg,Npoints,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of gridpoints + type(cosp_misr),intent(out) :: x + ! Local variables + integer :: i,j,k + + + ! Allocate minumum storage if simulator not used + if (cfg%Lmisr_sim) then + i = Npoints + j = 7 + k = MISR_N_CTH + else + i = 1 + j = 1 + k = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ntau = j + x%Nlevels = k + + ! allocate space for MISR simulator outputs ... + allocate(x%fq_MISR(i,j,k), x%MISR_meanztop(i),x%MISR_cldarea(i), x%MISR_dist_model_layertops(i,k)) + x%fq_MISR = 0.0 + x%MISR_meanztop = 0.0 + x%MISR_cldarea = 0.0 + x%MISR_dist_model_layertops = 0.0 + + END SUBROUTINE CONSTRUCT_COSP_MISR +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_MISR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_MISR(x) + type(cosp_misr),intent(inout) :: x + deallocate(x%fq_MISR, x%MISR_meanztop,x%MISR_cldarea, x%MISR_dist_model_layertops) + + END SUBROUTINE FREE_COSP_MISR + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_ISCCP ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_ISCCP(cfg,Npoints,Ncolumns,Nlevels,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Ncolumns ! Number of subgrid columns + integer,intent(in) :: Nlevels ! Number of model levels + type(cosp_isccp),intent(out) :: x + ! Local variables + integer :: i,j,k + + ! Allocate minumum storage if simulator not used + if (cfg%Lisccp_sim) then + i = Npoints + j = Ncolumns + k = Nlevels + else + i = 1 + j = 1 + k = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ncolumns = j + x%Nlevels = k + + ! --- Allocate arrays --- + allocate(x%fq_isccp(i,7,7), x%totalcldarea(i), & + x%meanptop(i), x%meantaucld(i), & + x%meantb(i), x%meantbclr(i), & + x%boxtau(i,j), x%boxptop(i,j), & + x%meanalbedocld(i)) + ! --- Initialise to zero --- + x%fq_isccp = 0.0 + x%totalcldarea = 0.0 + x%meanptop = 0.0 + x%meantaucld = 0.0 + x%meantb = 0.0 + x%meantbclr = 0.0 + x%boxtau = 0.0 + x%boxptop = 0.0 + x%meanalbedocld= 0.0 + END SUBROUTINE CONSTRUCT_COSP_ISCCP + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_ISCCP ----------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_ISCCP(x) + type(cosp_isccp),intent(inout) :: x + + deallocate(x%fq_isccp, x%totalcldarea, & + x%meanptop, x%meantaucld, x%meantb, x%meantbclr, & + x%boxtau, x%boxptop, x%meanalbedocld) + END SUBROUTINE FREE_COSP_ISCCP + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_VGRID ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_VGRID(gbx,Nlvgrid,use_vgrid,cloudsat,x) + type(cosp_gridbox),intent(in) :: gbx ! Gridbox information + integer,intent(in) :: Nlvgrid ! Number of new levels + logical,intent(in) :: use_vgrid! Logical flag that controls the output on a different grid + logical,intent(in) :: cloudsat ! TRUE if a CloudSat like grid (480m) is requested + type(cosp_vgrid),intent(out) :: x + + ! Local variables + integer :: i + real :: zstep + + x%use_vgrid = use_vgrid + x%csat_vgrid = cloudsat + + ! Dimensions + x%Npoints = gbx%Npoints + x%Ncolumns = gbx%Ncolumns + x%Nlevels = gbx%Nlevels + + ! --- Allocate arrays --- + if (use_vgrid) then + x%Nlvgrid = Nlvgrid + else + x%Nlvgrid = gbx%Nlevels + endif + allocate(x%z(x%Nlvgrid),x%zl(x%Nlvgrid),x%zu(x%Nlvgrid)) + allocate(x%mz(x%Nlevels),x%mzl(x%Nlevels),x%mzu(x%Nlevels)) + + ! --- Model vertical levels --- + ! Use height levels of first model gridbox + x%mz = gbx%zlev(1,:) + x%mzl = gbx%zlev_half(1,:) + x%mzu(1:x%Nlevels-1) = gbx%zlev_half(1,2:x%Nlevels) + x%mzu(x%Nlevels) = gbx%zlev(1,x%Nlevels) + (gbx%zlev(1,x%Nlevels) - x%mzl(x%Nlevels)) + + if (use_vgrid) then + ! --- Initialise to zero --- + x%z = 0.0 + x%zl = 0.0 + x%zu = 0.0 + if (cloudsat) then ! --- CloudSat grid requested --- + zstep = 480.0 + else + ! Other grid requested. Constant vertical spacing with top at 20 km + zstep = 20000.0/x%Nlvgrid + endif + do i=1,x%Nlvgrid + x%zl(i) = (i-1)*zstep + x%zu(i) = i*zstep + enddo + x%z = (x%zl + x%zu)/2.0 + else + x%z = x%mz + x%zl = x%mzl + x%zu = x%mzu + endif + + END SUBROUTINE CONSTRUCT_COSP_VGRID + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------ SUBROUTINE FREE_COSP_VGRID ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_VGRID(x) + type(cosp_vgrid),intent(inout) :: x + + deallocate(x%z, x%zl, x%zu, x%mz, x%mzl, x%mzu) + END SUBROUTINE FREE_COSP_VGRID + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_SGLIDAR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_SGLIDAR(cfg,Npoints,Ncolumns,Nlevels,Nhydro,Nrefl,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Ncolumns ! Number of subgrid columns + integer,intent(in) :: Nlevels ! Number of model levels + integer,intent(in) :: Nhydro ! Number of hydrometeors + integer,intent(in) :: Nrefl ! Number of parasol reflectances ! parasol + type(cosp_sglidar),intent(out) :: x + ! Local variables + integer :: i,j,k,l,m + + ! Allocate minumum storage if simulator not used + if (cfg%Llidar_sim) then + i = Npoints + j = Ncolumns + k = Nlevels + l = Nhydro + m = Nrefl + else + i = 1 + j = 1 + k = 1 + l = 1 + m = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ncolumns = j + x%Nlevels = k + x%Nhydro = l + x%Nrefl = m + + ! --- Allocate arrays --- + allocate(x%beta_mol(i,k), x%beta_tot(i,j,k), & + x%tau_tot(i,j,k),x%refl(i,j,m)) + ! --- Initialise to zero --- + x%beta_mol = 0.0 + x%beta_tot = 0.0 + x%tau_tot = 0.0 + x%refl = 0.0 ! parasol + END SUBROUTINE CONSTRUCT_COSP_SGLIDAR + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------ SUBROUTINE FREE_COSP_SGLIDAR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_SGLIDAR(x) + type(cosp_sglidar),intent(inout) :: x + + deallocate(x%beta_mol, x%beta_tot, x%tau_tot, x%refl) + END SUBROUTINE FREE_COSP_SGLIDAR + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_SGRADAR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_SGRADAR(cfg,Npoints,Ncolumns,Nlevels,Nhydro,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Ncolumns ! Number of subgrid columns + integer,intent(in) :: Nlevels ! Number of model levels + integer,intent(in) :: Nhydro ! Number of hydrometeors + type(cosp_sgradar),intent(out) :: x + ! Local variables + integer :: i,j,k,l + + if (cfg%Lradar_sim) then + i = Npoints + j = Ncolumns + k = Nlevels + l = Nhydro + else ! Allocate minumum storage if simulator not used + i = 1 + j = 1 + k = 1 + l = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ncolumns = j + x%Nlevels = k + x%Nhydro = l + + ! --- Allocate arrays --- + allocate(x%att_gas(i,k), x%Ze_tot(i,j,k)) + ! --- Initialise to zero --- + x%att_gas = 0.0 + x%Ze_tot = 0.0 + ! The following line give a compilation error on the Met Office NEC +! call zero_real(x%Z_hydro, x%att_hydro) +! f90: error(666): cosp_types.f90, line nnn: +! Actual argument corresponding to dummy +! argument of ELEMENTAL subroutine +! "zero_real" with INTENET(OUT) attribute +! is not array. + END SUBROUTINE CONSTRUCT_COSP_SGRADAR + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------ SUBROUTINE FREE_COSP_SGRADAR ---------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_SGRADAR(x) + type(cosp_sgradar),intent(inout) :: x + + deallocate(x%att_gas, x%Ze_tot) + END SUBROUTINE FREE_COSP_SGRADAR + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------- SUBROUTINE CONSTRUCT_COSP_RADARSTATS --------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_RADARSTATS(cfg,Npoints,Ncolumns,Nlevels,Nhydro,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Ncolumns ! Number of subgrid columns + integer,intent(in) :: Nlevels ! Number of model levels + integer,intent(in) :: Nhydro ! Number of hydrometeors + type(cosp_radarstats),intent(out) :: x + ! Local variables + integer :: i,j,k,l + + ! Allocate minumum storage if simulator not used + if (cfg%Lradar_sim) then + i = Npoints + j = Ncolumns + k = Nlevels + l = Nhydro + else + i = 1 + j = 1 + k = 1 + l = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ncolumns = j + x%Nlevels = k + x%Nhydro = l + + ! --- Allocate arrays --- + allocate(x%cfad_ze(i,DBZE_BINS,k),x%lidar_only_freq_cloud(i,k)) + allocate(x%radar_lidar_tcc(i)) + ! --- Initialise to zero --- + x%cfad_ze = 0.0 + x%lidar_only_freq_cloud = 0.0 + x%radar_lidar_tcc = 0.0 + END SUBROUTINE CONSTRUCT_COSP_RADARSTATS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------ SUBROUTINE FREE_COSP_RADARSTATS ------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_RADARSTATS(x) + type(cosp_radarstats),intent(inout) :: x + + deallocate(x%cfad_ze,x%lidar_only_freq_cloud,x%radar_lidar_tcc) + END SUBROUTINE FREE_COSP_RADARSTATS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------- SUBROUTINE CONSTRUCT_COSP_LIDARSTATS --------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_LIDARSTATS(cfg,Npoints,Ncolumns,Nlevels,Nhydro,Nrefl,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Ncolumns ! Number of subgrid columns + integer,intent(in) :: Nlevels ! Number of model levels + integer,intent(in) :: Nhydro ! Number of hydrometeors + integer,intent(in) :: Nrefl ! Number of parasol reflectance + type(cosp_lidarstats),intent(out) :: x + ! Local variables + integer :: i,j,k,l,m + + ! Allocate minumum storage if simulator not used + if (cfg%Llidar_sim) then + i = Npoints + j = Ncolumns + k = Nlevels + l = Nhydro + m = Nrefl + else + i = 1 + j = 1 + k = 1 + l = 1 + m = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ncolumns = j + x%Nlevels = k + x%Nhydro = l + x%Nrefl = m + + ! --- Allocate arrays --- + allocate(x%srbval(SR_BINS),x%cfad_sr(i,SR_BINS,k), & + x%lidarcld(i,k), x%cldlayer(i,LIDAR_NCAT), x%parasolrefl(i,m)) + ! --- Initialise to zero --- + x%srbval = 0.0 + x%cfad_sr = 0.0 + x%lidarcld = 0.0 + x%cldlayer = 0.0 + x%parasolrefl = 0.0 + END SUBROUTINE CONSTRUCT_COSP_LIDARSTATS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------ SUBROUTINE FREE_COSP_LIDARSTATS ------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_LIDARSTATS(x) + type(cosp_lidarstats),intent(inout) :: x + + deallocate(x%srbval, x%cfad_sr, x%lidarcld, x%cldlayer, x%parasolrefl) + END SUBROUTINE FREE_COSP_LIDARSTATS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_SUBGRID ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_SUBGRID(Npoints,Ncolumns,Nlevels,y) + integer,intent(in) :: Npoints, & ! Number of gridpoints + Ncolumns, & ! Number of columns + Nlevels ! Number of levels + type(cosp_subgrid),intent(out) :: y + + ! Dimensions + y%Npoints = Npoints + y%Ncolumns = Ncolumns + y%Nlevels = Nlevels + + ! --- Allocate arrays --- + allocate(y%frac_out(Npoints,Ncolumns,Nlevels)) + if (Ncolumns > 1) then + allocate(y%prec_frac(Npoints,Ncolumns,Nlevels)) + else ! CRM mode, not needed + allocate(y%prec_frac(1,1,1)) + endif + ! --- Initialise to zero --- + y%prec_frac = 0.0 + y%frac_out = 0.0 + ! The following line gives a compilation error on the Met Office NEC +! call zero_real(y%mr_hydro) +! f90: error(666): cosp_types.f90, line nnn: +! Actual argument corresponding to dummy +! argument of ELEMENTAL subroutine +! "zero_real" with INTENET(OUT) attribute +! is not array. + + END SUBROUTINE CONSTRUCT_COSP_SUBGRID + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_SUBGRID ----------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_SUBGRID(y) + type(cosp_subgrid),intent(inout) :: y + + ! --- Deallocate arrays --- + deallocate(y%prec_frac, y%frac_out) + + END SUBROUTINE FREE_COSP_SUBGRID + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_SGHYDRO ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_SGHYDRO(Npoints,Ncolumns,Nlevels,Nhydro,y) + integer,intent(in) :: Npoints, & ! Number of gridpoints + Ncolumns, & ! Number of columns + Nhydro, & ! Number of hydrometeors + Nlevels ! Number of levels + type(cosp_sghydro),intent(out) :: y + + ! Dimensions + y%Npoints = Npoints + y%Ncolumns = Ncolumns + y%Nlevels = Nlevels + y%Nhydro = Nhydro + + ! --- Allocate arrays --- + allocate(y%mr_hydro(Npoints,Ncolumns,Nlevels,Nhydro), & + y%Reff(Npoints,Ncolumns,Nlevels,Nhydro)) + ! --- Initialise to zero --- + y%mr_hydro = 0.0 + y%Reff = 0.0 + + END SUBROUTINE CONSTRUCT_COSP_SGHYDRO + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_SGHYDRO ----------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_SGHYDRO(y) + type(cosp_sghydro),intent(inout) :: y + + ! --- Deallocate arrays --- + deallocate(y%mr_hydro, y%Reff) + + END SUBROUTINE FREE_COSP_SGHYDRO + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_GRIDBOX ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_GRIDBOX(time,radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, & + Npoints,Nlevels,Ncolumns,Nhydro,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, & + lidar_ice_type,isccp_top_height,isccp_top_height_direction,isccp_overlap,isccp_emsfc_lw, & + use_precipitation_fluxes,use_reff, & + ! RTTOV inputs + Plat,Sat,Inst,Nchan,ZenAng,Ichan,SurfEm,co2,ch4,n2o,co,& + y) + double precision,intent(in) :: time ! Time since start of run [days] + real,intent(in) :: radar_freq, & ! Radar frequency [GHz] + k2 ! |K|^2, -1=use frequency dependent default + integer,intent(in) :: & + surface_radar, & ! surface=1,spaceborne=0 + use_mie_tables, & ! use a precomputed lookup table? yes=1,no=0,2=use first column everywhere + use_gas_abs, & ! include gaseous absorption? yes=1,no=0 + do_ray, & ! calculate/output Rayleigh refl=1, not=0 + melt_lay ! melting layer model off=0, on=1 + integer,intent(in) :: Npoints ! Number of gridpoints + integer,intent(in) :: Nlevels ! Number of levels + integer,intent(in) :: Ncolumns ! Number of columns + integer,intent(in) :: Nhydro ! Number of hydrometeors + integer,intent(in) :: Nprmts_max_hydro ! Max number of parameters for hydrometeor size distributions + integer,intent(in) :: Naero ! Number of aerosol species + integer,intent(in) :: Nprmts_max_aero ! Max number of parameters for aerosol size distributions + integer,intent(in) :: Npoints_it ! Number of gridpoints processed in one iteration + integer,intent(in) :: lidar_ice_type ! Ice particle shape in lidar calculations (0=ice-spheres ; 1=ice-non-spherical) + integer,intent(in) :: isccp_top_height + integer,intent(in) :: isccp_top_height_direction + integer,intent(in) :: isccp_overlap + real,intent(in) :: isccp_emsfc_lw + logical,intent(in) :: use_precipitation_fluxes,use_reff + integer,intent(in) :: Plat + integer,intent(in) :: Sat + integer,intent(in) :: Inst + integer,intent(in) :: Nchan + integer,intent(in) :: Ichan(Nchan) + real,intent(in) :: SurfEm(Nchan) + real,intent(in) :: ZenAng + real,intent(in) :: co2,ch4,n2o,co + type(cosp_gridbox),intent(out) :: y + + + ! local variables + integer i, cnt_ice, cnt_liq + character*200 :: mie_table_name ! Mie table name + real*8 :: delt, deltp + + ! Dimensions and scalars + y%radar_freq = radar_freq + y%surface_radar = surface_radar + y%use_mie_tables = use_mie_tables + y%use_gas_abs = use_gas_abs + y%do_ray = do_ray + y%melt_lay = melt_lay + y%k2 = k2 + y%Npoints = Npoints + y%Nlevels = Nlevels + y%Ncolumns = Ncolumns + y%Nhydro = Nhydro + y%Nprmts_max_hydro = Nprmts_max_hydro + y%Naero = Naero + y%Nprmts_max_aero = Nprmts_max_aero + y%Npoints_it = Npoints_it + y%lidar_ice_type = lidar_ice_type + y%isccp_top_height = isccp_top_height + y%isccp_top_height_direction = isccp_top_height_direction + y%isccp_overlap = isccp_overlap + y%isccp_emsfc_lw = isccp_emsfc_lw + y%use_precipitation_fluxes = use_precipitation_fluxes + y%use_reff = use_reff + + y%time = time + + ! RTTOV parameters + y%Plat = Plat + y%Sat = Sat + y%Inst = Inst + y%Nchan = Nchan + y%ZenAng = ZenAng + y%co2 = co2 + y%ch4 = ch4 + y%n2o = n2o + y%co = co + + ! --- Allocate arrays --- + ! Gridbox information (Npoints,Nlevels) + allocate(y%zlev(Npoints,Nlevels), y%zlev_half(Npoints,Nlevels), y%dlev(Npoints,Nlevels), & + y%p(Npoints,Nlevels), y%ph(Npoints,Nlevels), y%T(Npoints,Nlevels), & + y%q(Npoints,Nlevels), y%sh(Npoints,Nlevels), & + y%dtau_s(Npoints,Nlevels), y%dtau_c(Npoints,Nlevels), & + y%dem_s(Npoints,Nlevels), y%dem_c(Npoints,Nlevels), & + y%tca(Npoints,Nlevels), y%cca(Npoints,Nlevels), & + y%rain_ls(Npoints,Nlevels), y%rain_cv(Npoints,Nlevels), y%grpl_ls(Npoints,Nlevels), & + y%snow_ls(Npoints,Nlevels), y%snow_cv(Npoints,Nlevels),y%mr_ozone(Npoints,Nlevels)) + + + ! Surface information and geolocation (Npoints) + allocate(y%longitude(Npoints),y%latitude(Npoints),y%psfc(Npoints), y%land(Npoints), & + y%sunlit(Npoints),y%skt(Npoints),y%sfc_height(Npoints),y%u_wind(Npoints),y%v_wind(Npoints)) + ! Hydrometeors concentration and distribution parameters + allocate(y%mr_hydro(Npoints,Nlevels,Nhydro), & + y%dist_prmts_hydro(Nprmts_max_hydro,Nhydro), & + y%Reff(Npoints,Nlevels,Nhydro)) + ! Aerosols concentration and distribution parameters + allocate(y%conc_aero(Npoints,Nlevels,Naero), y%dist_type_aero(Naero), & + y%dist_prmts_aero(Npoints,Nlevels,Nprmts_max_aero,Naero)) + + ! RTTOV channels and sfc. emissivity + allocate(y%ichan(Nchan),y%surfem(Nchan)) + + ! RTTOV parameters + y%ichan = ichan + y%surfem = surfem + + ! --- Initialise to zero --- + y%zlev = 0.0 + y%zlev_half = 0.0 + y%dlev = 0.0 + y%p = 0.0 + y%ph = 0.0 + y%T = 0.0 + y%q = 0.0 + y%sh = 0.0 + y%dtau_s = 0.0 + y%dtau_c = 0.0 + y%dem_s = 0.0 + y%dem_c = 0.0 + y%tca = 0.0 + y%cca = 0.0 + y%rain_ls = 0.0 + y%rain_cv = 0.0 + y%grpl_ls = 0.0 + y%snow_ls = 0.0 + y%snow_cv = 0.0 + y%Reff = 0.0 + y%mr_ozone = 0.0 + y%u_wind = 0.0 + y%v_wind = 0.0 + + + ! (Npoints) +! call zero_real(y%psfc, y%land) + y%longitude = 0.0 + y%latitude = 0.0 + y%psfc = 0.0 + y%land = 0.0 + y%sunlit = 0.0 + y%skt = 0.0 + y%sfc_height = 0.0 + ! (Npoints,Nlevels,Nhydro) +! y%fr_hydro = 0.0 + y%mr_hydro = 0.0 + ! Others + y%dist_prmts_hydro = 0.0 ! (Nprmts_max_hydro,Nhydro) + y%conc_aero = 0.0 ! (Npoints,Nlevels,Naero) + y%dist_type_aero = 0 ! (Naero) + y%dist_prmts_aero = 0.0 ! (Npoints,Nlevels,Nprmts_max_aero,Naero) + + y%hp%p1 = 0.0 + y%hp%p2 = 0.0 + y%hp%p3 = 0.0 + y%hp%dmin = 0.0 + y%hp%dmax = 0.0 + y%hp%apm = 0.0 + y%hp%bpm = 0.0 + y%hp%rho = 0.0 + y%hp%dtype = 0 + y%hp%col = 0 + y%hp%cp = 0 + y%hp%phase = 0 + y%hp%scaled = .false. + y%hp%z_flag = .false. + y%hp%Ze_scaled = 0.0 + y%hp%Zr_scaled = 0.0 + y%hp%kr_scaled = 0.0 + y%hp%fc = 0.0 + y%hp%rho_eff = 0.0 + y%hp%ifc = 0 + y%hp%idd = 0 + y%mt%freq = 0.0 + y%mt%tt = 0.0 + y%mt%f = 0.0 + y%mt%D = 0.0 + y%mt%qext = 0.0 + y%mt%qbsca = 0.0 + y%mt%phase = 0 + + + ! --- Initialize the distributional parameters for hydrometeors + y%dist_prmts_hydro( 1,:) = HCLASS_TYPE(:) + y%dist_prmts_hydro( 2,:) = HCLASS_COL(:) + y%dist_prmts_hydro( 3,:) = HCLASS_PHASE(:) + y%dist_prmts_hydro( 4,:) = HCLASS_CP(:) + y%dist_prmts_hydro( 5,:) = HCLASS_DMIN(:) + y%dist_prmts_hydro( 6,:) = HCLASS_DMAX(:) + y%dist_prmts_hydro( 7,:) = HCLASS_APM(:) + y%dist_prmts_hydro( 8,:) = HCLASS_BPM(:) + y%dist_prmts_hydro( 9,:) = HCLASS_RHO(:) + y%dist_prmts_hydro(10,:) = HCLASS_P1(:) + y%dist_prmts_hydro(11,:) = HCLASS_P2(:) + y%dist_prmts_hydro(12,:) = HCLASS_P3(:) + + ! the following code added by roj to initialize structures used by radar simulator, Feb 2008 + call load_hydrometeor_classes(y%Nprmts_max_hydro,y%dist_prmts_hydro(:,:),y%hp,y%Nhydro) + + ! load mie tables ? + if (y%use_mie_tables == 1) then + + ! ----- Mie tables ---- + mie_table_name='mie_table.dat' + call load_mie_table(mie_table_name,y%mt) + + ! :: D specified by table ... not must match that used when mie LUT generated! + y%nsizes = mt_nd + allocate(y%D(y%nsizes)) + y%D = y%mt%D + + else + ! otherwise we still need to initialize temperature arrays for Ze scaling (which is only done when not using mie table) + + cnt_ice=19 + cnt_liq=20 + if (.not.(allocated(mt_ttl).and.allocated(mt_tti))) then + allocate(mt_ttl(cnt_liq),mt_tti(cnt_ice)) ! note needed as this is global array ... + ! which should be changed in the future + endif + + do i=1,cnt_ice + mt_tti(i)=(i-1)*5-90 + enddo + + do i=1,cnt_liq + mt_ttl(i)=(i-1)*5 - 60 + enddo + + allocate(y%mt_ttl(cnt_liq),y%mt_tti(cnt_ice)) + + y%mt_ttl = mt_ttl + y%mt_tti = mt_tti + +! !------ OLD code in v0.1 --------------------------- +! allocate(mt_ttl(2),mt_tti(2)) +! allocate(y%mt_ttl(2),y%mt_tti(2)) +! mt_ttl = 0.0 +! mt_tti = 0.0 +! y%mt_ttl = mt_ttl +! y%mt_tti = mt_tti +! !--------------------------------------------------- + + ! :: D created on a log-linear scale + y%nsizes = nd + delt = (log(dmax)-log(dmin))/(y%nsizes-1) + deltp = exp(delt) + allocate(y%D(y%nsizes)) + y%D(1) = dmin + do i=2,y%nsizes + y%D(i) = y%D(i-1)*deltp + enddo + + endif + + +END SUBROUTINE CONSTRUCT_COSP_GRIDBOX + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_GRIDBOX ----------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_GRIDBOX(y,dglobal) + type(cosp_gridbox),intent(inout) :: y + logical,intent(in),optional :: dglobal + + ! --- Free arrays --- + deallocate(y%D,y%mt_ttl,y%mt_tti) ! added by roj Feb 2008 + if (.not.present(dglobal)) deallocate(mt_ttl,mt_tti) + +! deallocate(y%hp%p1,y%hp%p2,y%hp%p3,y%hp%dmin,y%hp%dmax,y%hp%apm,y%hp%bpm,y%hp%rho, & +! y%hp%dtype,y%hp%col,y%hp%cp,y%hp%phase,y%hp%scaled, & +! y%hp%z_flag,y%hp%Ze_scaled,y%hp%Zr_scaled,y%hp%kr_scaled, & +! y%hp%fc, y%hp%rho_eff, y%hp%ifc, y%hp%idd) +! deallocate(y%mt%freq, y%mt%tt, y%mt%f, y%mt%D, y%mt%qext, y%mt%qbsca, y%mt%phase) + + deallocate(y%zlev, y%zlev_half, y%dlev, y%p, y%ph, y%T, y%q, & + y%sh, y%dtau_s, y%dtau_c, y%dem_s, y%dem_c, & + y%longitude,y%latitude,y%psfc, y%land, y%tca, y%cca, & + y%mr_hydro, y%dist_prmts_hydro, & + y%conc_aero, y%dist_type_aero, y%dist_prmts_aero, & + y%rain_ls, y%rain_cv, y%snow_ls, y%snow_cv, y%grpl_ls, & + y%sunlit, y%skt, y%sfc_height, y%Reff,y%ichan,y%surfem, & + y%mr_ozone,y%u_wind,y%v_wind) + + END SUBROUTINE FREE_COSP_GRIDBOX + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_GRIDBOX_CPHP ---------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_GRIDBOX_CPHP(x,y) + type(cosp_gridbox),intent(in) :: x + type(cosp_gridbox),intent(inout) :: y + + integer :: i,j,k,sz(3) + double precision :: tny + + tny = tiny(tny) + y%hp%p1 = x%hp%p1 + y%hp%p2 = x%hp%p2 + y%hp%p3 = x%hp%p3 + y%hp%dmin = x%hp%dmin + y%hp%dmax = x%hp%dmax + y%hp%apm = x%hp%apm + y%hp%bpm = x%hp%bpm + y%hp%rho = x%hp%rho + y%hp%dtype = x%hp%dtype + y%hp%col = x%hp%col + y%hp%cp = x%hp%cp + y%hp%phase = x%hp%phase + + y%hp%fc = x%hp%fc + y%hp%rho_eff = x%hp%rho_eff + y%hp%ifc = x%hp%ifc + y%hp%idd = x%hp%idd + sz = shape(x%hp%z_flag) + do k=1,sz(3) + do j=1,sz(2) + do i=1,sz(1) + if (x%hp%scaled(i,k)) y%hp%scaled(i,k) = .true. + if (x%hp%z_flag(i,j,k)) y%hp%z_flag(i,j,k) = .true. + if (abs(x%hp%Ze_scaled(i,j,k)) > tny) y%hp%Ze_scaled(i,j,k) = x%hp%Ze_scaled(i,j,k) + if (abs(x%hp%Zr_scaled(i,j,k)) > tny) y%hp%Zr_scaled(i,j,k) = x%hp%Zr_scaled(i,j,k) + if (abs(x%hp%kr_scaled(i,j,k)) > tny) y%hp%kr_scaled(i,j,k) = x%hp%kr_scaled(i,j,k) + enddo + enddo + enddo + +END SUBROUTINE COSP_GRIDBOX_CPHP + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_GRIDBOX_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_GRIDBOX_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_gridbox),intent(in) :: x + type(cosp_gridbox),intent(inout) :: y + + integer :: i,j,k,sz(3) + + ! --- Copy arrays without Npoints as dimension --- + y%dist_prmts_hydro = x%dist_prmts_hydro + y%dist_type_aero = x%dist_type_aero + y%D = x%D + y%mt_ttl = x%mt_ttl + y%mt_tti = x%mt_tti + + +! call cosp_gridbox_cphp(x,y) + + ! 1D + y%longitude(iy(1):iy(2)) = x%longitude(ix(1):ix(2)) + y%latitude(iy(1):iy(2)) = x%latitude(ix(1):ix(2)) + y%psfc(iy(1):iy(2)) = x%psfc(ix(1):ix(2)) + y%land(iy(1):iy(2)) = x%land(ix(1):ix(2)) + y%sunlit(iy(1):iy(2)) = x%sunlit(ix(1):ix(2)) + y%skt(iy(1):iy(2)) = x%skt(ix(1):ix(2)) + y%sfc_height(iy(1):iy(2)) = x%sfc_height(ix(1):ix(2)) + y%u_wind(iy(1):iy(2)) = x%u_wind(ix(1):ix(2)) + y%v_wind(iy(1):iy(2)) = x%v_wind(ix(1):ix(2)) + ! 2D + y%zlev(iy(1):iy(2),:) = x%zlev(ix(1):ix(2),:) + y%zlev_half(iy(1):iy(2),:) = x%zlev_half(ix(1):ix(2),:) + y%dlev(iy(1):iy(2),:) = x%dlev(ix(1):ix(2),:) + y%p(iy(1):iy(2),:) = x%p(ix(1):ix(2),:) + y%ph(iy(1):iy(2),:) = x%ph(ix(1):ix(2),:) + y%T(iy(1):iy(2),:) = x%T(ix(1):ix(2),:) + y%q(iy(1):iy(2),:) = x%q(ix(1):ix(2),:) + y%sh(iy(1):iy(2),:) = x%sh(ix(1):ix(2),:) + y%dtau_s(iy(1):iy(2),:) = x%dtau_s(ix(1):ix(2),:) + y%dtau_c(iy(1):iy(2),:) = x%dtau_c(ix(1):ix(2),:) + y%dem_s(iy(1):iy(2),:) = x%dem_s(ix(1):ix(2),:) + y%dem_c(iy(1):iy(2),:) = x%dem_c(ix(1):ix(2),:) + y%tca(iy(1):iy(2),:) = x%tca(ix(1):ix(2),:) + y%cca(iy(1):iy(2),:) = x%cca(ix(1):ix(2),:) + y%rain_ls(iy(1):iy(2),:) = x%rain_ls(ix(1):ix(2),:) + y%rain_cv(iy(1):iy(2),:) = x%rain_cv(ix(1):ix(2),:) + y%grpl_ls(iy(1):iy(2),:) = x%grpl_ls(ix(1):ix(2),:) + y%snow_ls(iy(1):iy(2),:) = x%snow_ls(ix(1):ix(2),:) + y%snow_cv(iy(1):iy(2),:) = x%snow_cv(ix(1):ix(2),:) + y%mr_ozone(iy(1):iy(2),:) = x%mr_ozone(ix(1):ix(2),:) + ! 3D + y%Reff(iy(1):iy(2),:,:) = x%Reff(ix(1):ix(2),:,:) + y%conc_aero(iy(1):iy(2),:,:) = x%conc_aero(ix(1):ix(2),:,:) + y%mr_hydro(iy(1):iy(2),:,:) = x%mr_hydro(ix(1):ix(2),:,:) + ! 4D + y%dist_prmts_aero(iy(1):iy(2),:,:,:) = x%dist_prmts_aero(ix(1):ix(2),:,:,:) + +END SUBROUTINE COSP_GRIDBOX_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_SUBGRID_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_SUBGRID_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_subgrid),intent(in) :: x + type(cosp_subgrid),intent(inout) :: y + + y%prec_frac(iy(1):iy(2),:,:) = x%prec_frac(ix(1):ix(2),:,:) + y%frac_out(iy(1):iy(2),:,:) = x%frac_out(ix(1):ix(2),:,:) +END SUBROUTINE COSP_SUBGRID_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_SGRADAR_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_SGRADAR_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_sgradar),intent(in) :: x + type(cosp_sgradar),intent(inout) :: y + + y%att_gas(iy(1):iy(2),:) = x%att_gas(ix(1):ix(2),:) + y%Ze_tot(iy(1):iy(2),:,:) = x%Ze_tot(ix(1):ix(2),:,:) +END SUBROUTINE COSP_SGRADAR_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_SGLIDAR_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_SGLIDAR_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_sglidar),intent(in) :: x + type(cosp_sglidar),intent(inout) :: y + + y%beta_mol(iy(1):iy(2),:) = x%beta_mol(ix(1):ix(2),:) + y%beta_tot(iy(1):iy(2),:,:) = x%beta_tot(ix(1):ix(2),:,:) + y%tau_tot(iy(1):iy(2),:,:) = x%tau_tot(ix(1):ix(2),:,:) + y%refl(iy(1):iy(2),:,:) = x%refl(ix(1):ix(2),:,:) +END SUBROUTINE COSP_SGLIDAR_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_ISCCP_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_ISCCP_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_isccp),intent(in) :: x + type(cosp_isccp),intent(inout) :: y + + y%fq_isccp(iy(1):iy(2),:,:) = x%fq_isccp(ix(1):ix(2),:,:) + y%totalcldarea(iy(1):iy(2)) = x%totalcldarea(ix(1):ix(2)) + y%meantb(iy(1):iy(2)) = x%meantb(ix(1):ix(2)) + y%meantbclr(iy(1):iy(2)) = x%meantbclr(ix(1):ix(2)) + y%meanptop(iy(1):iy(2)) = x%meanptop(ix(1):ix(2)) + y%meantaucld(iy(1):iy(2)) = x%meantaucld(ix(1):ix(2)) + y%meanalbedocld(iy(1):iy(2)) = x%meanalbedocld(ix(1):ix(2)) + y%boxtau(iy(1):iy(2),:) = x%boxtau(ix(1):ix(2),:) + y%boxptop(iy(1):iy(2),:) = x%boxptop(ix(1):ix(2),:) +END SUBROUTINE COSP_ISCCP_CPSECTION + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_MISR_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_MISR_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_misr),intent(in) :: x + type(cosp_misr),intent(inout) :: y + + y%fq_MISR(iy(1):iy(2),:,:) = x%fq_MISR(ix(1):ix(2),:,:) + y%MISR_meanztop(iy(1):iy(2)) = x%MISR_meanztop(ix(1):ix(2)) + y%MISR_cldarea(iy(1):iy(2)) = x%MISR_cldarea(ix(1):ix(2)) + y%MISR_dist_model_layertops(iy(1):iy(2),:) = x%MISR_dist_model_layertops(ix(1):ix(2),:) +END SUBROUTINE COSP_MISR_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_RTTOV_CPSECTION ------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_RTTOV_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_rttov),intent(in) :: x + type(cosp_rttov),intent(inout) :: y + + y%tbs(iy(1):iy(2),:) = x%tbs(ix(1):ix(2),:) +END SUBROUTINE COSP_RTTOV_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_RADARSTATS_CPSECTION -------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_RADARSTATS_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_radarstats),intent(in) :: x + type(cosp_radarstats),intent(inout) :: y + + y%cfad_ze(iy(1):iy(2),:,:) = x%cfad_ze(ix(1):ix(2),:,:) + y%radar_lidar_tcc(iy(1):iy(2)) = x%radar_lidar_tcc(ix(1):ix(2)) + y%lidar_only_freq_cloud(iy(1):iy(2),:) = x%lidar_only_freq_cloud(ix(1):ix(2),:) +END SUBROUTINE COSP_RADARSTATS_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_LIDARSTATS_CPSECTION -------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_LIDARSTATS_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_lidarstats),intent(in) :: x + type(cosp_lidarstats),intent(inout) :: y + + y%srbval = x%srbval + y%cfad_sr(iy(1):iy(2),:,:) = x%cfad_sr(ix(1):ix(2),:,:) + y%lidarcld(iy(1):iy(2),:) = x%lidarcld(ix(1):ix(2),:) + y%cldlayer(iy(1):iy(2),:) = x%cldlayer(ix(1):ix(2),:) + y%parasolrefl(iy(1):iy(2),:) = x%parasolrefl(ix(1):ix(2),:) +END SUBROUTINE COSP_LIDARSTATS_CPSECTION + +END MODULE MOD_COSP_TYPES Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_utils.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_utils.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/cosp_utils.F90 (revision 1280) @@ -0,0 +1,294 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! + +MODULE MOD_COSP_UTILS + USE MOD_COSP_CONSTANTS + IMPLICIT NONE + + INTERFACE Z_TO_DBZ + MODULE PROCEDURE Z_TO_DBZ_2D,Z_TO_DBZ_3D,Z_TO_DBZ_4D + END INTERFACE + + INTERFACE COSP_CHECK_INPUT + MODULE PROCEDURE COSP_CHECK_INPUT_1D,COSP_CHECK_INPUT_2D,COSP_CHECK_INPUT_3D + END INTERFACE +CONTAINS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE ZERO_INT ------------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +ELEMENTAL SUBROUTINE ZERO_INT(x,y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & + y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, & + y21,y22,y23,y24,y25,y26,y27,y28,y29,y30) + + integer,intent(inout) :: x + integer,intent(inout),optional :: y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & + y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, & + y21,y22,y23,y24,y25,y26,y27,y28,y29,y30 + x = 0 + if (present(y01)) y01 = 0 + if (present(y02)) y02 = 0 + if (present(y03)) y03 = 0 + if (present(y04)) y04 = 0 + if (present(y05)) y05 = 0 + if (present(y06)) y06 = 0 + if (present(y07)) y07 = 0 + if (present(y08)) y08 = 0 + if (present(y09)) y09 = 0 + if (present(y10)) y10 = 0 + if (present(y11)) y11 = 0 + if (present(y12)) y12 = 0 + if (present(y13)) y13 = 0 + if (present(y14)) y14 = 0 + if (present(y15)) y15 = 0 + if (present(y16)) y16 = 0 + if (present(y17)) y17 = 0 + if (present(y18)) y18 = 0 + if (present(y19)) y19 = 0 + if (present(y20)) y20 = 0 + if (present(y21)) y21 = 0 + if (present(y22)) y22 = 0 + if (present(y23)) y23 = 0 + if (present(y24)) y24 = 0 + if (present(y25)) y25 = 0 + if (present(y26)) y26 = 0 + if (present(y27)) y27 = 0 + if (present(y28)) y28 = 0 + if (present(y29)) y29 = 0 + if (present(y30)) y30 = 0 +END SUBROUTINE ZERO_INT + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE ZERO_REAL ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +ELEMENTAL SUBROUTINE ZERO_REAL(x,y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & + y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, & + y21,y22,y23,y24,y25,y26,y27,y28,y29,y30) + + real,intent(inout) :: x + real,intent(inout),optional :: y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & + y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, & + y21,y22,y23,y24,y25,y26,y27,y28,y29,y30 + x = 0.0 + if (present(y01)) y01 = 0.0 + if (present(y02)) y02 = 0.0 + if (present(y03)) y03 = 0.0 + if (present(y04)) y04 = 0.0 + if (present(y05)) y05 = 0.0 + if (present(y06)) y06 = 0.0 + if (present(y07)) y07 = 0.0 + if (present(y08)) y08 = 0.0 + if (present(y09)) y09 = 0.0 + if (present(y10)) y10 = 0.0 + if (present(y11)) y11 = 0.0 + if (present(y12)) y12 = 0.0 + if (present(y13)) y13 = 0.0 + if (present(y14)) y14 = 0.0 + if (present(y15)) y15 = 0.0 + if (present(y16)) y16 = 0.0 + if (present(y17)) y17 = 0.0 + if (present(y18)) y18 = 0.0 + if (present(y19)) y19 = 0.0 + if (present(y20)) y20 = 0.0 + if (present(y21)) y21 = 0.0 + if (present(y22)) y22 = 0.0 + if (present(y23)) y23 = 0.0 + if (present(y24)) y24 = 0.0 + if (present(y25)) y25 = 0.0 + if (present(y26)) y26 = 0.0 + if (present(y27)) y27 = 0.0 + if (present(y28)) y28 = 0.0 + if (present(y29)) y29 = 0.0 + if (present(y30)) y30 = 0.0 +END SUBROUTINE ZERO_REAL + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE Z_TO_DBZ_2D -------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE Z_TO_DBZ_2D(mdi,z) + real,intent(in) :: mdi + real,dimension(:,:),intent(inout) :: z + ! Reflectivity Z: + ! Input in [m3] + ! Output in dBZ, with Z in [mm6 m-3] + + ! 1.e18 to convert from [m3] to [mm6 m-3] + z = 1.e18*z + where (z > 1.0e-6) ! Limit to -60 dBZ + z = 10.0*log10(z) + elsewhere + z = mdi + end where + END SUBROUTINE Z_TO_DBZ_2D +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE Z_TO_DBZ_3D -------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE Z_TO_DBZ_3D(mdi,z) + real,intent(in) :: mdi + real,dimension(:,:,:),intent(inout) :: z + ! Reflectivity Z: + ! Input in [m3] + ! Output in dBZ, with Z in [mm6 m-3] + + ! 1.e18 to convert from [m3] to [mm6 m-3] + z = 1.e18*z + where (z > 1.0e-6) ! Limit to -60 dBZ + z = 10.0*log10(z) + elsewhere + z = mdi + end where + END SUBROUTINE Z_TO_DBZ_3D +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE Z_TO_DBZ_4D -------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE Z_TO_DBZ_4D(mdi,z) + real,intent(in) :: mdi + real,dimension(:,:,:,:),intent(inout) :: z + ! Reflectivity Z: + ! Input in [m3] + ! Output in dBZ, with Z in [mm6 m-3] + + ! 1.e18 to convert from [m3] to [mm6 m-3] + z = 1.e18*z + where (z > 1.0e-6) ! Limit to -60 dBZ + z = 10.0*log10(z) + elsewhere + z = mdi + end where + END SUBROUTINE Z_TO_DBZ_4D + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------------- SUBROUTINES COSP_CHECK_INPUT_1D --------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_CHECK_INPUT_1D(vname,x,min_val,max_val) + character(len=*) :: vname + real,intent(inout) :: x(:) + real,intent(in),optional :: min_val,max_val + logical :: l_min,l_max + character(len=128) :: pro_name='COSP_CHECK_INPUT_1D' + + l_min=.false. + l_max=.false. + + if (present(min_val)) then +! if (x < min_val) x = min_val + if (any(x < min_val)) then + l_min = .true. + where (x < min_val) + x = min_val + end where + endif + endif + if (present(max_val)) then +! if (x > max_val) x = max_val + if (any(x > max_val)) then + l_max = .true. + where (x > max_val) + x = max_val + end where + endif + endif + + if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val + if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val + END SUBROUTINE COSP_CHECK_INPUT_1D +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------------- SUBROUTINES COSP_CHECK_INPUT_2D --------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_CHECK_INPUT_2D(vname,x,min_val,max_val) + character(len=*) :: vname + real,intent(inout) :: x(:,:) + real,intent(in),optional :: min_val,max_val + logical :: l_min,l_max + character(len=128) :: pro_name='COSP_CHECK_INPUT_2D' + + l_min=.false. + l_max=.false. + + if (present(min_val)) then +! if (x < min_val) x = min_val + if (any(x < min_val)) then + l_min = .true. + where (x < min_val) + x = min_val + end where + endif + endif + if (present(max_val)) then +! if (x > max_val) x = max_val + if (any(x > max_val)) then + l_max = .true. + where (x > max_val) + x = max_val + end where + endif + endif + + if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val + if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val + END SUBROUTINE COSP_CHECK_INPUT_2D +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------------- SUBROUTINES COSP_CHECK_INPUT_3D --------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_CHECK_INPUT_3D(vname,x,min_val,max_val) + character(len=*) :: vname + real,intent(inout) :: x(:,:,:) + real,intent(in),optional :: min_val,max_val + logical :: l_min,l_max + character(len=128) :: pro_name='COSP_CHECK_INPUT_3D' + + l_min=.false. + l_max=.false. + + if (present(min_val)) then +! if (x < min_val) x = min_val + if (any(x < min_val)) then + l_min = .true. + where (x < min_val) + x = min_val + end where + endif + endif + if (present(max_val)) then +! if (x > max_val) x = max_val + if (any(x > max_val)) then + l_max = .true. + where (x > max_val) + x = max_val + end where + endif + endif + + if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val + if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val + END SUBROUTINE COSP_CHECK_INPUT_3D + + +END MODULE MOD_COSP_UTILS Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/dsd.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/dsd.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/dsd.F90 (revision 1280) @@ -0,0 +1,359 @@ + subroutine dsd(Q,Re,D,N,nsizes,dtype,rho_a,tc, & + dmin,dmax,apm,bpm,rho_c,p1,p2,p3,fc,scaled) + use array_lib + use math_lib + implicit none + +! Purpose: +! Create a discrete drop size distribution +! Part of QuickBeam v1.03 by John Haynes +! http://reef.atmos.colostate.edu/haynes/radarsim +! +! Inputs: +! [Q] hydrometeor mixing ratio (g/kg) +! [Re] Optional Effective Radius (microns). 0 = use default. +! [D] discrete drop sizes (um) +! [nsizes] number of elements of [D] +! [dtype] distribution type +! [rho_a] ambient air density (kg m^-3) +! [tc] temperature (C) +! [dmin] minimum size cutoff (um) +! [dmax] maximum size cutoff (um) +! [rho_c] alternate constant density (kg m^-3) +! [p1],[p2],[p3] distribution parameters +! +! Input/Output: +! [fc] scaling factor for the distribution +! [scaled] has this hydrometeor type been scaled? +! [apm] a parameter for mass (kg m^[-bpm]) +! [bmp] b params for mass +! +! Outputs: +! [N] discrete concentrations (cm^-3 um^-1) +! or, for monodisperse, a constant (1/cm^3) +! +! Requires: +! function infind +! +! Created: +! 11/28/05 John Haynes (haynes@atmos.colostate.edu) +! Modified: +! 01/31/06 Port from IDL to Fortran 90 +! 07/07/06 Rewritten for variable DSD's +! 10/02/06 Rewritten using scaling factors (Roger Marchand and JMH) + +! ----- INPUTS ----- + + integer*4, intent(in) :: nsizes + integer, intent(in) :: dtype + real*8, intent(in) :: Q,D(nsizes),rho_a,tc,dmin,dmax, & + rho_c,p1,p2,p3 + +! ----- INPUT/OUTPUT ----- + + real*8, intent(inout) :: fc(nsizes),apm,bpm,Re + logical, intent(inout) :: scaled + +! ----- OUTPUTS ----- + + real*8, intent(out) :: N(nsizes) + +! ----- INTERNAL ----- + + real*8 :: & + N0,D0,vu,np,dm,ld, & ! gamma, exponential variables + dmin_mm,dmax_mm,ahp,bhp, & ! power law variables + rg,log_sigma_g, & ! lognormal variables + rho_e ! particle density (kg m^-3) + + real*8 :: tmp1, tmp2 + real*8 :: pi,rc + + integer k,lidx,uidx + + pi = acos(-1.0) + +! // if density is constant, store equivalent values for apm and bpm + if ((rho_c > 0) .and. (apm < 0)) then + apm = (pi/6)*rho_c + bpm = 3. + endif + + select case(dtype) + +! ---------------------------------------------------------! +! // modified gamma ! +! ---------------------------------------------------------! +! :: N0 = total number concentration (m^-3) +! :: np = fixed number concentration (kg^-1) +! :: D0 = characteristic diameter (um) +! :: dm = mean diameter (um) +! :: vu = distribution width parameter + + case(1) + if (abs(p1+1) < 1E-8) then + +! // D0, vu are given + vu = p3 + + if(Re.le.0) then + dm = p2 + D0 = gamma(vu)/gamma(vu+1)*dm + else + D0 = 2.0*Re*gamma(vu+2)/gamma(vu+3) + endif + + if (scaled .eqv. .false.) then + + fc = ( & + ((D*1E-6)**(vu-1)*exp(-1*D/D0)) / & + (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm)) & + ) * 1E-12 + scaled = .true. + + endif + + N = fc*rho_a*(Q*1E-3) + + elseif (abs(p2+1) < 1E-8) then + +! // N0, vu are given + np = p1 + vu = p3 + tmp1 = (Q*1E-3)**(1./bpm) + + if (scaled .eqv. .false.) then + + fc = (D*1E-6 / (gamma(vu)/(apm*np*gamma(vu+bpm)))** & + (1./bpm))**vu + + scaled = .true. + + endif + + N = ( & + (rho_a*np*fc*(D*1E-6)**(-1.))/(gamma(vu)*tmp1**vu) * & + exp(-1.*fc**(1./vu)/tmp1) & + ) * 1E-12 + + else + +! // vu isn't given + print *, 'Error: Must specify a value for vu' + stop + + endif + +! ---------------------------------------------------------! +! // exponential ! +! ---------------------------------------------------------! +! :: N0 = intercept parameter (m^-4) +! :: ld = slope parameter (um) + + case(2) + if (abs(p1+1) > 1E-8) then + +! // N0 has been specified, determine ld + N0 = p1 + + if(Re>0) then + + ! if Re is set and No is set than the distribution is fully defined. + ! so we assume Re and No have already been chosen consistant with + ! the water content, Q. + + ! print *,'using Re pass ...' + + ld = 1.5/Re ! units 1/um + + N = ( & + N0*exp(-1*ld*D) & + ) * 1E-12 + + else + + tmp1 = 1./(1.+bpm) + + if (scaled .eqv. .false.) then + fc = ((apm*gamma(1.+bpm)*N0)**tmp1)*(D*1E-6) + scaled = .true. + + endif + + N = ( & + N0*exp(-1.*fc*(1./(rho_a*Q*1E-3))**tmp1) & + ) * 1E-12 + + endif + + elseif (abs(p2+1) > 1E-8) then + +! // ld has been specified, determine N0 + ld = p2 + + if (scaled .eqv. .false.) then + + fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))* & + exp(-1.*(ld*1E6)*(D*1E-6))*1E-12 + scaled = .true. + + endif + + N = fc*rho_a*(Q*1E-3) + + else + +! // ld will be determined from temperature, then N0 follows + ld = 1220*10.**(-0.0245*tc)*1E-6 + N0 = ((ld*1E6)**(1+bpm)*Q*1E-3*rho_a)/(apm*gamma(1+bpm)) + + N = ( & + N0*exp(-1*ld*D) & + ) * 1E-12 + + endif + +! ---------------------------------------------------------! +! // power law ! +! ---------------------------------------------------------! +! :: ahp = Ar parameter (m^-4 mm^-bhp) +! :: bhp = br parameter +! :: dmin_mm = lower bound (mm) +! :: dmax_mm = upper bound (mm) + + case(3) + +! :: br parameter + if (abs(p1+2) < 1E-8) then +! :: if p1=-2, bhp is parameterized according to Ryan (2000), +! :: applicatable to cirrus clouds + if (tc < -30) then + bhp = -1.75+0.09*((tc+273)-243.16) + elseif ((tc >= -30) .and. (tc < -9)) then + bhp = -3.25-0.06*((tc+273)-265.66) + else + bhp = -2.15 + endif + elseif (abs(p1+3) < 1E-8) then +! :: if p1=-3, bhp is parameterized according to Ryan (2000), +! :: applicable to frontal clouds + if (tc < -35) then + bhp = -1.75+0.09*((tc+273)-243.16) + elseif ((tc >= -35) .and. (tc < -17.5)) then + bhp = -2.65+0.09*((tc+273)-255.66) + elseif ((tc >= -17.5) .and. (tc < -9)) then + bhp = -3.25-0.06*((tc+273)-265.66) + else + bhp = -2.15 + endif + else +! :: otherwise the specified value is used + bhp = p1 + endif + +! :: Ar parameter + dmin_mm = dmin*1E-3 + dmax_mm = dmax*1E-3 + +! :: commented lines are original method with constant density + ! rc = 500. ! (kg/m^3) + ! tmp1 = 6*rho_a*(bhp+4) + ! tmp2 = pi*rc*(dmax_mm**(bhp+4))*(1-(dmin_mm/dmax_mm)**(bhp+4)) + ! ahp = (Q*1E-3)*1E12*tmp1/tmp2 + +! :: new method is more consistent with the rest of the distributions +! :: and allows density to vary with particle size + tmp1 = rho_a*(Q*1E-3)*(bhp+bpm+1) + tmp2 = apm*(dmax_mm**bhp*dmax**(bpm+1)-dmin_mm**bhp*dmin**(bpm+1)) + ahp = tmp1/tmp2 * 1E24 + ! ahp = tmp1/tmp2 + + lidx = infind(D,dmin) + uidx = infind(D,dmax) + do k=lidx,uidx + + N(k) = ( & + ahp*(D(k)*1E-3)**bhp & + ) * 1E-12 + + enddo + + ! print *,'test=',ahp,bhp,ahp/(rho_a*Q),D(100),N(100),bpm,dmin_mm,dmax_mm + +! ---------------------------------------------------------! +! // monodisperse ! +! ---------------------------------------------------------! +! :: D0 = particle diameter (um) + + case(4) + + if (scaled .eqv. .false.) then + + D0 = p1 + rho_e = (6/pi)*apm*(D0*1E-6)**(bpm-3) + fc(1) = (6./(pi*D0**3*rho_e))*1E12 + scaled = .true. + + endif + + N(1) = fc(1)*rho_a*(Q*1E-3) + +! ---------------------------------------------------------! +! // lognormal ! +! ---------------------------------------------------------! +! :: N0 = total number concentration (m^-3) +! :: np = fixed number concentration (kg^-1) +! :: rg = mean radius (um) +! :: log_sigma_g = ln(geometric standard deviation) + + case(5) + if (abs(p1+1) < 1E-8) then + +! // rg, log_sigma_g are given + log_sigma_g = p3 + tmp2 = (bpm*log_sigma_g)**2. + if(Re.le.0) then + rg = p2 + else + rg =Re*exp(-2.5*(log_sigma_g**2)) + endif + + if (scaled .eqv. .false.) then + + fc = 0.5 * ( & + (1./((2.*rg*1E-6)**(bpm)*apm*(2.*pi)**(0.5) * & + log_sigma_g*D*0.5*1E-6)) * & + exp(-0.5*((log(0.5*D/rg)/log_sigma_g)**2.+tmp2)) & + ) * 1E-12 + scaled = .true. + + endif + + N = fc*rho_a*(Q*1E-3) + + elseif (abs(p2+1) < 1E-8) then + +! // N0, log_sigma_g are given + Np = p1 + log_sigma_g = p3 + N0 = np*rho_a + tmp1 = (rho_a*(Q*1E-3))/(2.**bpm*apm*N0) + tmp2 = exp(0.5*bpm**2.*(log_sigma_g))**2. + rg = ((tmp1/tmp2)**(1/bpm))*1E6 + + N = 0.5*( & + N0 / ((2.*pi)**(0.5)*log_sigma_g*D*0.5*1E-6) * & + exp((-0.5*(log(0.5*D/rg)/log_sigma_g)**2.)) & + ) * 1E-12 + + else + +! // vu isn't given + print *, 'Error: Must specify a value for sigma_g' + stop + + endif + + end select + + end subroutine dsd Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/format_input.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/format_input.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/format_input.F90 (revision 1280) @@ -0,0 +1,132 @@ +! FORMAT_INPUT: Procedures to prepare data for input to the simulator +! Compiled/Modified: +! 08/28/2006 John Haynes (haynes@atmos.colostate.edu) +! +! irreg_to_grid (subroutine) +! order_data (subroutine) + + module format_input + + contains + +! ---------------------------------------------------------------------------- +! SUBROUTINE IRREG_TO_GRID +! ---------------------------------------------------------------------------- + subroutine irreg_to_grid(hgt_matrix,t_matrix,p_matrix,rh_matrix, & + env_hgt_matrix,env_t_matrix,env_p_matrix,env_rh_matrix) + use array_lib + implicit none + +! Purpose: +! Linearly interpolate sounding-level data to the hydrometeor-level +! resolution +! +! Inputs: +! [hgt_matrix] hydrometeor-level heights +! [env_hgt_matrix] sounding-level heights +! [env_t_matrix] sounding-level temperatures +! [env_p_matrix] sounding-level pressures +! [env_rh_matrix] sounding-level relative humidities +! +! Outputs: +! [t_matrix] hydrometeor-level temperatures +! [p_matrix] hydrometeor-level pressures +! [rh_matrix] hydrometeor-level relative humidities +! +! Created: +! 08/28/2006 John Haynes (haynes@atmos.colostate.edu) + +! ----- INPUTS ----- + real*8, dimension(:,:), intent(in) :: & + hgt_matrix,env_hgt_matrix,env_t_matrix,env_p_matrix,env_rh_matrix + +! ----- OUTPUTS ----- + real*8, dimension(:,:), intent(out) :: & + t_matrix,p_matrix,rh_matrix + +! ----- INTERNAL ----- + integer :: nprof, i + integer,parameter :: KR8 = selected_real_kind(15,300) + + nprof = size(hgt_matrix,1) + do i=1,nprof + call lin_interpolate(env_t_matrix(i,:),env_hgt_matrix(i,:), & + t_matrix(i,:),hgt_matrix(i,:),1000._KR8) + call lin_interpolate(env_p_matrix(i,:),env_hgt_matrix(i,:), & + p_matrix(i,:),hgt_matrix(i,:),1000._KR8) + call lin_interpolate(env_rh_matrix(i,:),env_hgt_matrix(i,:), & + rh_matrix(i,:),hgt_matrix(i,:),1000._KR8) + enddo + + end subroutine irreg_to_grid + +! ---------------------------------------------------------------------------- +! SUBROUTINE ORDER_DATA +! ---------------------------------------------------------------------------- + subroutine order_data(hgt_matrix,hm_matrix,p_matrix,t_matrix, & + rh_matrix,sfc_radar,hgt_reversed) + implicit none + +! Purpose: +! Ensure that input data is in top-down order/bottom-up order, +! for space-based/surface based radars, respectively +! +! Inputs: +! [hgt_matrix] heights +! [hm_matrix] mixing ratios +! [t_matrix] temperatures +! [p_matrix] pressures +! [rh_matrix] relative humidities +! [sfc_radar] 1=surface radar, 0=spaceborne +! +! Outputs: +! [hgt_matrix],[hm_matrix],[p_matrix,[t_matrix],[rh_matrix] in proper +! order for input to the radar simulator routine +! [hgt_reversed] T=heights were reordered,F=heights were not reordered +! +! Note: +! The order for all profiles is assumed to the same as the first profile. +! +! Created: +! 08/28/2006 John Haynes (haynes@atmos.colostate.edu) + +! ----- INPUTS ----- + integer, intent(in) :: sfc_radar + +! ----- OUTPUTS ----- + real*8, dimension(:,:), intent(inout) :: & + hgt_matrix,p_matrix,t_matrix,rh_matrix + real*8, dimension(:,:,:), intent(inout) :: & + hm_matrix + logical, intent(out) :: hgt_reversed + +! ----- INTERNAL ----- + integer :: ngate + logical :: hgt_descending + + + ngate = size(hgt_matrix,2) + hgt_descending = hgt_matrix(1,1) > hgt_matrix(1,ngate) + +! :: surface: heights must be ascending +! :: space-based: heights must be descending + if ( & + (sfc_radar == 1 .and. hgt_descending) .or. & + (sfc_radar == 0 .and. (.not. hgt_descending)) & + ) & + then + + hgt_matrix(:,:) = hgt_matrix(:,ngate:1:-1) + hm_matrix(:,:,:) = hm_matrix(:,:,ngate:1:-1) + p_matrix(:,:) = p_matrix(:,ngate:1:-1) + t_matrix(:,:) = t_matrix(:,ngate:1:-1) + rh_matrix(:,:) = rh_matrix(:,ngate:1:-1) + + hgt_reversed = .true. + else + hgt_reversed = .false. + endif + + end subroutine order_data + + end module format_input Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/gases.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/gases.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/gases.F90 (revision 1280) @@ -0,0 +1,182 @@ + function gases(PRES_mb,T,RH,f) + implicit none + +! Purpose: +! Compute 2-way gaseous attenuation through a volume in microwave +! +! Inputs: +! [PRES_mb] pressure (mb) (hPa) +! [T] temperature (K) +! [RH] relative humidity (%) +! [f] frequency (GHz), < 300 GHz +! +! Returns: +! 2-way gaseous attenuation (dB/km) +! +! Reference: +! Uses method of Liebe (1985) +! +! Created: +! 12/09/05 John Haynes (haynes@atmos.colostate.edu) +! Modified: +! 01/31/06 Port from IDL to Fortran 90 + + integer, parameter :: & + nbands_o2 = 48 ,& + nbands_h2o = 30 + real*8, intent(in) :: PRES_mb, T, RH, f + real*8 :: gases, th, e, p, sumo, gm0, a0, ap, term1, term2, term3, & + bf, be, term4, npp + real*8, dimension(nbands_o2) :: v0, a1, a2, a3, a4, a5, a6 + real*8, dimension(nbands_h2o) :: v1, b1, b2, b3 + integer :: i + +! // table1 parameters v0, a1, a2, a3, a4, a5, a6 + data v0/49.4523790,49.9622570,50.4742380,50.9877480,51.5033500, & + 52.0214090,52.5423930,53.0669060,53.5957480,54.1299999,54.6711570, & + 55.2213650,55.7838000,56.2647770,56.3378700,56.9681000,57.6124810, & + 58.3238740,58.4465890,59.1642040,59.5909820,60.3060570,60.4347750, & + 61.1505580,61.8001520,62.4112120,62.4862530,62.9979740,63.5685150, & + 64.1277640,64.6789000,65.2240670,65.7647690,66.3020880,66.8368270, & + 67.3695950,67.9008620,68.4310010,68.9603060,69.4890210,70.0173420, & + 118.7503410,368.4983500,424.7631200,487.2493700,715.3931500, & + 773.8387300, 834.1453300/ + data a1/0.0000001,0.0000003,0.0000009,0.0000025,0.0000061,0.0000141, & + 0.0000310,0.0000641,0.0001247,0.0002280,0.0003918,0.0006316,0.0009535, & + 0.0005489,0.0013440,0.0017630,0.0000213,0.0000239,0.0000146,0.0000240, & + 0.0000211,0.0000212,0.0000246,0.0000250,0.0000230,0.0000193,0.0000152, & + 0.0000150,0.0000109,0.0007335,0.0004635,0.0002748,0.0001530,0.0000801, & + 0.0000395,0.0000183,0.0000080,0.0000033,0.0000013,0.0000005,0.0000002, & + 0.0000094,0.0000679,0.0006380,0.0002350,0.0000996,0.0006710,0.0001800/ + data a2/11.8300000,10.7200000,9.6900000,8.8900000,7.7400000,6.8400000, & + 6.0000000,5.2200000,4.4800000,3.8100000,3.1900000,2.6200000,2.1150000, & + 0.0100000,1.6550000,1.2550000,0.9100000,0.6210000,0.0790000,0.3860000, & + 0.2070000,0.2070000,0.3860000,0.6210000,0.9100000,1.2550000,0.0780000, & + 1.6600000,2.1100000,2.6200000,3.1900000,3.8100000,4.4800000,5.2200000, & + 6.0000000,6.8400000,7.7400000,8.6900000,9.6900000,10.7200000,11.8300000, & + 0.0000000,0.0200000,0.0110000,0.0110000,0.0890000,0.0790000,0.0790000/ + data a3/0.0083000,0.0085000,0.0086000,0.0087000,0.0089000,0.0092000, & + 0.0094000,0.0097000,0.0100000,0.0102000,0.0105000,0.0107900,0.0111000, & + 0.0164600,0.0114400,0.0118100,0.0122100,0.0126600,0.0144900,0.0131900, & + 0.0136000,0.0138200,0.0129700,0.0124800,0.0120700,0.0117100,0.0146800, & + 0.0113900,0.0110800,0.0107800,0.0105000,0.0102000,0.0100000,0.0097000, & + 0.0094000,0.0092000,0.0089000,0.0087000,0.0086000,0.0085000,0.0084000, & + 0.0159200,0.0192000,0.0191600,0.0192000,0.0181000,0.0181000,0.0181000/ + data a4/0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.6000000,0.6000000,0.6000000,0.6000000,0.6000000,0.6000000/ + data a5/0.0056000,0.0056000,0.0056000,0.0055000,0.0056000,0.0055000, & + 0.0057000,0.0053000,0.0054000,0.0048000,0.0048000,0.0041700,0.0037500, & + 0.0077400,0.0029700,0.0021200,0.0009400,-0.0005500,0.0059700,-0.0024400, & + 0.0034400,-0.0041300,0.0013200,-0.0003600,-0.0015900,-0.0026600, & + -0.0047700,-0.0033400,-0.0041700,-0.0044800,-0.0051000,-0.0051000, & + -0.0057000,-0.0055000,-0.0059000,-0.0056000,-0.0058000,-0.0057000, & + -0.0056000,-0.0056000,-0.0056000,-0.0004400,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000/ + data a6/1.7000000,1.7000000,1.7000000,1.7000000,1.8000000,1.8000000,& + 1.8000000,1.9000000,1.8000000,2.0000000,1.9000000,2.1000000,2.1000000, & + 0.9000000,2.3000000,2.5000000,3.7000000,-3.1000000,0.8000000,0.1000000, & + 0.5000000,0.7000000,-1.0000000,5.8000000,2.9000000,2.3000000,0.9000000, & + 2.2000000,2.0000000,2.0000000,1.8000000,1.9000000,1.8000000,1.8000000, & + 1.7000000,1.8000000,1.7000000,1.7000000,1.7000000,1.7000000,1.7000000, & + 0.9000000,1.0000000,1.0000000,1.0000000,1.0000000,1.0000000,1.0000000/ + +! // table2 parameters v1, b1, b2, b3 + data v1/22.2350800,67.8139600,119.9959400,183.3101170,321.2256440, & + 325.1529190,336.1870000,380.1973720,390.1345080,437.3466670,439.1508120, & + 443.0182950,448.0010750,470.8889740,474.6891270,488.4911330,503.5685320, & + 504.4826920,556.9360020,620.7008070,658.0065000,752.0332270,841.0735950, & + 859.8650000,899.4070000,902.5550000,906.2055240,916.1715820,970.3150220, & + 987.9267640/ + data b1/0.1090000,0.0011000,0.0007000,2.3000000,0.0464000,1.5400000, & + 0.0010000,11.9000000,0.0044000,0.0637000,0.9210000,0.1940000,10.6000000, & + 0.3300000,1.2800000,0.2530000,0.0374000,0.0125000,510.0000000,5.0900000, & + 0.2740000,250.0000000,0.0130000,0.1330000,0.0550000,0.0380000,0.1830000, & + 8.5600000,9.1600000,138.0000000/ + data b2/2.1430000,8.7300000,8.3470000,0.6530000,6.1560000,1.5150000, & + 9.8020000,1.0180000,7.3180000,5.0150000,3.5610000,5.0150000,1.3700000, & + 3.5610000,2.3420000,2.8140000,6.6930000,6.6930000,0.1140000,2.1500000, & + 7.7670000,0.3360000,8.1130000,7.9890000,7.8450000,8.3600000,5.0390000, & + 1.3690000,1.8420000,0.1780000/ + data b3/0.0278400,0.0276000,0.0270000,0.0283500,0.0214000,0.0270000, & + 0.0265000,0.0276000,0.0190000,0.0137000,0.0164000,0.0144000,0.0238000, & + 0.0182000,0.0198000,0.0249000,0.0115000,0.0119000,0.0300000,0.0223000, & + 0.0300000,0.0286000,0.0141000,0.0286000,0.0286000,0.0264000,0.0234000, & + 0.0253000,0.0240000,0.0286000/ + +! // conversions + th = 300./T ! unitless + e = (RH*th**5)/(41.45*10**(9.834*th-10)) ! kPa + p = PRES_mb/10.-e ! kPa + +! // term1 + sumo = 0. + do i=1,nbands_o2 + sumo = sumo + fpp_o2(p,th,e,a3(i),a4(i),a5(i),a6(i),f,v0(i)) & + * s_o2(p,th,a1(i),a2(i)) + enddo + term1 = sumo + +! // term2 + gm0 = 5.6E-3*(p+1.1*e)*th**(0.8) + a0 = 3.07E-4 + ap = 1.4*(1-1.2*f**(1.5)*1E-5)*1E-10 + term2 = (2*a0*(gm0*(1+(f/gm0)**2)*(1+(f/60.)**2))**(-1) + ap*p*th**(2.5)) & + * f*p*th**2 + +! // term3 + sumo = 0. + do i=1,nbands_h2o + sumo = sumo + fpp_h2o(p,th,e,b3(i),f,v1(i)) & + * s_h2o(th,e,b1(i),b2(i)) + enddo + term3 = sumo + +! // term4 + bf = 1.4E-6 + be = 5.41E-5 + term4 = (bf*p+be*e*th**3)*f*e*th**(2.5) + +! // summation and result + npp = term1 + term2 + term3 + term4 + gases = 0.182*f*npp + +! ----- SUB FUNCTIONS ----- + + contains + + function fpp_o2(p,th,e,a3,a4,a5,a6,f,v0) + real*8 :: fpp_o2,p,th,e,a3,a4,a5,a6,f,v0 + real*8 :: gm, delt, x, y + gm = a3*(p*th**(0.8-a4)+1.1*e*th) + delt = a5*p*th**(a6) + x = (v0-f)**2+gm**2 + y = (v0+f)**2+gm**2 + fpp_o2 = ((1./x)+(1./y))*(gm*f/v0) - (delt*f/v0)*(((v0-f)/(x))-((v0+f)/(x))) + end function fpp_o2 + + function fpp_h2o(p,th,e,b3,f,v0) + real*8 :: fpp_h2o,p,th,e,b3,f,v0 + real*8 :: gm, delt, x, y + gm = b3*(p*th**(0.8)+4.8*e*th) + delt = 0. + x = (v0-f)**2+gm**2 + y = (v0+f)**2+gm**2 + fpp_h2o = ((1./x)+(1./y))*(gm*f/v0) - (delt*f/v0)*(((v0-f)/(x))-((v0+f)/(x))) + end function fpp_h2o + + function s_o2(p,th,a1,a2) + real*8 :: s_o2,p,th,a1,a2 + s_o2 = a1*p*th**(3)*exp(a2*(1-th)) + end function s_o2 + + function s_h2o(th,e,b1,b2) + real*8 :: s_h2o,th,e,b1,b2 + s_h2o = b1*e*th**(3.5)*exp(b2*(1-th)) + end function s_h2o + + end function gases Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/icarus.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/icarus.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/icarus.F (revision 1280) @@ -0,0 +1,1265 @@ + SUBROUTINE ICARUS( + & debug, + & debugcol, + & npoints, + & sunlit, + & nlev, + & ncol, + & pfull, + & phalf, + & qv, + & cc, + & conv, + & dtau_s, + & dtau_c, + & top_height, + & top_height_direction, + & overlap, + & frac_out, + & skt, + & emsfc_lw, + & at, + & dem_s, + & dem_c, + & fq_isccp, + & totalcldarea, + & meanptop, + & meantaucld, + & meanalbedocld, + & meantb, + & meantbclr, + & boxtau, + & boxptop + &) + +!Id: icarus.f,v 4.0 2009/02/12 13:59:20 hadmw Exp $ + +! *****************************COPYRIGHT**************************** +! (c) 2009, Lawrence Livermore National Security Limited Liability +! Corporation. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the +! following conditions are met: +! +! * Redistributions of source code must retain the above +! copyright notice, this list of conditions and the following +! disclaimer. +! * Redistributions in binary form must reproduce the above +! copyright notice, this list of conditions and the following +! disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Lawrence Livermore National Security +! Limited Liability Corporation nor the names of its +! contributors may be used to endorse or promote products +! derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! *****************************COPYRIGHT******************************* +! *****************************COPYRIGHT******************************* +! *****************************COPYRIGHT******************************* + + implicit none + +! NOTE: the maximum number of levels and columns is set by +! the following parameter statement + + INTEGER ncolprint + +! ----- +! Input +! ----- + + INTEGER npoints ! number of model points in the horizontal + INTEGER nlev ! number of model levels in column + INTEGER ncol ! number of subcolumns + + INTEGER sunlit(npoints) ! 1 for day points, 0 for night time + + REAL pfull(npoints,nlev) + ! pressure of full model levels (Pascals) + ! pfull(npoints,1) is top level of model + ! pfull(npoints,nlev) is bot of model + + REAL phalf(npoints,nlev+1) + ! pressure of half model levels (Pascals) + ! phalf(npoints,1) is top of model + ! phalf(npoints,nlev+1) is the surface pressure + + REAL qv(npoints,nlev) + ! water vapor specific humidity (kg vapor/ kg air) + ! on full model levels + + REAL cc(npoints,nlev) + ! input cloud cover in each model level (fraction) + ! NOTE: This is the HORIZONTAL area of each + ! grid box covered by clouds + + REAL conv(npoints,nlev) + ! input convective cloud cover in each model + ! level (fraction) + ! NOTE: This is the HORIZONTAL area of each + ! grid box covered by convective clouds + + REAL dtau_s(npoints,nlev) + ! mean 0.67 micron optical depth of stratiform + ! clouds in each model level + ! NOTE: this the cloud optical depth of only the + ! cloudy part of the grid box, it is not weighted + ! with the 0 cloud optical depth of the clear + ! part of the grid box + + REAL dtau_c(npoints,nlev) + ! mean 0.67 micron optical depth of convective + ! clouds in each + ! model level. Same note applies as in dtau_s. + + INTEGER overlap ! overlap type + ! 1=max + ! 2=rand + ! 3=max/rand + + INTEGER top_height ! 1 = adjust top height using both a computed + ! infrared brightness temperature and the visible + ! optical depth to adjust cloud top pressure. Note + ! that this calculation is most appropriate to compare + ! to ISCCP data during sunlit hours. + ! 2 = do not adjust top height, that is cloud top + ! pressure is the actual cloud top pressure + ! in the model + ! 3 = adjust top height using only the computed + ! infrared brightness temperature. Note that this + ! calculation is most appropriate to compare to ISCCP + ! IR only algortihm (i.e. you can compare to nighttime + ! ISCCP data with this option) + + INTEGER top_height_direction ! direction for finding atmosphere pressure level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! + ! 1 = find the *lowest* altitude (highest pressure) level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! + ! 2 = find the *highest* altitude (lowest pressure) level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! + ! ONLY APPLICABLE IF top_height EQUALS 1 or 3 + ! ! + ! 1 = old setting: matches all versions of + ! ISCCP simulator with versions numbers 3.5.1 and lower + ! + ! 2 = default setting: for version numbers 4.0 and higher +! +! The following input variables are used only if top_height = 1 or top_height = 3 +! + REAL skt(npoints) ! skin Temperature (K) + REAL emsfc_lw ! 10.5 micron emissivity of surface (fraction) + REAL at(npoints,nlev) ! temperature in each model level (K) + REAL dem_s(npoints,nlev) ! 10.5 micron longwave emissivity of stratiform + ! clouds in each + ! model level. Same note applies as in dtau_s. + REAL dem_c(npoints,nlev) ! 10.5 micron longwave emissivity of convective + ! clouds in each + ! model level. Same note applies as in dtau_s. + + REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into + ! Equivalent of BOX in original version, but + ! indexed by column then row, rather than + ! by row then column + + + +! ------ +! Output +! ------ + + REAL fq_isccp(npoints,7,7) ! the fraction of the model grid box covered by + ! each of the 49 ISCCP D level cloud types + + REAL totalcldarea(npoints) ! the fraction of model grid box columns + ! with cloud somewhere in them. NOTE: This diagnostic + ! does not count model clouds with tau < isccp_taumin + ! Thus this diagnostic does not equal the sum over all entries of fq_isccp. + ! However, this diagnostic does equal the sum over entries of fq_isccp with + ! itau = 2:7 (omitting itau = 1) + + + ! The following three means are averages only over the cloudy areas with tau > isccp_taumin. + ! If no clouds with tau > isccp_taumin are in grid box all three quantities should equal zero. + + REAL meanptop(npoints) ! mean cloud top pressure (mb) - linear averaging + ! in cloud top pressure. + + REAL meantaucld(npoints) ! mean optical thickness + ! linear averaging in albedo performed. + + real meanalbedocld(npoints) ! mean cloud albedo + ! linear averaging in albedo performed + + real meantb(npoints) ! mean all-sky 10.5 micron brightness temperature + + real meantbclr(npoints) ! mean clear-sky 10.5 micron brightness temperature + + REAL boxtau(npoints,ncol) ! optical thickness in each column + + REAL boxptop(npoints,ncol) ! cloud top pressure (mb) in each column + + +! +! ------ +! Working variables added when program updated to mimic Mark Webb's PV-Wave code +! ------ + + REAL dem(npoints,ncol),bb(npoints) ! working variables for 10.5 micron longwave + ! emissivity in part of + ! gridbox under consideration + + REAL ptrop(npoints) + REAL attrop(npoints) + REAL attropmin (npoints) + REAL atmax(npoints) + REAL atmin(npoints) + REAL btcmin(npoints) + REAL transmax(npoints) + + INTEGER i,j,ilev,ibox,itrop(npoints) + INTEGER ipres(npoints) + INTEGER itau(npoints),ilev2 + INTEGER acc(nlev,ncol) + INTEGER match(npoints,nlev-1) + INTEGER nmatch(npoints) + INTEGER levmatch(npoints,ncol) + + !variables needed for water vapor continuum absorption + real fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints) + real taumin(npoints) + real dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0 + real press(npoints), dpress(npoints), atmden(npoints) + real rvh20(npoints), wk(npoints), rhoave(npoints) + real rh20s(npoints), rfrgn(npoints) + real tmpexp(npoints),tauwv(npoints) + + character*1 cchar(6),cchar_realtops(6) + integer icycle + REAL tau(npoints,ncol) + LOGICAL box_cloudy(npoints,ncol) + REAL tb(npoints,ncol) + REAL ptop(npoints,ncol) + REAL emcld(npoints,ncol) + REAL fluxtop(npoints,ncol) + REAL trans_layers_above(npoints,ncol) + real isccp_taumin,fluxtopinit(npoints),tauir(npoints) + REAL albedocld(npoints,ncol) + real boxarea + integer debug ! set to non-zero value to print out inputs + ! with step debug + integer debugcol ! set to non-zero value to print out column + ! decomposition with step debugcol + integer rangevec(npoints),rangeerror + + integer index1(npoints),num1,jj,k1,k2 + real rec2p13,tauchk,logp,logp1,logp2,atd + real output_missing_value + + character*10 ftn09 + + DATA isccp_taumin / 0.3 / + DATA output_missing_value / -1.E+30 / + DATA cchar / ' ','-','1','+','I','+'/ + DATA cchar_realtops / ' ',' ','1','1','I','I'/ + +! ------ End duplicate definitions common to wrapper routine + + tauchk = -1.*log(0.9999999) + rec2p13=1./2.13 + + ncolprint=0 + + if ( debug.ne.0 ) then + j=1 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write(6,'(a10)') 'debug=' + write(6,'(8I10)') debug + write(6,'(a10)') 'debugcol=' + write(6,'(8I10)') debugcol + write(6,'(a10)') 'npoints=' + write(6,'(8I10)') npoints + write(6,'(a10)') 'nlev=' + write(6,'(8I10)') nlev + write(6,'(a10)') 'ncol=' + write(6,'(8I10)') ncol + write(6,'(a11)') 'top_height=' + write(6,'(8I10)') top_height + write(6,'(a21)') 'top_height_direction=' + write(6,'(8I10)') top_height_direction + write(6,'(a10)') 'overlap=' + write(6,'(8I10)') overlap + write(6,'(a10)') 'emsfc_lw=' + write(6,'(8f10.2)') emsfc_lw + do j=1,npoints,debug + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write(6,'(a10)') 'sunlit=' + write(6,'(8I10)') sunlit(j) + write(6,'(a10)') 'pfull=' + write(6,'(8f10.2)') (pfull(j,i),i=1,nlev) + write(6,'(a10)') 'phalf=' + write(6,'(8f10.2)') (phalf(j,i),i=1,nlev+1) + write(6,'(a10)') 'qv=' + write(6,'(8f10.3)') (qv(j,i),i=1,nlev) + write(6,'(a10)') 'cc=' + write(6,'(8f10.3)') (cc(j,i),i=1,nlev) + write(6,'(a10)') 'conv=' + write(6,'(8f10.2)') (conv(j,i),i=1,nlev) + write(6,'(a10)') 'dtau_s=' + write(6,'(8g12.5)') (dtau_s(j,i),i=1,nlev) + write(6,'(a10)') 'dtau_c=' + write(6,'(8f10.2)') (dtau_c(j,i),i=1,nlev) + write(6,'(a10)') 'skt=' + write(6,'(8f10.2)') skt(j) + write(6,'(a10)') 'at=' + write(6,'(8f10.2)') (at(j,i),i=1,nlev) + write(6,'(a10)') 'dem_s=' + write(6,'(8f10.3)') (dem_s(j,i),i=1,nlev) + write(6,'(a10)') 'dem_c=' + write(6,'(8f10.3)') (dem_c(j,i),i=1,nlev) + enddo + endif + +! ---------------------------------------------------! + + if (ncolprint.ne.0) then + do j=1,npoints,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + enddo + endif + + if (top_height .eq. 1 .or. top_height .eq. 3) then + + do j=1,npoints + ptrop(j)=5000. + atmin(j) = 400. + attropmin(j) = 400. + atmax(j) = 0. + attrop(j) = 120. + itrop(j) = 1 + enddo + + do 12 ilev=1,nlev + do j=1,npoints + if (pfull(j,ilev) .lt. 40000. .and. + & pfull(j,ilev) .gt. 5000. .and. + & at(j,ilev) .lt. attropmin(j)) then + ptrop(j) = pfull(j,ilev) + attropmin(j) = at(j,ilev) + attrop(j) = attropmin(j) + itrop(j)=ilev + end if + if (at(j,ilev) .gt. atmax(j)) atmax(j)=at(j,ilev) + if (at(j,ilev) .lt. atmin(j)) atmin(j)=at(j,ilev) + enddo +12 continue + + end if + + + if (top_height .eq. 1 .or. top_height .eq. 3) then + do j=1,npoints + meantb(j) = 0. + meantbclr(j) = 0. + end do + else + do j=1,npoints + meantb(j) = output_missing_value + meantbclr(j) = output_missing_value + end do + end if + +! -----------------------------------------------------! + +! ---------------------------------------------------! + + do ilev=1,nlev + do j=1,npoints + + rangevec(j)=0 + + if (cc(j,ilev) .lt. 0. .or. cc(j,ilev) .gt. 1.) then +! error = cloud fraction less than zero +! error = cloud fraction greater than 1 + rangevec(j)=rangevec(j)+1 + endif + + if (conv(j,ilev) .lt. 0. .or. conv(j,ilev) .gt. 1.) then +! ' error = convective cloud fraction less than zero' +! ' error = convective cloud fraction greater than 1' + rangevec(j)=rangevec(j)+2 + endif + + if (dtau_s(j,ilev) .lt. 0.) then +! ' error = stratiform cloud opt. depth less than zero' + rangevec(j)=rangevec(j)+4 + endif + + if (dtau_c(j,ilev) .lt. 0.) then +! ' error = convective cloud opt. depth less than zero' + rangevec(j)=rangevec(j)+8 + endif + + if (dem_s(j,ilev) .lt. 0. .or. dem_s(j,ilev) .gt. 1.) then +! ' error = stratiform cloud emissivity less than zero' +! ' error = stratiform cloud emissivity greater than 1' + rangevec(j)=rangevec(j)+16 + endif + + if (dem_c(j,ilev) .lt. 0. .or. dem_c(j,ilev) .gt. 1.) then +! ' error = convective cloud emissivity less than zero' +! ' error = convective cloud emissivity greater than 1' + rangevec(j)=rangevec(j)+32 + endif + enddo + + rangeerror=0 + do j=1,npoints + rangeerror=rangeerror+rangevec(j) + enddo + + if (rangeerror.ne.0) then + write (6,*) 'Input variable out of range' + write (6,*) 'rangevec:' + write (6,*) rangevec + call flush(6) + STOP + endif + enddo + +! +! ---------------------------------------------------! + + +! +! ---------------------------------------------------! +! COMPUTE CLOUD OPTICAL DEPTH FOR EACH COLUMN and +! put into vector tau + + !initialize tau and albedocld to zero + do 15 ibox=1,ncol + do j=1,npoints + tau(j,ibox)=0. + albedocld(j,ibox)=0. + boxtau(j,ibox)=output_missing_value + boxptop(j,ibox)=output_missing_value + box_cloudy(j,ibox)=.false. + enddo +15 continue + + !compute total cloud optical depth for each column + do ilev=1,nlev + !increment tau for each of the boxes + do ibox=1,ncol + do j=1,npoints + if (frac_out(j,ibox,ilev).eq.1) then + tau(j,ibox)=tau(j,ibox) + & + dtau_s(j,ilev) + endif + if (frac_out(j,ibox,ilev).eq.2) then + tau(j,ibox)=tau(j,ibox) + & + dtau_c(j,ilev) + end if + enddo + enddo ! ibox + enddo ! ilev + if (ncolprint.ne.0) then + + do j=1,npoints ,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write(6,'(i2,1X,8(f7.2,1X))') + & ilev, + & (tau(j,ibox),ibox=1,ncolprint) + enddo + endif +! +! ---------------------------------------------------! + + + +! +! ---------------------------------------------------! +! COMPUTE INFRARED BRIGHTNESS TEMPERUATRES +! AND CLOUD TOP TEMPERATURE SATELLITE SHOULD SEE +! +! again this is only done if top_height = 1 or 3 +! +! fluxtop is the 10.5 micron radiance at the top of the +! atmosphere +! trans_layers_above is the total transmissivity in the layers +! above the current layer +! fluxtop_clrsky(j) and trans_layers_above_clrsky(j) are the clear +! sky versions of these quantities. + + if (top_height .eq. 1 .or. top_height .eq. 3) then + + + !---------------------------------------------------------------------- + ! + ! DO CLEAR SKY RADIANCE CALCULATION FIRST + ! + !compute water vapor continuum emissivity + !this treatment follows Schwarkzopf and Ramasamy + !JGR 1999,vol 104, pages 9467-9499. + !the emissivity is calculated at a wavenumber of 955 cm-1, + !or 10.47 microns + wtmair = 28.9644 + wtmh20 = 18.01534 + Navo = 6.023E+23 + grav = 9.806650E+02 + pstd = 1.013250E+06 + t0 = 296. + if (ncolprint .ne. 0) + & write(6,*) 'ilev pw (kg/m2) tauwv(j) dem_wv' + do 125 ilev=1,nlev + do j=1,npoints + !press and dpress are dyne/cm2 = Pascals *10 + press(j) = pfull(j,ilev)*10. + dpress(j) = (phalf(j,ilev+1)-phalf(j,ilev))*10 + !atmden = g/cm2 = kg/m2 / 10 + atmden(j) = dpress(j)/grav + rvh20(j) = qv(j,ilev)*wtmair/wtmh20 + wk(j) = rvh20(j)*Navo*atmden(j)/wtmair + rhoave(j) = (press(j)/pstd)*(t0/at(j,ilev)) + rh20s(j) = rvh20(j)*rhoave(j) + rfrgn(j) = rhoave(j)-rh20s(j) + tmpexp(j) = exp(-0.02*(at(j,ilev)-t0)) + tauwv(j) = wk(j)*1.e-20*( + & (0.0224697*rh20s(j)*tmpexp(j)) + + & (3.41817e-7*rfrgn(j)) )*0.98 + dem_wv(j,ilev) = 1. - exp( -1. * tauwv(j)) + enddo + if (ncolprint .ne. 0) then + do j=1,npoints ,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write(6,'(i2,1X,3(f8.3,3X))') ilev, + & qv(j,ilev)*(phalf(j,ilev+1)-phalf(j,ilev))/(grav/100.), + & tauwv(j),dem_wv(j,ilev) + enddo + endif +125 continue + + !initialize variables + do j=1,npoints + fluxtop_clrsky(j) = 0. + trans_layers_above_clrsky(j)=1. + enddo + + do ilev=1,nlev + do j=1,npoints + + ! Black body emission at temperature of the layer + + bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. ) + !bb(j)= 5.67e-8*at(j,ilev)**4 + + ! increase TOA flux by flux emitted from layer + ! times total transmittance in layers above + + fluxtop_clrsky(j) = fluxtop_clrsky(j) + & + dem_wv(j,ilev)*bb(j)*trans_layers_above_clrsky(j) + + ! update trans_layers_above with transmissivity + ! from this layer for next time around loop + + trans_layers_above_clrsky(j)= + & trans_layers_above_clrsky(j)*(1.-dem_wv(j,ilev)) + + + enddo + if (ncolprint.ne.0) then + do j=1,npoints ,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(a)') 'ilev:' + write (6,'(I2)') ilev + + write (6,'(a)') + & 'emiss_layer,100.*bb(j),100.*f,total_trans:' + write (6,'(4(f7.2,1X))') dem_wv(j,ilev),100.*bb(j), + & 100.*fluxtop_clrsky(j),trans_layers_above_clrsky(j) + enddo + endif + + enddo !loop over level + + do j=1,npoints + !add in surface emission + bb(j)=1/( exp(1307.27/skt(j)) - 1. ) + !bb(j)=5.67e-8*skt(j)**4 + + fluxtop_clrsky(j) = fluxtop_clrsky(j) + emsfc_lw * bb(j) + & * trans_layers_above_clrsky(j) + + !clear sky brightness temperature + meantbclr(j) = 1307.27/(log(1.+(1./fluxtop_clrsky(j)))) + + enddo + + if (ncolprint.ne.0) then + do j=1,npoints ,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(a)') 'id:' + write (6,'(a)') 'surface' + + write (6,'(a)') 'emsfc,100.*bb(j),100.*f,total_trans:' + write (6,'(5(f7.2,1X))') emsfc_lw,100.*bb(j), + & 100.*fluxtop_clrsky(j), + & trans_layers_above_clrsky(j), meantbclr(j) + enddo + endif + + + ! + ! END OF CLEAR SKY CALCULATION + ! + !---------------------------------------------------------------- + + + + if (ncolprint.ne.0) then + + do j=1,npoints ,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(a)') 'ts:' + write (6,'(8f7.2)') (skt(j),ibox=1,ncolprint) + + write (6,'(a)') 'ta_rev:' + write (6,'(8f7.2)') + & ((at(j,ilev2),ibox=1,ncolprint),ilev2=1,nlev) + + enddo + endif + !loop over columns + do ibox=1,ncol + do j=1,npoints + fluxtop(j,ibox)=0. + trans_layers_above(j,ibox)=1. + enddo + enddo + + do ilev=1,nlev + do j=1,npoints + ! Black body emission at temperature of the layer + + bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. ) + !bb(j)= 5.67e-8*at(j,ilev)**4 + enddo + + do ibox=1,ncol + do j=1,npoints + + ! emissivity for point in this layer + if (frac_out(j,ibox,ilev).eq.1) then + dem(j,ibox)= 1. - + & ( (1. - dem_wv(j,ilev)) * (1. - dem_s(j,ilev)) ) + else if (frac_out(j,ibox,ilev).eq.2) then + dem(j,ibox)= 1. - + & ( (1. - dem_wv(j,ilev)) * (1. - dem_c(j,ilev)) ) + else + dem(j,ibox)= dem_wv(j,ilev) + end if + + + ! increase TOA flux by flux emitted from layer + ! times total transmittance in layers above + + fluxtop(j,ibox) = fluxtop(j,ibox) + & + dem(j,ibox) * bb(j) + & * trans_layers_above(j,ibox) + + ! update trans_layers_above with transmissivity + ! from this layer for next time around loop + + trans_layers_above(j,ibox)= + & trans_layers_above(j,ibox)*(1.-dem(j,ibox)) + + enddo ! j + enddo ! ibox + + if (ncolprint.ne.0) then + do j=1,npoints,1000 + write (6,'(a)') 'ilev:' + write (6,'(I2)') ilev + + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(a)') 'emiss_layer:' + write (6,'(8f7.2)') (dem(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') '100.*bb(j):' + write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint) + + write (6,'(a)') '100.*f:' + write (6,'(8f7.2)') + & (100.*fluxtop(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'total_trans:' + write (6,'(8f7.2)') + & (trans_layers_above(j,ibox),ibox=1,ncolprint) + enddo + endif + + enddo ! ilev + + + do j=1,npoints + !add in surface emission + bb(j)=1/( exp(1307.27/skt(j)) - 1. ) + !bb(j)=5.67e-8*skt(j)**4 + end do + + do ibox=1,ncol + do j=1,npoints + + !add in surface emission + + fluxtop(j,ibox) = fluxtop(j,ibox) + & + emsfc_lw * bb(j) + & * trans_layers_above(j,ibox) + + end do + end do + + !calculate mean infrared brightness temperature + do ibox=1,ncol + do j=1,npoints + meantb(j) = meantb(j)+1307.27/(log(1.+(1./fluxtop(j,ibox)))) + end do + end do + do j=1, npoints + meantb(j) = meantb(j) / real(ncol) + end do + + if (ncolprint.ne.0) then + + do j=1,npoints ,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(a)') 'id:' + write (6,'(a)') 'surface' + + write (6,'(a)') 'emiss_layer:' + write (6,'(8f7.2)') (dem(1,ibox),ibox=1,ncolprint) + + write (6,'(a)') '100.*bb(j):' + write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint) + + write (6,'(a)') '100.*f:' + write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'meantb(j):' + write (6,'(8f7.2)') (meantb(j),ibox=1,ncolprint) + + end do + endif + + !now that you have the top of atmosphere radiance account + !for ISCCP procedures to determine cloud top temperature + + !account for partially transmitting cloud recompute flux + !ISCCP would see assuming a single layer cloud + !note choice here of 2.13, as it is primarily ice + !clouds which have partial emissivity and need the + !adjustment performed in this section + ! + !If it turns out that the cloud brightness temperature + !is greater than 260K, then the liquid cloud conversion + !factor of 2.56 is used. + ! + !Note that this is discussed on pages 85-87 of + !the ISCCP D level documentation (Rossow et al. 1996) + + do j=1,npoints + !compute minimum brightness temperature and optical depth + btcmin(j) = 1. / ( exp(1307.27/(attrop(j)-5.)) - 1. ) + enddo + do ibox=1,ncol + do j=1,npoints + transmax(j) = (fluxtop(j,ibox)-btcmin(j)) + & /(fluxtop_clrsky(j)-btcmin(j)) + !note that the initial setting of tauir(j) is needed so that + !tauir(j) has a realistic value should the next if block be + !bypassed + tauir(j) = tau(j,ibox) * rec2p13 + taumin(j) = -1. * log(max(min(transmax(j),0.9999999),0.001)) + + enddo + + if (top_height .eq. 1) then + do j=1,npoints + if (transmax(j) .gt. 0.001 .and. + & transmax(j) .le. 0.9999999) then + fluxtopinit(j) = fluxtop(j,ibox) + tauir(j) = tau(j,ibox) *rec2p13 + endif + enddo + do icycle=1,2 + do j=1,npoints + if (tau(j,ibox) .gt. (tauchk )) then + if (transmax(j) .gt. 0.001 .and. + & transmax(j) .le. 0.9999999) then + emcld(j,ibox) = 1. - exp(-1. * tauir(j) ) + fluxtop(j,ibox) = fluxtopinit(j) - + & ((1.-emcld(j,ibox))*fluxtop_clrsky(j)) + fluxtop(j,ibox)=max(1.E-06, + & (fluxtop(j,ibox)/emcld(j,ibox))) + tb(j,ibox)= 1307.27 + & / (log(1. + (1./fluxtop(j,ibox)))) + if (tb(j,ibox) .gt. 260.) then + tauir(j) = tau(j,ibox) / 2.56 + end if + end if + end if + enddo + enddo + + endif + + do j=1,npoints + if (tau(j,ibox) .gt. (tauchk )) then + !cloudy box + !NOTE: tb is the cloud-top temperature not infrared brightness temperature + !at this point in the code + tb(j,ibox)= 1307.27/ (log(1. + (1./fluxtop(j,ibox)))) + if (top_height.eq.1.and.tauir(j).lt.taumin(j)) then + tb(j,ibox) = attrop(j) - 5. + tau(j,ibox) = 2.13*taumin(j) + end if + else + !clear sky brightness temperature + tb(j,ibox) = meantbclr(j) + end if + enddo ! j + enddo ! ibox + + if (ncolprint.ne.0) then + + do j=1,npoints,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + + write (6,'(a)') 'attrop:' + write (6,'(8f7.2)') (attrop(j)) + + write (6,'(a)') 'btcmin:' + write (6,'(8f7.2)') (btcmin(j)) + + write (6,'(a)') 'fluxtop_clrsky*100:' + write (6,'(8f7.2)') + & (100.*fluxtop_clrsky(j)) + + write (6,'(a)') '100.*f_adj:' + write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'transmax:' + write (6,'(8f7.2)') (transmax(ibox),ibox=1,ncolprint) + + write (6,'(a)') 'tau:' + write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'emcld:' + write (6,'(8f7.2)') (emcld(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'total_trans:' + write (6,'(8f7.2)') + & (trans_layers_above(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'total_emiss:' + write (6,'(8f7.2)') + & (1.0-trans_layers_above(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'total_trans:' + write (6,'(8f7.2)') + & (trans_layers_above(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'ppout:' + write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint) + enddo ! j + endif + + end if + +! ---------------------------------------------------! + +! +! ---------------------------------------------------! +! DETERMINE CLOUD TOP PRESSURE +! +! again the 2 methods differ according to whether +! or not you use the physical cloud top pressure (top_height = 2) +! or the radiatively determined cloud top pressure (top_height = 1 or 3) +! + + !compute cloud top pressure + do 30 ibox=1,ncol + !segregate according to optical thickness + if (top_height .eq. 1 .or. top_height .eq. 3) then + !find level whose temperature + !most closely matches brightness temperature + do j=1,npoints + nmatch(j)=0 + enddo + do 29 k1=1,nlev-1 + if (top_height_direction .eq. 2) then + ilev = nlev - k1 + else + ilev = k1 + end if + !cdir nodep + do j=1,npoints + if (ilev .ge. itrop(j)) then + if ((at(j,ilev) .ge. tb(j,ibox) .and. + & at(j,ilev+1) .le. tb(j,ibox)) .or. + & (at(j,ilev) .le. tb(j,ibox) .and. + & at(j,ilev+1) .ge. tb(j,ibox))) then + nmatch(j)=nmatch(j)+1 + match(j,nmatch(j))=ilev + end if + end if + enddo +29 continue + + do j=1,npoints + if (nmatch(j) .ge. 1) then + k1 = match(j,nmatch(j)) + k2 = k1 + 1 + logp1 = log(pfull(j,k1)) + logp2 = log(pfull(j,k2)) + atd = max(tauchk,abs(at(j,k2) - at(j,k1))) + logp=logp1+(logp2-logp1)*abs(tb(j,ibox)-at(j,k1))/atd + ptop(j,ibox) = exp(logp) + if(abs(pfull(j,k1)-ptop(j,ibox)) .lt. + & abs(pfull(j,k2)-ptop(j,ibox))) then + levmatch(j,ibox)=k1 + else + levmatch(j,ibox)=k2 + end if + else + if (tb(j,ibox) .le. attrop(j)) then + ptop(j,ibox)=ptrop(j) + levmatch(j,ibox)=itrop(j) + end if + if (tb(j,ibox) .ge. atmax(j)) then + ptop(j,ibox)=pfull(j,nlev) + levmatch(j,ibox)=nlev + end if + end if + enddo ! j + + else ! if (top_height .eq. 1 .or. top_height .eq. 3) + + do j=1,npoints + ptop(j,ibox)=0. + enddo + do ilev=1,nlev + do j=1,npoints + if ((ptop(j,ibox) .eq. 0. ) + & .and.(frac_out(j,ibox,ilev) .ne. 0)) then + ptop(j,ibox)=phalf(j,ilev) + levmatch(j,ibox)=ilev + end if + end do + end do + end if + + do j=1,npoints + if (tau(j,ibox) .le. (tauchk )) then + ptop(j,ibox)=0. + levmatch(j,ibox)=0 + endif + enddo + +30 continue + +! +! +! ---------------------------------------------------! + + +! +! ---------------------------------------------------! +! DETERMINE ISCCP CLOUD TYPE FREQUENCIES +! +! Now that ptop and tau have been determined, +! determine amount of each of the 49 ISCCP cloud +! types +! +! Also compute grid box mean cloud top pressure and +! optical thickness. The mean cloud top pressure and +! optical thickness are averages over the cloudy +! area only. The mean cloud top pressure is a linear +! average of the cloud top pressures. The mean cloud +! optical thickness is computed by converting optical +! thickness to an albedo, averaging in albedo units, +! then converting the average albedo back to a mean +! optical thickness. +! + + !compute isccp frequencies + + !reset frequencies + do 38 ilev=1,7 + do 38 ilev2=1,7 + do j=1,npoints ! + if (sunlit(j).eq.1 .or. top_height .eq. 3) then + fq_isccp(j,ilev,ilev2)= 0. + else + fq_isccp(j,ilev,ilev2)= output_missing_value + end if + enddo +38 continue + + !reset variables need for averaging cloud properties + do j=1,npoints + if (sunlit(j).eq.1 .or. top_height .eq. 3) then + totalcldarea(j) = 0. + meanalbedocld(j) = 0. + meanptop(j) = 0. + meantaucld(j) = 0. + else + totalcldarea(j) = output_missing_value + meanalbedocld(j) = output_missing_value + meanptop(j) = output_missing_value + meantaucld(j) = output_missing_value + end if + enddo ! j + + boxarea = 1./real(ncol) + + do 39 ibox=1,ncol + do j=1,npoints + + if (tau(j,ibox) .gt. (tauchk ) + & .and. ptop(j,ibox) .gt. 0.) then + box_cloudy(j,ibox)=.true. + endif + + if (box_cloudy(j,ibox)) then + + if (sunlit(j).eq.1 .or. top_height .eq. 3) then + + boxtau(j,ibox) = tau(j,ibox) + + if (tau(j,ibox) .ge. isccp_taumin) then + totalcldarea(j) = totalcldarea(j) + boxarea + + !convert optical thickness to albedo + albedocld(j,ibox) + & = (tau(j,ibox)**0.895)/((tau(j,ibox)**0.895)+6.82) + + !contribute to averaging + meanalbedocld(j) = meanalbedocld(j) + & +albedocld(j,ibox)*boxarea + + end if + + endif + + endif + + if (sunlit(j).eq.1 .or. top_height .eq. 3) then + + if (box_cloudy(j,ibox)) then + + !convert ptop to millibars + ptop(j,ibox)=ptop(j,ibox) / 100. + + !save for output cloud top pressure and optical thickness + boxptop(j,ibox) = ptop(j,ibox) + + if (tau(j,ibox) .ge. isccp_taumin) then + meanptop(j) = meanptop(j) + ptop(j,ibox)*boxarea + end if + + !reset itau(j), ipres(j) + itau(j) = 0 + ipres(j) = 0 + + !determine optical depth category + if (tau(j,ibox) .lt. isccp_taumin) then + itau(j)=1 + else if (tau(j,ibox) .ge. isccp_taumin + & + & .and. tau(j,ibox) .lt. 1.3) then + itau(j)=2 + else if (tau(j,ibox) .ge. 1.3 + & .and. tau(j,ibox) .lt. 3.6) then + itau(j)=3 + else if (tau(j,ibox) .ge. 3.6 + & .and. tau(j,ibox) .lt. 9.4) then + itau(j)=4 + else if (tau(j,ibox) .ge. 9.4 + & .and. tau(j,ibox) .lt. 23.) then + itau(j)=5 + else if (tau(j,ibox) .ge. 23. + & .and. tau(j,ibox) .lt. 60.) then + itau(j)=6 + else if (tau(j,ibox) .ge. 60.) then + itau(j)=7 + end if + + !determine cloud top pressure category + if ( ptop(j,ibox) .gt. 0. + & .and.ptop(j,ibox) .lt. 180.) then + ipres(j)=1 + else if(ptop(j,ibox) .ge. 180. + & .and.ptop(j,ibox) .lt. 310.) then + ipres(j)=2 + else if(ptop(j,ibox) .ge. 310. + & .and.ptop(j,ibox) .lt. 440.) then + ipres(j)=3 + else if(ptop(j,ibox) .ge. 440. + & .and.ptop(j,ibox) .lt. 560.) then + ipres(j)=4 + else if(ptop(j,ibox) .ge. 560. + & .and.ptop(j,ibox) .lt. 680.) then + ipres(j)=5 + else if(ptop(j,ibox) .ge. 680. + & .and.ptop(j,ibox) .lt. 800.) then + ipres(j)=6 + else if(ptop(j,ibox) .ge. 800.) then + ipres(j)=7 + end if + + !update frequencies + if(ipres(j) .gt. 0.and.itau(j) .gt. 0) then + fq_isccp(j,itau(j),ipres(j))= + & fq_isccp(j,itau(j),ipres(j))+ boxarea + end if + + end if + + end if + + enddo ! j +39 continue + + !compute mean cloud properties + do j=1,npoints + if (totalcldarea(j) .gt. 0.) then + ! code above guarantees that totalcldarea > 0 + ! only if sunlit .eq. 1 .or. top_height = 3 + ! and applies only to clouds with tau > isccp_taumin + meanptop(j) = meanptop(j) / totalcldarea(j) + meanalbedocld(j) = meanalbedocld(j) / totalcldarea(j) + meantaucld(j) = (6.82/((1./meanalbedocld(j))-1.))**(1./0.895) + else + ! this code is necessary so that in the case that totalcldarea = 0., + ! that these variables, which are in-cloud averages, are set to missing + ! note that totalcldarea will be 0. if all the clouds in the grid box have + ! tau < isccp_taumin + meanptop(j) = output_missing_value + meanalbedocld(j) = output_missing_value + meantaucld(j) = output_missing_value + end if + enddo ! j +! +! ---------------------------------------------------! + +! ---------------------------------------------------! +! OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM +! + if (debugcol.ne.0) then +! + do j=1,npoints,debugcol + + !produce character output + do ilev=1,nlev + do ibox=1,ncol + acc(ilev,ibox)=0 + enddo + enddo + + do ilev=1,nlev + do ibox=1,ncol + acc(ilev,ibox)=frac_out(j,ibox,ilev)*2 + if (levmatch(j,ibox) .eq. ilev) + & acc(ilev,ibox)=acc(ilev,ibox)+1 + enddo + enddo + + !print test + + write(ftn09,11) j +11 format('ftn09.',i4.4) + open(9, FILE=ftn09, FORM='FORMATTED') + + write(9,'(a1)') ' ' + write(9,'(10i5)') + & (ilev,ilev=5,nlev,5) + write(9,'(a1)') ' ' + + do ibox=1,ncol + write(9,'(40(a1),1x,40(a1))') + & (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev) + & ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev) + end do + close(9) + + if (ncolprint.ne.0) then + write(6,'(a1)') ' ' + write(6,'(a2,1X,5(a7,1X),a50)') + & 'ilev', + & 'pfull','at', + & 'cc*100','dem_s','dtau_s', + & 'cchar' + +! do 4012 ilev=1,nlev +! write(6,'(60i2)') (box(i,ilev),i=1,ncolprint) +! write(6,'(i2,1X,5(f7.2,1X),50(a1))') +! & ilev, +! & pfull(j,ilev)/100.,at(j,ilev), +! & cc(j,ilev)*100.0,dem_s(j,ilev),dtau_s(j,ilev) +! & ,(cchar(acc(ilev,ibox)+1),ibox=1,ncolprint) +!4012 continue + write (6,'(a)') 'skt(j):' + write (6,'(8f7.2)') skt(j) + + write (6,'(8I7)') (ibox,ibox=1,ncolprint) + + write (6,'(a)') 'tau:' + write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'tb:' + write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'ptop:' + write (6,'(8f7.2)') (ptop(j,ibox),ibox=1,ncolprint) + endif + + enddo + + end if + + return + end + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/ini_histdayCOSP.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/ini_histdayCOSP.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/ini_histdayCOSP.h (revision 1280) @@ -0,0 +1,192 @@ +! Abderrahmane Idelkadi Septebmre 2009 +! Sorties journalieres de COSP +! Pour l'instant sorties Lidar et ISCCP +! +! sorties par jour +! + zstoday = ecrit_day + zout = freq_COSP +! +! PRINT*, 'La frequence de sortie hf3d est de ', ecrit_hf +! + + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) + + CALL histbeg_phy("histdayCOSP",itau_phy,zjulian,dtime,nhori,nid_day_cosp) + +! Definition de l'axe vertical + CALL histvert(nid_day_cosp,"height","height","m",Nlevout,vgrid%z,nvert) + print*,'Ok height Nlevout, height =',Nlevout,vgrid%z + CALL histvert(nid_day_cosp,"height_mlev","height_mlev","m",Nlevlmdz,vgrid%mz,nvertm) + print*,'Ok height_mlev Nlevout, height_mlev =',Nlevout,vgrid%mz +! CALL histvert(nid_day_cosp,"presnivs","Vertical levels","mb",Nlevout,presnivs,nvert) + + CALL histvert(nid_day_cosp,"sza","solar_zenith_angle","degrees",PARASOL_NREFL,PARASOL_SZA,nvertp) + + CALL histvert(nid_day_cosp,"pressure2","pressure","mb",7,ISCCP_PC,nvertisccp) + + CALL histvert(nid_day_cosp,"column","column","count",Ncolumns,column_ax,nvertcol) + +! Sorties LIDAR + if (cfg%Llidar_sim) then + if (cfg%Lcllcalipso) then + CALL histdef(nid_day_cosp, "cllcalipso", & + "Lidar Low-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lclhcalipso) then + CALL histdef(nid_day_cosp, "clhcalipso", & + "Lidar High-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lclmcalipso) then + CALL histdef(nid_day_cosp, "clmcalipso", & + "Lidar Mid-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lcltcalipso) then + CALL histdef(nid_day_cosp, "cltcalipso", & + "Lidar Total Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lclcalipso) then + CALL histdef(nid_day_cosp, "clcalipso", & + "Lidar Cloud Fraction (532 nm)", "1", & + iim,jj_nb,nhori, Nlevout,1,Nlevout,nvert, 32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lcfad_lidarsr532) then + do ii=1,SR_BINS + CALL histdef(nid_day_cosp, "cfad_lidarsr532_"//chcol(ii), & + "Lidar Scattering Ratio CFAD (532 nm)","1", & + iim,jj_nb,nhori, Nlevout,1,Nlevout,nvert, 32, & + "ave(X)", zout,zstoday) + enddo + endif + if (cfg%Lparasol_refl) then + CALL histdef(nid_day_cosp, "parasol_refl", & + "PARASOL-like mono-directional reflectance","1", & + iim,jj_nb,nhori, PARASOL_NREFL,1, PARASOL_NREFL, nvertp,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Latb532) then + do ii=1,Ncolumns + CALL histdef(nid_day_cosp, "atb532_"//chcol(ii), & + "Lidar Attenuated Total Backscatter (532 nm)","1", & + iim,jj_nb,nhori, Nlevlmdz,1,Nlevlmdz,nvertm, 32, & + "ave(X)", zout,zstoday) + enddo + endif + if (cfg%Lbeta_mol532) then + CALL histdef(nid_day_cosp, "beta_mol532", & + "Lidar Molecular Backscatter (532 nm)","m-1 sr-1", & + iim,jj_nb,nhori, Nlevlmdz,1,Nlevlmdz,nvertm, 32, & + "ave(X)", zout,zstoday) + endif + endif ! Lidar + +! Sorties RADAR +!Attention A FAIRE +! if (cfg%Lradar_sim) then +! print*,'Ecriture sorties Radar' +! if (cfg%Lcfad_dbze94) then +! print*,'Ecriture de cfad_dbze94.nc ' +! A revoir l axe vertical Nlvgrid +! do ii=1,DBZE_BINS +! dbze_ax(ii) = CFAD_ZE_MIN + CFAD_ZE_WIDTH*(ii - 0.5) +! enddo +! call write_netcdf4d('cfad_dbze94.nc',use_vgrid,nlon,nlat,Nlevout,DBZE_BINS, & +! x,y,out_levs,dbze_ax,i,ndays,time,stradar%cfad_ze) +! endif +! if (cfg%Lclcalipso2) then +! call write_netcdf3d('clcalipso2.nc',use_vgrid,'clcalipso2', & +! nlon,nlat,Nlevout,x,y,out_levs,i,ndays,time,stradar%lidar_only_freq_cloud) +! endif +! if (cfg%Ldbze94) then +! do ii=1,Ncolumns +! xcol(ii)=float(i) +! enddo +! call write_netcdf4d('dbze94.nc',use_vgrid,nlon,nlat,Nlevout,Ncolumns, & +! x,y,out_levs,xcol,i,ndays,time,sgradar%Ze_tot) +! endif +! if (cfg%Lcltlidarradar) then +! call write_netcdf2d('cltlidarradar.nc','cltlidarradar', & +! nlon,nlat,x,y,i,ndays,time,stradar%radar_lidar_tcc) +! endif +! endif ! Radar + +! Sorties MISR +!Attention A FAIRE +! if (cfg%Lmisr_sim) then +! print*,'Ecriture sorties Misr' +! call write_netcdf4d('clMISR.nc',use_vgrid,nlon,nlat,MISR_N_CTH,7, & +! x,y,MISR_CTH,ISCCP_TAU,i,ndays,time,misr%fq_MISR) +! endif + +! Sorties ISCCP + if (cfg%Lisccp_sim) then + if (cfg%Lclisccp2) then + do ii=1,7 + CALL histdef(nid_day_cosp, "clisccp2_"//chcol(ii), & + "Cloud Fraction as Calculated by the ISCCP Simulator","1", & + iim,jj_nb,nhori,7,1,7,nvertisccp, 32, & + "ave(X)", zout,zstoday) + enddo + endif + if (cfg%Lboxtauisccp) then + CALL histdef(nid_day_cosp, "boxtauisccp", & + "Optical Depth in Each Column as Calculated by the ISCCP Simulator","1", & + iim,jj_nb,nhori,Ncolumns,1,Ncolumns,nvertcol, 32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lboxptopisccp) then + CALL histdef(nid_day_cosp, "boxptopisccp", & + "Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator","Pa", & + iim,jj_nb,nhori,Ncolumns,1,Ncolumns,nvertcol, 32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Ltclisccp) then + CALL histdef(nid_day_cosp, "tclisccp", & + "Total Cloud Fraction as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lctpisccp) then + CALL histdef(nid_day_cosp, "ctpisccp", & + "Mean Cloud Top Pressure as Calculated by the ISCCP Simulator", "Pa", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Ltauisccp) then + CALL histdef(nid_day_cosp, "tauisccp", & + "Optical Depth as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lalbisccp) then + CALL histdef(nid_day_cosp, "albisccp", & + "Mean Cloud Albedo as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lmeantbisccp) then + CALL histdef(nid_day_cosp, "meantbisccp", & + " Mean all-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator","K", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lmeantbclrisccp) then + CALL histdef(nid_day_cosp, "meantbclrisccp", & + "Mean clear-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator","K", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + endif ! Isccp + + + CALL histend(nid_day_cosp) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/ini_histhfCOSP.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/ini_histhfCOSP.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/ini_histhfCOSP.h (revision 1280) @@ -0,0 +1,192 @@ +! Abderrahmane Idelkadi Septebmre 2009 +! Sorties journalieres de COSP +! Pour l'instant sorties Lidar et ISCCP +! +! sorties par jour +! + zstohf = ecrit_hf + zout = freq_COSP +! +! PRINT*, 'La frequence de sortie hf3d est de ', ecrit_hf +! + + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) + + CALL histbeg_phy("histhfCOSP",itau_phy,zjulian,dtime,nhori,nid_hf_cosp) + +! Definition de l'axe vertical + CALL histvert(nid_hf_cosp,"height","height","m",Nlevout,vgrid%z,nvert) + print*,'Ok height Nlevout, height =',Nlevout,vgrid%z + CALL histvert(nid_hf_cosp,"height_mlev","height_mlev","m",Nlevlmdz,vgrid%mz,nvertm) + print*,'Ok height_mlev Nlevout height_mlev =',Nlevout,vgrid%mz +! CALL histvert(nid_hf_cosp,"presnivs","Vertical levels","mb",Nlevout,presnivs,nvert) + + CALL histvert(nid_hf_cosp,"sza","solar_zenith_angle","degrees",PARASOL_NREFL,PARASOL_SZA,nvertp) + + CALL histvert(nid_hf_cosp,"pressure2","pressure","mb",7,ISCCP_PC,nvertisccp) + + CALL histvert(nid_hf_cosp,"column","column","count",Ncolumns,column_ax,nvertcol) + +! Sorties LIDAR + if (cfg%Llidar_sim) then + if (cfg%Lcllcalipso) then + CALL histdef(nid_hf_cosp, "cllcalipso", & + "Lidar Low-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lclhcalipso) then + CALL histdef(nid_hf_cosp, "clhcalipso", & + "Lidar High-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lclmcalipso) then + CALL histdef(nid_hf_cosp, "clmcalipso", & + "Lidar Mid-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lcltcalipso) then + CALL histdef(nid_hf_cosp, "cltcalipso", & + "Lidar Total Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lclcalipso) then + CALL histdef(nid_hf_cosp, "clcalipso", & + "Lidar Cloud Fraction (532 nm)", "1", & + iim,jj_nb,nhori, Nlevout,1,Nlevout,nvert, 32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lcfad_lidarsr532) then + do ii=1,SR_BINS + CALL histdef(nid_hf_cosp, "cfad_lidarsr532_"//chcol(ii), & + "Lidar Scattering Ratio CFAD (532 nm)","1", & + iim,jj_nb,nhori, Nlevout,1,Nlevout,nvert, 32, & + "ave(X)", zout,zstohf) + enddo + endif + if (cfg%Lparasol_refl) then + CALL histdef(nid_hf_cosp, "parasol_refl", & + "PARASOL-like mono-directional reflectance","1", & + iim,jj_nb,nhori, PARASOL_NREFL,1, PARASOL_NREFL, nvertp,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Latb532) then + do ii=1,Ncolumns + CALL histdef(nid_hf_cosp, "atb532_"//chcol(ii), & + "Lidar Attenuated Total Backscatter (532 nm)","1", & + iim,jj_nb,nhori, Nlevlmdz,1,Nlevlmdz,nvertm, 32, & + "ave(X)", zout,zstohf) + enddo + endif + if (cfg%Lbeta_mol532) then + CALL histdef(nid_hf_cosp, "beta_mol532", & + "Lidar Molecular Backscatter (532 nm)","m-1 sr-1", & + iim,jj_nb,nhori, Nlevlmdz,1,Nlevlmdz,nvertm, 32, & + "ave(X)", zout,zstohf) + endif + endif ! Lidar + +! Sorties RADAR +!Attention A FAIRE +! if (cfg%Lradar_sim) then +! print*,'Ecriture sorties Radar' +! if (cfg%Lcfad_dbze94) then +! print*,'Ecriture de cfad_dbze94.nc ' +! A revoir l axe vertical Nlvgrid +! do ii=1,DBZE_BINS +! dbze_ax(ii) = CFAD_ZE_MIN + CFAD_ZE_WIDTH*(ii - 0.5) +! enddo +! call write_netcdf4d('cfad_dbze94.nc',use_vgrid,nlon,nlat,Nlevout,DBZE_BINS, & +! x,y,out_levs,dbze_ax,i,ndays,time,stradar%cfad_ze) +! endif +! if (cfg%Lclcalipso2) then +! call write_netcdf3d('clcalipso2.nc',use_vgrid,'clcalipso2', & +! nlon,nlat,Nlevout,x,y,out_levs,i,ndays,time,stradar%lidar_only_freq_cloud) +! endif +! if (cfg%Ldbze94) then +! do ii=1,Ncolumns +! xcol(ii)=float(i) +! enddo +! call write_netcdf4d('dbze94.nc',use_vgrid,nlon,nlat,Nlevout,Ncolumns, & +! x,y,out_levs,xcol,i,ndays,time,sgradar%Ze_tot) +! endif +! if (cfg%Lcltlidarradar) then +! call write_netcdf2d('cltlidarradar.nc','cltlidarradar', & +! nlon,nlat,x,y,i,ndays,time,stradar%radar_lidar_tcc) +! endif +! endif ! Radar + +! Sorties MISR +!Attention A FAIRE +! if (cfg%Lmisr_sim) then +! print*,'Ecriture sorties Misr' +! call write_netcdf4d('clMISR.nc',use_vgrid,nlon,nlat,MISR_N_CTH,7, & +! x,y,MISR_CTH,ISCCP_TAU,i,ndays,time,misr%fq_MISR) +! endif + +! Sorties ISCCP + if (cfg%Lisccp_sim) then + if (cfg%Lclisccp2) then + do ii=1,7 + CALL histdef(nid_hf_cosp, "clisccp2_"//chcol(ii), & + "Cloud Fraction as Calculated by the ISCCP Simulator","1", & + iim,jj_nb,nhori,7,1,7,nvertisccp, 32, & + "ave(X)", zout,zstohf) + enddo + endif + if (cfg%Lboxtauisccp) then + CALL histdef(nid_hf_cosp, "boxtauisccp", & + "Optical Depth in Each Column as Calculated by the ISCCP Simulator","1", & + iim,jj_nb,nhori,Ncolumns,1,Ncolumns,nvertcol, 32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lboxptopisccp) then + CALL histdef(nid_hf_cosp, "boxptopisccp", & + "Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator","Pa", & + iim,jj_nb,nhori,Ncolumns,1,Ncolumns,nvertcol, 32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Ltclisccp) then + CALL histdef(nid_hf_cosp, "tclisccp", & + "Total Cloud Fraction as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lctpisccp) then + CALL histdef(nid_hf_cosp, "ctpisccp", & + "Mean Cloud Top Pressure as Calculated by the ISCCP Simulator", "Pa", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Ltauisccp) then + CALL histdef(nid_hf_cosp, "tauisccp", & + "Optical Depth as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lalbisccp) then + CALL histdef(nid_hf_cosp, "albisccp", & + "Mean Cloud Albedo as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lmeantbisccp) then + CALL histdef(nid_hf_cosp, "meantbisccp", & + " Mean all-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator","K", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lmeantbclrisccp) then + CALL histdef(nid_hf_cosp, "meantbclrisccp", & + "Mean clear-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator","K", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + endif ! Isccp + + + CALL histend(nid_hf_cosp) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/ini_histmthCOSP.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/ini_histmthCOSP.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/ini_histmthCOSP.h (revision 1280) @@ -0,0 +1,190 @@ +! Abderrahmane Idelkadi Septebmre 2009 +! Sorties journalieres de COSP +! Pour l'instant sorties Lidar et ISCCP +! +! sorties par jour +! + zstomth = ecrit_mth + zout = freq_COSP +! +! PRINT*, 'La frequence de sortie hf3d est de ', ecrit_hf +! + + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) + + CALL histbeg_phy("histmthCOSP",itau_phy,zjulian,dtime,nhori,nid_mth_cosp) + +! Definition de l'axe vertical + CALL histvert(nid_mth_cosp,"height","height","m",Nlevout,vgrid%z,nvert) + CALL histvert(nid_mth_cosp,"height_mlev","height_mlev","m",Nlevlmdz,vgrid%mz,nvertm) +! CALL histvert(nid_mth_cosp,"presnivs","Vertical levels","mb",Nlevout,presnivs,nvert) + + CALL histvert(nid_mth_cosp,"sza","solar_zenith_angle","degrees",PARASOL_NREFL,PARASOL_SZA,nvertp) + + CALL histvert(nid_mth_cosp,"pressure2","pressure","mb",7,ISCCP_PC,nvertisccp) + + CALL histvert(nid_mth_cosp,"column","column","count",Ncolumns,column_ax,nvertcol) + +! Sorties LIDAR + if (cfg%Llidar_sim) then + if (cfg%Lcllcalipso) then + CALL histdef(nid_mth_cosp, "cllcalipso", & + "Lidar Low-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lclhcalipso) then + CALL histdef(nid_mth_cosp, "clhcalipso", & + "Lidar High-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lclmcalipso) then + CALL histdef(nid_mth_cosp, "clmcalipso", & + "Lidar Mid-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lcltcalipso) then + CALL histdef(nid_mth_cosp, "cltcalipso", & + "Lidar Total Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lclcalipso) then + CALL histdef(nid_mth_cosp, "clcalipso", & + "Lidar Cloud Fraction (532 nm)", "1", & + iim,jj_nb,nhori, Nlevout,1,Nlevout,nvert, 32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lcfad_lidarsr532) then + do ii=1,SR_BINS + CALL histdef(nid_mth_cosp, "cfad_lidarsr532_"//chcol(ii), & + "Lidar Scattering Ratio CFAD (532 nm)","1", & + iim,jj_nb,nhori, Nlevout,1,Nlevout,nvert, 32, & + "ave(X)", zout,zstomth) + enddo + endif + if (cfg%Lparasol_refl) then + CALL histdef(nid_mth_cosp, "parasol_refl", & + "PARASOL-like mono-directional reflectance","1", & + iim,jj_nb,nhori, PARASOL_NREFL,1, PARASOL_NREFL, nvertp,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Latb532) then + do ii=1,Ncolumns + CALL histdef(nid_mth_cosp, "atb532_"//chcol(ii), & + "Lidar Attenuated Total Backscatter (532 nm)","1", & + iim,jj_nb,nhori, Nlevlmdz,1,Nlevlmdz,nvertm, 32, & + "ave(X)", zout,zstomth) + enddo + endif + if (cfg%Lbeta_mol532) then + CALL histdef(nid_mth_cosp, "beta_mol532", & + "Lidar Molecular Backscatter (532 nm)","m-1 sr-1", & + iim,jj_nb,nhori, Nlevlmdz,1,Nlevlmdz,nvertm, 32, & + "ave(X)", zout,zstomth) + endif + endif ! Lidar + +! Sorties RADAR +!Attention A FAIRE +! if (cfg%Lradar_sim) then +! print*,'Ecriture sorties Radar' +! if (cfg%tttttttttttt) then +! print*,'Ecriture de cfad_dbze94.nc ' +! A revoir l axe vertical Nlvgrid +! do ii=1,DBZE_BINS +! dbze_ax(ii) = CFAD_ZE_MIN + CFAD_ZE_WIDTH*(ii - 0.5) +! enddo +! call write_netcdf4d('cfad_dbze94.nc',use_vgrid,nlon,nlat,Nlevout,DBZE_BINS, & +! x,y,out_levs,dbze_ax,i,ndays,time,stradar%cfad_ze) +! endif +! if (cfg%Lclcalipso2) then +! call write_netcdf3d('clcalipso2.nc',use_vgrid,'clcalipso2', & +! nlon,nlat,Nlevout,x,y,out_levs,i,ndays,time,stradar%lidar_only_freq_cloud) +! endif +! if (cfg%Ldbze94) then +! do ii=1,Ncolumns +! xcol(ii)=float(i) +! enddo +! call write_netcdf4d('dbze94.nc',use_vgrid,nlon,nlat,Nlevout,Ncolumns, & +! x,y,out_levs,xcol,i,ndays,time,sgradar%Ze_tot) +! endif +! if (cfg%Lcltlidarradar) then +! call write_netcdf2d('cltlidarradar.nc','cltlidarradar', & +! nlon,nlat,x,y,i,ndays,time,stradar%radar_lidar_tcc) +! endif +! endif ! Radar + +! Sorties MISR +!Attention A FAIRE +! if (cfg%Lmisr_sim) then +! print*,'Ecriture sorties Misr' +! call write_netcdf4d('clMISR.nc',use_vgrid,nlon,nlat,MISR_N_CTH,7, & +! x,y,MISR_CTH,ISCCP_TAU,i,ndays,time,misr%fq_MISR) +! endif + +! Sorties ISCCP + if (cfg%Lisccp_sim) then + if (cfg%Lclisccp2) then + do ii=1,7 + CALL histdef(nid_mth_cosp, "clisccp2_"//chcol(ii), & + "Cloud Fraction as Calculated by the ISCCP Simulator","1", & + iim,jj_nb,nhori,7,1,7,nvertisccp, 32, & + "ave(X)", zout,zstomth) + enddo + endif + if (cfg%Lboxtauisccp) then + CALL histdef(nid_mth_cosp, "boxtauisccp", & + "Optical Depth in Each Column as Calculated by the ISCCP Simulator","1", & + iim,jj_nb,nhori,Ncolumns,1,Ncolumns,nvertcol, 32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lboxptopisccp) then + CALL histdef(nid_mth_cosp, "boxptopisccp", & + "Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator","Pa", & + iim,jj_nb,nhori,Ncolumns,1,Ncolumns,nvertcol, 32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Ltclisccp) then + CALL histdef(nid_mth_cosp, "tclisccp", & + "Total Cloud Fraction as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lctpisccp) then + CALL histdef(nid_mth_cosp, "ctpisccp", & + "Mean Cloud Top Pressure as Calculated by the ISCCP Simulator", "Pa", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Ltauisccp) then + CALL histdef(nid_mth_cosp, "tauisccp", & + "Optical Depth as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lalbisccp) then + CALL histdef(nid_mth_cosp, "albisccp", & + "Mean Cloud Albedo as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lmeantbisccp) then + CALL histdef(nid_mth_cosp, "meantbisccp", & + " Mean all-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator","K", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lmeantbclrisccp) then + CALL histdef(nid_mth_cosp, "meantbclrisccp", & + "Mean clear-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator","K", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + endif ! Isccp + + + CALL histend(nid_mth_cosp) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/lidar_simulator.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/lidar_simulator.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/lidar_simulator.F90 (revision 1280) @@ -0,0 +1,553 @@ +! Copyright (c) 2009, Centre National de la Recherche Scientifique +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the LMD/IPSL/CNRS/UPMC nor the names of its +! contributors may be used to endorse or promote products derived from this software without +! specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + SUBROUTINE lidar_simulator(npoints,nlev,npart,nrefl & + , undef & + , pres, presf, temp & + , q_lsliq, q_lsice, q_cvliq, q_cvice & + , ls_radliq, ls_radice, cv_radliq, cv_radice & + , frac_out, ice_type & + , pmol, pnorm, tautot, refl ) +! +!--------------------------------------------------------------------------------- +! Purpose: To compute lidar signal from model-simulated profiles of cloud water +! and cloud fraction in each sub-column of each model gridbox. +! +! References: +! Chepfer H., S. Bony, D. Winker, M. Chiriaco, J.-L. Dufresne, G. Seze (2008), +! Use of CALIPSO lidar observations to evaluate the cloudiness simulated by a +! climate model, Geophys. Res. Lett., 35, L15704, doi:10.1029/2008GL034207. +! +! Previous references: +! Chiriaco et al, MWR, 2006; Chepfer et al., MWR, 2007 +! +! Contacts: Helene Chepfer (chepfer@lmd.polytechnique.fr), Sandrine Bony (bony@lmd.jussieu.fr) +! +! May 2007: ActSim code of M. Chiriaco and H. Chepfer rewritten by S. Bony +! +! May 2008, H. Chepfer: +! - Units of pressure inputs: Pa +! - Non Spherical particles : LS Ice NS coefficients, CONV Ice NS coefficients +! - New input: ice_type (0=ice-spheres ; 1=ice-non-spherical) +! +! June 2008, A. Bodas-Salcedo: +! - Ported to Fortran 90 and optimisation changes +! +! August 2008, J-L Dufresne: +! - Optimisation changes (sum instructions suppressed) +! +! October 2008, S. Bony, H. Chepfer and J-L. Dufresne : +! - Interface with COSP v2.0: +! cloud fraction removed from inputs +! in-cloud condensed water now in input (instead of grid-averaged value) +! depolarisation diagnostic removed +! parasol (polder) reflectances (for 5 different solar zenith angles) added +! +! December 2008, S. Bony, H. Chepfer and J-L. Dufresne : +! - Modification of the integration of the lidar equation. +! - change the cloud detection threshold +! +! April 2008, A. Bodas-Salcedo: +! - Bug fix in computation of pmol and pnorm of upper layer +! +! April 2008, J-L. Dufresne +! - Bug fix in computation of pmol and pnorm, thanks to Masaki Satoh: a factor 2 +! was missing. This affects the ATB values but not the cloud fraction. +! +!--------------------------------------------------------------------------------- +! +! Inputs: +! npoints : number of horizontal points +! nlev : number of vertical levels +! npart: numberb of cloud meteors (stratiform_liq, stratiform_ice, conv_liq, conv_ice). +! Currently npart must be 4 +! nrefl: number of solar zenith angles for parasol reflectances +! pres : pressure in the middle of atmospheric layers (full levels): Pa +! presf: pressure in the interface of atmospheric layers (half levels): Pa +! presf(..,1) : surface pressure ; presf(..,nlev+1)= TOA pressure +! temp : temperature of atmospheric layers: K +! q_lsliq: LS sub-column liquid water mixing ratio (kg/kg) +! q_lsice: LS sub-column ice water mixing ratio (kg/kg) +! q_cvliq: CONV sub-column liquid water mixing ratio (kg/kg) +! q_cvice: CONV sub-column ice water mixing ratio (kg/kg) +! ls_radliq: effective radius of LS liquid particles (meters) +! ls_radice: effective radius of LS ice particles (meters) +! cv_radliq: effective radius of CONV liquid particles (meters) +! cv_radice: effective radius of CONV ice particles (meters) +! frac_out : cloud cover in each sub-column of the gridbox (output from scops) +! ice_type : ice particle shape hypothesis (ice_type=0 for spheres, ice_type=1 +! for non spherical particles) +! +! Outputs: +! pmol : molecular attenuated backscatter lidar signal power (m^-1.sr^-1) +! pnorm: total attenuated backscatter lidar signal power (m^-1.sr^-1) +! tautot: optical thickess integrated from top to level z +! refl : parasol(polder) reflectance +! +! Version 1.0 (June 2007) +! Version 1.1 (May 2008) +! Version 1.2 (June 2008) +! Version 2.0 (October 2008) +! Version 2.1 (December 2008) +!--------------------------------------------------------------------------------- + + IMPLICIT NONE + REAL :: SRsat + PARAMETER (SRsat = 0.01) ! threshold full attenuation + + LOGICAL ok_parasol + PARAMETER (ok_parasol=.true.) ! set to .true. if you want to activate parasol reflectances + + INTEGER i, k + + INTEGER INDX_LSLIQ,INDX_LSICE,INDX_CVLIQ,INDX_CVICE + PARAMETER (INDX_LSLIQ=1,INDX_LSICE=2,INDX_CVLIQ=3,INDX_CVICE=4) +! inputs: + INTEGER npoints,nlev,npart,ice_type + INTEGER nrefl + real undef ! undefined value + REAL pres(npoints,nlev) ! pressure full levels + REAL presf(npoints,nlev+1) ! pressure half levels + REAL temp(npoints,nlev) + REAL q_lsliq(npoints,nlev), q_lsice(npoints,nlev) + REAL q_cvliq(npoints,nlev), q_cvice(npoints,nlev) + REAL ls_radliq(npoints,nlev), ls_radice(npoints,nlev) + REAL cv_radliq(npoints,nlev), cv_radice(npoints,nlev) + REAL frac_out(npoints,nlev) + +! outputs (for each subcolumn): + + REAL pmol(npoints,nlev) ! molecular backscatter signal power (m^-1.sr^-1) + REAL pnorm(npoints,nlev) ! total lidar backscatter signal power (m^-1.sr^-1) + REAL tautot(npoints,nlev)! optical thickess integrated from top + REAL refl(npoints,nrefl)! parasol reflectance ! parasol + +! actsim variables: + + REAL km, rdiffm, Qscat, Cmol + PARAMETER (Cmol = 6.2446e-32) ! depends on wavelength + PARAMETER (km = 1.38e-23) ! Boltzmann constant (J/K) + + PARAMETER (rdiffm = 0.7) ! multiple scattering correction parameter + PARAMETER (Qscat = 2.0) ! particle scattering efficiency at 532 nm + + REAL rholiq, rhoice + PARAMETER (rholiq=1.0e+03) ! liquid water (kg/m3) + PARAMETER (rhoice=0.5e+03) ! ice (kg/m3) + + REAL pi, rhopart(npart) + REAL polpart(npart,5) ! polynomial coefficients derived for spherical and non spherical + ! particules + +! grid-box variables: + REAL rad_part(npoints,nlev,npart) + REAL rhoair(npoints,nlev), zheight(npoints,nlev+1) + REAL beta_mol(npoints,nlev), alpha_mol(npoints,nlev) + REAL kp_part(npoints,nlev,npart) + +! sub-column variables: + REAL frac_sub(npoints,nlev) + REAL qpart(npoints,nlev,npart) ! mixing ratio particles in each subcolumn + REAL alpha_part(npoints,nlev,npart) + REAL tau_mol_lay(npoints) ! temporary variable, moL. opt. thickness of layer k + REAL tau_mol(npoints,nlev) ! optical thickness between TOA and bottom of layer k + REAL tau_part(npoints,nlev,npart) + REAL betatot(npoints,nlev) + REAL tautot_lay(npoints) ! temporary variable, total opt. thickness of layer k +! Optical thickness from TOA to surface for Parasol + REAL tautot_S_liq(npoints),tautot_S_ice(npoints) ! for liq and ice clouds + + +!------------------------------------------------------------ +!---- 1. Preliminary definitions and calculations : +!------------------------------------------------------------ + + if ( npart .ne. 4 ) then + print *,'Error in lidar_simulator, npart should be 4, not',npart + stop + endif + + pi = dacos(-1.D0) + +! Polynomial coefficients for spherical liq/ice particles derived from Mie theory. +! Polynomial coefficients for non spherical particles derived from a composite of +! Ray-tracing theory for large particles (e.g. Noel et al., Appl. Opt., 2001) +! and FDTD theory for very small particles (Yang et al., JQSRT, 2003). + +! We repeat the same coefficients for LS and CONV cloud to make code more readable +!* LS Liquid water coefficients: + polpart(INDX_LSLIQ,1) = 2.6980e-8 + polpart(INDX_LSLIQ,2) = -3.7701e-6 + polpart(INDX_LSLIQ,3) = 1.6594e-4 + polpart(INDX_LSLIQ,4) = -0.0024 + polpart(INDX_LSLIQ,5) = 0.0626 +!* LS Ice coefficients: + if (ice_type.eq.0) then + polpart(INDX_LSICE,1) = -1.0176e-8 + polpart(INDX_LSICE,2) = 1.7615e-6 + polpart(INDX_LSICE,3) = -1.0480e-4 + polpart(INDX_LSICE,4) = 0.0019 + polpart(INDX_LSICE,5) = 0.0460 + endif +!* LS Ice NS coefficients: + if (ice_type.eq.1) then + polpart(INDX_LSICE,1) = 1.3615e-8 + polpart(INDX_LSICE,2) = -2.04206e-6 + polpart(INDX_LSICE,3) = 7.51799e-5 + polpart(INDX_LSICE,4) = 0.00078213 + polpart(INDX_LSICE,5) = 0.0182131 + endif +!* CONV Liquid water coefficients: + polpart(INDX_CVLIQ,1) = 2.6980e-8 + polpart(INDX_CVLIQ,2) = -3.7701e-6 + polpart(INDX_CVLIQ,3) = 1.6594e-4 + polpart(INDX_CVLIQ,4) = -0.0024 + polpart(INDX_CVLIQ,5) = 0.0626 +!* CONV Ice coefficients: + if (ice_type.eq.0) then + polpart(INDX_CVICE,1) = -1.0176e-8 + polpart(INDX_CVICE,2) = 1.7615e-6 + polpart(INDX_CVICE,3) = -1.0480e-4 + polpart(INDX_CVICE,4) = 0.0019 + polpart(INDX_CVICE,5) = 0.0460 + endif + if (ice_type.eq.1) then + polpart(INDX_CVICE,1) = 1.3615e-8 + polpart(INDX_CVICE,2) = -2.04206e-6 + polpart(INDX_CVICE,3) = 7.51799e-5 + polpart(INDX_CVICE,4) = 0.00078213 + polpart(INDX_CVICE,5) = 0.0182131 + endif + +! density: +!* clear-sky air: + rhoair = pres/(287.04*temp) + +!* liquid/ice particules: + rhopart(INDX_LSLIQ) = rholiq + rhopart(INDX_LSICE) = rhoice + rhopart(INDX_CVLIQ) = rholiq + rhopart(INDX_CVICE) = rhoice + +! effective radius particles: + rad_part(:,:,INDX_LSLIQ) = ls_radliq(:,:) + rad_part(:,:,INDX_LSICE) = ls_radice(:,:) + rad_part(:,:,INDX_CVLIQ) = cv_radliq(:,:) + rad_part(:,:,INDX_CVICE) = cv_radice(:,:) + rad_part(:,:,:)=MAX(rad_part(:,:,:),0.) + rad_part(:,:,:)=MIN(rad_part(:,:,:),70.0e-6) + +! altitude at half pressure levels: + zheight(:,1) = 0.0 + do k = 2, nlev+1 + zheight(:,k) = zheight(:,k-1) & + -(presf(:,k)-presf(:,k-1))/(rhoair(:,k-1)*9.81) + enddo + +! cloud fraction (0 or 1) in each sub-column: +! (if frac_out=1or2 -> frac_sub=1; if frac_out=0 -> frac_sub=0) + frac_sub = MIN( frac_out, 1.0 ) + +!------------------------------------------------------------ +!---- 2. Molecular alpha and beta: +!------------------------------------------------------------ + + beta_mol = pres/km/temp * Cmol + alpha_mol = 8.0*pi/3.0 * beta_mol + +!------------------------------------------------------------ +!---- 3. Particles alpha and beta: +!------------------------------------------------------------ + +! polynomes kp_lidar derived from Mie theory: + do i = 1, npart + where ( rad_part(:,:,i).gt.0.0) + kp_part(:,:,i) = & + polpart(i,1)*(rad_part(:,:,i)*1e6)**4 & + + polpart(i,2)*(rad_part(:,:,i)*1e6)**3 & + + polpart(i,3)*(rad_part(:,:,i)*1e6)**2 & + + polpart(i,4)*(rad_part(:,:,i)*1e6) & + + polpart(i,5) + elsewhere + kp_part(:,:,i) = 0. + endwhere + enddo + +! mixing ratio particules in each subcolumn: + qpart(:,:,INDX_LSLIQ) = q_lsliq(:,:) ! oct08 + qpart(:,:,INDX_LSICE) = q_lsice(:,:) ! oct08 + qpart(:,:,INDX_CVLIQ) = q_cvliq(:,:) ! oct08 + qpart(:,:,INDX_CVICE) = q_cvice(:,:) ! oct08 + +! alpha of particles in each subcolumn: + do i = 1, npart + where ( rad_part(:,:,i).gt.0.0) + alpha_part(:,:,i) = 3.0/4.0 * Qscat & + * rhoair(:,:) * qpart(:,:,i) & + / (rhopart(i) * rad_part(:,:,i) ) + elsewhere + alpha_part(:,:,i) = 0. + endwhere + enddo + +!------------------------------------------------------------ +!---- 4. Backscatter signal: +!------------------------------------------------------------ + +! optical thickness (molecular): +! opt. thick of each layer + tau_mol(:,1:nlev) = alpha_mol(:,1:nlev) & + & *(zheight(:,2:nlev+1)-zheight(:,1:nlev)) +! opt. thick from TOA + DO k = nlev-1, 1, -1 + tau_mol(:,k) = tau_mol(:,k) + tau_mol(:,k+1) + ENDDO + +! optical thickness (particles): + + tau_part = rdiffm * alpha_part + DO i = 1, npart +! opt. thick of each layer + tau_part(:,:,i) = tau_part(:,:,i) & + & * (zheight(:,2:nlev+1)-zheight(:,1:nlev) ) +! opt. thick from TOA + DO k = nlev-1, 1, -1 + tau_part(:,k,i) = tau_part(:,k,i) + tau_part(:,k+1,i) + ENDDO + ENDDO + +! molecular signal: +! Upper layer + pmol(:,nlev) = beta_mol(:,nlev) / (2.*tau_mol(:,nlev)) & + & * (1.-exp(-2.0*tau_mol(:,nlev))) +! Other layers + DO k= nlev-1, 1, -1 + tau_mol_lay(:) = tau_mol(:,k)-tau_mol(:,k+1) ! opt. thick. of layer k + WHERE (tau_mol_lay(:).GT.0.) + pmol(:,k) = beta_mol(:,k) * EXP(-2.0*tau_mol(:,k+1)) / (2.*tau_mol_lay(:)) & + & * (1.-exp(-2.0*tau_mol_lay(:))) + ELSEWHERE +! This must never happend, but just in case, to avoid div. by 0 + pmol(:,k) = beta_mol(:,k) * EXP(-2.0*tau_mol(:,k+1)) + END WHERE + END DO +! +! Total signal (molecular + particules): +! +! For performance reason on vector computers, the 2 following lines should not be used +! and should be replace by the later one. +! betatot(:,:) = beta_mol(:,:) + sum(kp_part*alpha_part,dim=3) +! tautot(:,:) = tau_mol(:,:) + sum(tau_part,dim=3) + betatot(:,:) = beta_mol(:,:) + tautot(:,:) = tau_mol(:,:) + DO i = 1, npart + betatot(:,:) = betatot(:,:) + kp_part(:,:,i)*alpha_part(:,:,i) + tautot(:,:) = tautot(:,:) + tau_part(:,:,i) + ENDDO ! i +! +! Upper layer + pnorm(:,nlev) = betatot(:,nlev) / (2.*tautot(:,nlev)) & + & * (1.-exp(-2.0*tautot(:,nlev))) +! Other layers + DO k= nlev-1, 1, -1 + tautot_lay(:) = tautot(:,k)-tautot(:,k+1) ! optical thickness of layer k + WHERE (tautot_lay(:).GT.0.) + pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1)) / (2.*tautot_lay(:)) & +!correc pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1)) & ! correc Satoh +!correc & / (2.0*tautot_lay(:)) & ! correc Satoh + & * (1.-EXP(-2.0*tautot_lay(:))) + ELSEWHERE +! This must never happend, but just in case, to avoid div. by 0 + pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1)) + END WHERE + END DO + +!-------- End computation Lidar -------------------------- + +!--------------------------------------------------------- +! Parasol/Polder module +! +! Purpose : Compute reflectance for one particular viewing direction +! and 5 solar zenith angles (calculation valid only over ocean) +! --------------------------------------------------------- + +! initialization: + refl(:,:) = 0.0 + +! activate parasol calculations: + if (ok_parasol) then + +! Optical thickness from TOA to surface + tautot_S_liq = 0. + tautot_S_ice = 0. + tautot_S_liq(:) = tautot_S_liq(:) & + + tau_part(:,1,1) + tau_part(:,1,3) + tautot_S_ice(:) = tautot_S_ice(:) & + + tau_part(:,1,2) + tau_part(:,1,4) + + call parasol(npoints,nrefl,undef & + ,tautot_S_liq,tautot_S_ice & + ,refl) + + endif ! ok_parasol + + END SUBROUTINE lidar_simulator +! +!--------------------------------------------------------------------------------- +! + SUBROUTINE parasol(npoints,nrefl,undef & + ,tautot_S_liq,tautot_S_ice & + ,refl) +!--------------------------------------------------------------------------------- +! Purpose: To compute Parasol reflectance signal from model-simulated profiles +! of cloud water and cloud fraction in each sub-column of each model +! gridbox. +! +! +! December 2008, S. Bony, H. Chepfer and J-L. Dufresne : +! - optimization for vectorization +! +! Version 2.0 (October 2008) +! Version 2.1 (December 2008) +!--------------------------------------------------------------------------------- + + IMPLICIT NONE + +! inputs + INTEGER npoints ! Number of horizontal gridpoints + INTEGER nrefl ! Number of angles for which the reflectance + ! is computed. Can not be greater then ntetas + REAL undef ! Undefined value. Currently not used + REAL tautot_S_liq(npoints) ! liquid water cloud optical thickness, + ! integrated from TOA to surface + REAL tautot_S_ice(npoints) ! same for ice water clouds only +! outputs + REAL refl(npoints,nrefl) ! Parasol reflectances +! +! Local variables + REAL tautot_S(npoints) ! cloud optical thickness, from TOA to surface + REAL frac_taucol_liq(npoints), frac_taucol_ice(npoints) + + REAL pi +! look up table variables: + INTEGER ny, it + INTEGER ntetas, nbtau ! number of angle and of optical thickness + ! of the look-up table + PARAMETER (ntetas=5, nbtau=7) + REAL aa(ntetas,nbtau-1), ab(ntetas,nbtau-1) + REAL ba(ntetas,nbtau-1), bb(ntetas,nbtau-1) + REAL tetas(ntetas),tau(nbtau) + REAL r_norm(ntetas) + REAL rlumA(ntetas,nbtau), rlumB(ntetas,nbtau) + REAL rlumA_mod(npoints,5), rlumB_mod(npoints,5) + + DATA tau /0., 1., 5., 10., 20., 50., 100./ + DATA tetas /0., 20., 40., 60., 80./ + +! Look-up table for spherical liquid particles: + DATA (rlumA(1,ny),ny=1,nbtau) /0.03, 0.090886, 0.283965, & + 0.480587, 0.695235, 0.908229, 1.0 / + DATA (rlumA(2,ny),ny=1,nbtau) /0.03, 0.072185, 0.252596, & + 0.436401, 0.631352, 0.823924, 0.909013 / + DATA (rlumA(3,ny),ny=1,nbtau) /0.03, 0.058410, 0.224707, & + 0.367451, 0.509180, 0.648152, 0.709554 / + DATA (rlumA(4,ny),ny=1,nbtau) /0.03, 0.052498, 0.175844, & + 0.252916, 0.326551, 0.398581, 0.430405 / + DATA (rlumA(5,ny),ny=1,nbtau) /0.03, 0.034730, 0.064488, & + 0.081667, 0.098215, 0.114411, 0.121567 / + +! Look-up table for ice particles: + DATA (rlumB(1,ny),ny=1,nbtau) /0.03, 0.092170, 0.311941, & + 0.511298, 0.712079 , 0.898243 , 0.976646 / + DATA (rlumB(2,ny),ny=1,nbtau) /0.03, 0.087082, 0.304293, & + 0.490879, 0.673565, 0.842026, 0.912966 / + DATA (rlumB(3,ny),ny=1,nbtau) /0.03, 0.083325, 0.285193, & + 0.430266, 0.563747, 0.685773, 0.737154 / + DATA (rlumB(4,ny),ny=1,nbtau) /0.03, 0.084935, 0.233450, & + 0.312280, 0.382376, 0.446371, 0.473317 / + DATA (rlumB(5,ny),ny=1,nbtau) /0.03, 0.054157, 0.089911, & + 0.107854, 0.124127, 0.139004, 0.145269 / + +!-------------------------------------------------------------------------------- +! Lum_norm=f(tetaS,tau_cloud) derived from adding-doubling calculations +! valid ONLY ABOVE OCEAN (albedo_sfce=5%) +! valid only in one viewing direction (theta_v=30�, phi_s-phi_v=320�) +! based on adding-doubling radiative transfer computation +! for tau values (0 to 100) and for tetas values (0 to 80) +! for 2 scattering phase functions: liquid spherical, ice non spherical + + IF ( nrefl.GT. ntetas ) THEN + PRINT *,'Error in lidar_simulator, nrefl should be less then ',ntetas,' not',nrefl + STOP + ENDIF + + rlumA_mod=0 + rlumB_mod=0 +! + pi = ACOS(-1.0) + r_norm(:)=1./ COS(pi/180.*tetas(:)) +! + tautot_S_liq(:)=MAX(tautot_S_liq(:),tau(1)) + tautot_S_ice(:)=MAX(tautot_S_ice(:),tau(1)) + tautot_S(:) = tautot_S_ice(:) + tautot_S_liq(:) +! +! relative fraction of the opt. thick due to liquid or ice clouds + WHERE (tautot_S(:) .GT. 0.) + frac_taucol_liq(:) = tautot_S_liq(:) / tautot_S(:) + frac_taucol_ice(:) = tautot_S_ice(:) / tautot_S(:) + ELSEWHERE + frac_taucol_liq(:) = 1. + frac_taucol_ice(:) = 0. + END WHERE + tautot_S(:)=MIN(tautot_S(:),tau(nbtau)) +! +! Linear interpolation : + + DO ny=1,nbtau-1 +! microphysics A (liquid clouds) + aA(:,ny) = (rlumA(:,ny+1)-rlumA(:,ny))/(tau(ny+1)-tau(ny)) + bA(:,ny) = rlumA(:,ny) - aA(:,ny)*tau(ny) +! microphysics B (ice clouds) + aB(:,ny) = (rlumB(:,ny+1)-rlumB(:,ny))/(tau(ny+1)-tau(ny)) + bB(:,ny) = rlumB(:,ny) - aB(:,ny)*tau(ny) + ENDDO +! + DO it=1,ntetas + DO ny=1,nbtau-1 + WHERE (tautot_S(:).GE.tau(ny).AND.tautot_S(:).LE.tau(ny+1)) + rlumA_mod(:,it) = aA(it,ny)*tautot_S(:) + bA(it,ny) + rlumB_mod(:,it) = aB(it,ny)*tautot_S(:) + bB(it,ny) + END WHERE + END DO + END DO +! + DO it=1,ntetas + refl(:,it) = frac_taucol_liq(:) * rlumA_mod(:,it) & + + frac_taucol_ice(:) * rlumB_mod(:,it) +! normalized radiance -> reflectance: + refl(:,it) = refl(:,it) * r_norm(it) + ENDDO + + RETURN + END SUBROUTINE parasol Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/llnl_stats.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/llnl_stats.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/llnl_stats.F90 (revision 1280) @@ -0,0 +1,132 @@ +! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation +! nor the names of its contributors may be used to endorse or promote products derived from +! this software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +MODULE MOD_LLNL_STATS + IMPLICIT NONE + +CONTAINS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!-------------------- FUNCTION COSP_CFAD ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +FUNCTION COSP_CFAD(Npoints,Ncolumns,Nlevels,Nbins,x,xmin,xmax,bmin,bwidth) + ! Input arguments + integer,intent(in) :: Npoints,Ncolumns,Nlevels,Nbins + real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: x + real,intent(in) :: xmin,xmax + real,intent(in) :: bmin,bwidth + + real,dimension(Npoints,Nbins,Nlevels) :: cosp_cfad + ! Local variables + integer :: i, j, k + integer :: ibin + + !--- Input arguments + ! Npoints: Number of horizontal points + ! Ncolumns: Number of subcolumns + ! Nlevels: Number of levels + ! Nbins: Number of x axis bins + ! x: variable to process (Npoints,Ncolumns,Nlevels) + ! xmin: minimum value allowed for x + ! xmax: minimum value allowed for x + ! bmin: mimumum value of first bin + ! bwidth: bin width + ! + ! Output: 2D histogram on each horizontal point (Npoints,Nbins,Nlevels) + + cosp_cfad = 0.0 + ! bwidth intervals in the range [bmin,bmax=bmin+Nbins*hwidth] + ! Valid x values smaller than bmin and larger than bmax are set + ! into the smallest bin and largest bin, respectively. + do j = 1, Nlevels, 1 + do k = 1, Ncolumns, 1 + do i = 1, Npoints, 1 + if ((x(i,k,j) >= xmin) .and. (x(i,k,j) <= xmax)) then + ibin = ceiling((x(i,k,j) - bmin)/bwidth) + if (ibin > Nbins) ibin = Nbins + if (ibin < 1) ibin = 1 + cosp_cfad(i,ibin,j) = cosp_cfad(i,ibin,j) + 1.0 + end if + enddo !i + enddo !k + enddo !j + cosp_cfad = cosp_cfad / Ncolumns +END FUNCTION COSP_CFAD + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_LIDAR_ONLY_CLOUD ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_LIDAR_ONLY_CLOUD(Npoints,Ncolumns,Nlevels,beta_tot,beta_mol,Ze_tot,lidar_only_freq_cloud,tcc) + ! Input arguments + integer,intent(in) :: Npoints,Ncolumns,Nlevels + real,dimension(Npoints,Nlevels),intent(in) :: beta_mol ! Molecular backscatter + real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: beta_tot ! Total backscattered signal + real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: Ze_tot ! Radar reflectivity + ! Output arguments + real,dimension(Npoints,Nlevels),intent(out) :: lidar_only_freq_cloud + real,dimension(Npoints),intent(out) :: tcc + + ! local variables + real :: sc_ratio + real :: s_cld, s_att +! parameter (S_cld = 3.0) ! Previous thresold for cloud detection + parameter (S_cld = 5.0) ! New (dec 2008) thresold for cloud detection + parameter (s_att = 0.01) + integer :: flag_sat !first saturated level encountered from top + integer :: flag_cld !cloudy column + integer :: pr,i,j + +! lidar_only_freq_cloud = 0.0 +! tcc = 0.0 + do pr=1,Npoints + do i=1,Ncolumns + flag_sat = 0 + flag_cld = 0 + do j=Nlevels,1,-1 !top->surf + sc_ratio = beta_tot(pr,i,j)/beta_mol(pr,j) +! if ((pr == 1).and.(j==8)) print *, pr,i,j,sc_ratio,Ze_tot(pr,i,j) + if ((sc_ratio .le. s_att) .and. (flag_sat .eq. 0)) flag_sat = j + if (Ze_tot(pr,i,j) .lt. -30.) then !radar can't detect cloud + if ( (sc_ratio .gt. s_cld) .or. (flag_sat .eq. j) ) then !lidar sense cloud +! if ((pr == 1).and.(j==8)) print *, 'L' + lidar_only_freq_cloud(pr,j)=lidar_only_freq_cloud(pr,j)+1. !top->surf + flag_cld=1 + endif + else !radar sense cloud (z%Ze_tot(pr,i,j) .ge. -30.) +! if ((pr == 1).and.(j==8)) print *, 'R' + flag_cld=1 + endif + enddo !levels + if (flag_cld .eq. 1) tcc(pr)=tcc(pr)+1. + enddo !columns +! if (tcc(pr) > Ncolumns) then +! print *, 'tcc(',pr,'): ', tcc(pr) +! tcc(pr) = Ncolumns +! endif + enddo !points + lidar_only_freq_cloud=lidar_only_freq_cloud/Ncolumns + tcc=tcc/Ncolumns + +END SUBROUTINE COSP_LIDAR_ONLY_CLOUD +END MODULE MOD_LLNL_STATS Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/lmd_ipsl_stats.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/lmd_ipsl_stats.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/lmd_ipsl_stats.F90 (revision 1280) @@ -0,0 +1,386 @@ +! Copyright (c) 2009, Centre National de la Recherche Scientifique +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the LMD/IPSL/CNRS/UPMC nor the names of its +! contributors may be used to endorse or promote products derived from this software without +! specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +!------------------------------------------------------------------------------------ +! Authors: Sandrine Bony and Helene Chepfer (LMD/IPSL, CNRS, UPMC, France). +!------------------------------------------------------------------------------------ +MODULE MOD_LMD_IPSL_STATS + USE MOD_LLNL_STATS + IMPLICIT NONE + +CONTAINS + SUBROUTINE diag_lidar(npoints,ncol,llm,max_bin,nrefl & + ,pnorm,pmol,refl,land,pplay,undef,ok_lidar_cfad & + ,cfad2,srbval & + ,ncat,lidarcld,cldlayer,parasolrefl) +! +! ----------------------------------------------------------------------------------- +! Lidar outputs : +! +! Diagnose cloud fraction (3D cloud fraction + low/middle/high/total cloud fraction +! from the lidar signals (ATB and molecular ATB) computed from model outputs +! + +! Compute CFADs of lidar scattering ratio SR and of depolarization index +! +! Authors: Sandrine Bony and Helene Chepfer (LMD/IPSL, CNRS, UPMC, France). +! +! December 2008, S. Bony, H. Chepfer and J-L. Dufresne : +! - change of the cloud detection threshold S_cld from 3 to 5, for better +! with both day and night observations. The optical thinest clouds are missed. +! - remove of the detection of the first fully attenuated layer encountered from above. +! December 2008, A. Bodas-Salcedo: +! - Dimensions of pmol reduced to (npoints,llm) +! +! Version 1.0 (June 2007) +! Version 1.1 (May 2008) +! Version 1.2 (June 2008) +! Version 2.0 (October 2008) +! Version 2.1 (December 2008) +! c------------------------------------------------------------------------------------ + +! c inputs : + integer npoints + integer ncol + integer llm + integer max_bin ! nb of bins for SR CFADs + integer ncat ! nb of cloud layer types (low,mid,high,total) + integer nrefl ! nb of solar zenith angles for parasol reflectances + + real undef ! undefined value + real pnorm(npoints,ncol,llm) ! lidar ATB + real pmol(npoints,llm) ! molecular ATB + real land(npoints) ! Landmask [0 - Ocean, 1 - Land] + real pplay(npoints,llm) ! pressure on model levels (Pa) + logical ok_lidar_cfad ! true if lidar CFAD diagnostics need to be computed + real refl(npoints,ncol,nrefl) ! subgrid parasol reflectance ! parasol + +! c outputs : + real lidarcld(npoints,llm) ! 3D "lidar" cloud fraction + real cldlayer(npoints,ncat) ! "lidar" cloud fraction (low, mid, high, total) + real cfad2(npoints,max_bin,llm) ! CFADs of SR + real srbval(max_bin) ! SR bins in CFADs + real parasolrefl(npoints,nrefl)! grid-averaged parasol reflectance + +! c threshold for cloud detection : + real S_clr + parameter (S_clr = 1.2) + real S_cld +! parameter (S_cld = 3.0) ! Previous thresold for cloud detection + parameter (S_cld = 5.0) ! New (dec 2008) thresold for cloud detection + real S_att + parameter (S_att = 0.01) + +! c local variables : + integer ic,k + real x3d(npoints,ncol,llm) + real x3d_c(npoints,llm),pnorm_c(npoints,llm) + real xmax +! +! c ------------------------------------------------------- +! c 0- Initializations +! c ------------------------------------------------------- +! Parasol reflectance algorithm is not valid over land. Write +! a warning if there is no land. Landmask [0 - Ocean, 1 - Land] + IF ( MAXVAL(land(:)) .EQ. 0.0) THEN + WRITE (*,*) 'WARNING. PARASOL reflectance is not valid over land' & + & ,' and there is only land' + END IF + +! Should be modified in future version + xmax=undef-1.0 + +! c ------------------------------------------------------- +! c 1- Lidar scattering ratio : +! c ------------------------------------------------------- +! +! where ((pnorm.lt.xmax) .and. (pmol.lt.xmax) .and. (pmol.gt. 0.0 )) +! x3d = pnorm/pmol +! elsewhere +! x3d = undef +! end where +! A.B-S: pmol reduced to 2D (npoints,llm) (Dec 08) + do ic = 1, ncol + pnorm_c = pnorm(:,ic,:) + where ((pnorm_c.lt.xmax) .and. (pmol.lt.xmax) .and. (pmol.gt. 0.0 )) + x3d_c = pnorm_c/pmol + elsewhere + x3d_c = undef + end where + x3d(:,ic,:) = x3d_c + enddo + +! c ------------------------------------------------------- +! c 2- Diagnose cloud fractions (3D, low, middle, high, total) +! c from subgrid-scale lidar scattering ratios : +! c ------------------------------------------------------- + + CALL COSP_CLDFRAC(npoints,ncol,llm,ncat, & + x3d,pplay, S_att,S_cld,undef,lidarcld, & + cldlayer) + +! c ------------------------------------------------------- +! c 3- CFADs +! c ------------------------------------------------------- + if (ok_lidar_cfad) then +! +! c CFADs of subgrid-scale lidar scattering ratios : +! c ------------------------------------------------------- + CALL COSP_CFAD_SR(npoints,ncol,llm,max_bin, & + x3d, & + S_att,S_clr,xmax,cfad2,srbval) + + endif ! ok_lidar_cfad +! c ------------------------------------------------------- + +! c ------------------------------------------------------- +! c 4- Compute grid-box averaged Parasol reflectances +! c ------------------------------------------------------- + + parasolrefl(:,:) = 0.0 + + do k = 1, nrefl + do ic = 1, ncol + parasolrefl(:,k) = parasolrefl(:,k) + refl(:,ic,k) + enddo + enddo + + do k = 1, nrefl + parasolrefl(:,k) = parasolrefl(:,k) / float(ncol) +! if land=1 -> parasolrefl=undef +! if land=0 -> parasolrefl=parasolrefl + parasolrefl(:,k) = parasolrefl(:,k) * MAX(1.0-land(:),0.0) & + + (1.0 - MAX(1.0-land(:),0.0))*undef + enddo + + RETURN + END SUBROUTINE diag_lidar + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!-------------------- FUNCTION COSP_CFAD_SR ------------------------ +! Author: Sandrine Bony (LMD/IPSL, CNRS, Paris) +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_CFAD_SR(Npoints,Ncolumns,Nlevels,Nbins, & + x,S_att,S_clr,xmax,cfad,srbval) + IMPLICIT NONE + +!--- Input arguments +! Npoints: Number of horizontal points +! Ncolumns: Number of subcolumns +! Nlevels: Number of levels +! Nbins: Number of x axis bins +! xmax: maximum value allowed for x +! S_att: Threshold for full attenuation +! S_clr: Threshold for clear-sky layer +! +!--- Input-Outout arguments +! x: variable to process (Npoints,Ncolumns,Nlevels), mofified where saturation occurs +! +! -- Output arguments +! srbval : values of the histogram bins +! cfad: 2D histogram on each horizontal point + +! Input arguments + integer Npoints,Ncolumns,Nlevels,Nbins + real xmax,S_att,S_clr +! Input-output arguments + real x(Npoints,Ncolumns,Nlevels) +! Output : + real cfad(Npoints,Nbins,Nlevels) + real srbval(Nbins) +! Local variables + integer i, j, k, ib + +! c ------------------------------------------------------- +! c 0- Initializations +! c ------------------------------------------------------- + if ( Nbins .lt. 6) return + + srbval(1) = S_att + srbval(2) = S_clr + srbval(3) = 3.0 + srbval(4) = 5.0 + srbval(5) = 7.0 + srbval(6) = 10.0 + do i = 7, MIN(10,Nbins) + srbval(i) = srbval(i-1) + 5.0 + enddo + DO i = 11, MIN(13,Nbins) + srbval(i) = srbval(i-1) + 10.0 + enddo + srbval(MIN(14,Nbins)) = 80.0 + srbval(Nbins) = xmax + cfad(:,:,:) = 0.0 + + +! c ------------------------------------------------------- +! c c- Compute CFAD +! c ------------------------------------------------------- + + do j = Nlevels, 1, -1 + do k = 1, Ncolumns + where ( x(:,k,j).le.srbval(1) ) & + cfad(:,1,j) = cfad(:,1,j) + 1.0 + enddo !k + enddo !j + + do ib = 2, Nbins + do j = Nlevels, 1, -1 + do k = 1, Ncolumns + where ( ( x(:,k,j).gt.srbval(ib-1) ) .and. ( x(:,k,j).le.srbval(ib) ) ) & + cfad(:,ib,j) = cfad(:,ib,j) + 1.0 + enddo !k + enddo !j + enddo !ib + + cfad(:,:,:) = cfad(:,:,:) / float(Ncolumns) + +! c ------------------------------------------------------- + RETURN + END SUBROUTINE COSP_CFAD_SR + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!-------------------- SUBROUTINE COSP_CLDFRAC ------------------- +! c Purpose: Cloud fraction diagnosed from lidar measurements +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_CLDFRAC(Npoints,Ncolumns,Nlevels,Ncat, & + x,pplay,S_att,S_cld,undef,lidarcld, & + cldlayer) + IMPLICIT NONE +! Input arguments + integer Npoints,Ncolumns,Nlevels,Ncat + real x(Npoints,Ncolumns,Nlevels) + real pplay(Npoints,Nlevels) + real S_att,S_cld + real undef +! Output : + real lidarcld(Npoints,Nlevels) ! 3D cloud fraction + real cldlayer(Npoints,Ncat) ! low, middle, high, total cloud fractions +! Local variables + integer ip, k, iz, ic + real p1 + real cldy(Npoints,Ncolumns,Nlevels) + real srok(Npoints,Ncolumns,Nlevels) + real cldlay(Npoints,Ncolumns,Ncat) + real nsublay(Npoints,Ncolumns,Ncat), nsublayer(Npoints,Ncat) + real nsub(Npoints,Nlevels) + + +! --------------------------------------------------------------- +! 1- initialization +! --------------------------------------------------------------- + + if ( Ncat .ne. 4 ) then + print *,'Error in lmd_ipsl_stats.cosp_cldfrac, Ncat must be 4, not',Ncat + stop + endif + + lidarcld = 0.0 + nsub = 0.0 + cldlay = 0.0 + nsublay = 0.0 + +! --------------------------------------------------------------- +! 2- Cloud detection +! --------------------------------------------------------------- + + do k = 1, Nlevels + +! cloud detection at subgrid-scale: + where ( (x(:,:,k).gt.S_cld) .and. (x(:,:,k).ne. undef) ) + cldy(:,:,k)=1.0 + elsewhere + cldy(:,:,k)=0.0 + endwhere + +! number of usefull sub-columns: + where ( (x(:,:,k).gt.S_att) .and. (x(:,:,k).ne. undef) ) + srok(:,:,k)=1.0 + elsewhere + srok(:,:,k)=0.0 + endwhere + + enddo ! k + +! --------------------------------------------------------------- +! 3- grid-box 3D cloud fraction and layered cloud fractions (ISCCP pressure +! categories) : +! --------------------------------------------------------------- +! Test abderr + do k = Nlevels, 1, -1 + do ic = 1, Ncolumns + do ip = 1, Npoints + iz=1 + p1 = pplay(ip,k) + if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high clouds + iz=3 + else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid clouds + iz=2 + endif + + cldlay(ip,ic,iz) = MAX(cldlay(ip,ic,iz),cldy(ip,ic,k)) + cldlay(ip,ic,4) = MAX(cldlay(ip,ic,4),cldy(ip,ic,k)) + lidarcld(ip,k)=lidarcld(ip,k) + cldy(ip,ic,k) + + nsublay(ip,ic,iz) = MAX(nsublay(ip,ic,iz),srok(ip,ic,k)) + nsublay(ip,ic,4) = MAX(nsublay(ip,ic,4),srok(ip,ic,k)) + nsub(ip,k)=nsub(ip,k) + srok(ip,ic,k) + + enddo + enddo + enddo + +! -- grid-box 3D cloud fraction + + where ( nsub(:,:).gt.0.0 ) + lidarcld(:,:) = lidarcld(:,:)/nsub(:,:) + elsewhere + lidarcld(:,:) = undef + endwhere + +! -- layered cloud fractions + + cldlayer = 0.0 + nsublayer = 0.0 + + do iz = 1, Ncat + do ic = 1, Ncolumns + + cldlayer(:,iz)=cldlayer(:,iz) + cldlay(:,ic,iz) + nsublayer(:,iz)=nsublayer(:,iz) + nsublay(:,ic,iz) + + enddo + enddo + where ( nsublayer(:,:).gt.0.0 ) + cldlayer(:,:) = cldlayer(:,:)/nsublayer(:,:) + elsewhere + cldlayer(:,:) = undef + endwhere + + RETURN + END SUBROUTINE COSP_CLDFRAC +! --------------------------------------------------------------- + +END MODULE MOD_LMD_IPSL_STATS Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/load_hydrometeor_classes.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/load_hydrometeor_classes.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/load_hydrometeor_classes.F90 (revision 1280) @@ -0,0 +1,54 @@ + subroutine load_hydrometeor_classes(Nprmts_max,dist_prmts_hydro,hp,nhclass) + use radar_simulator_types + implicit none + +! Purpose: +! Loads the hydrometeor classes to be used in calculations +! Part of QuickBeam v1.03 by John Haynes +! http://reef.atmos.colostate.edu/haynes/radarsim +! +! Inputs: +! [dist_prmts_hydro] from data in hydrometeor class input +! +! Outputs: +! [hp] structure that define hydrometeor types +! +! Modified: +! 08/23/2006 placed into subroutine form (Roger Marchand) + +! ----- INPUT ----- + integer, intent(in) :: nhclass,Nprmts_max + real,dimension(Nprmts_max,nhclass), intent(in) :: dist_prmts_hydro +! ----- OUTPUTS ----- + type(class_param), intent(out) :: hp + +! ----- INTERNAL ----- + integer :: i + + hp%rho(:) = -1 + + do i = 1,nhclass,1 + hp%dtype(i) = dist_prmts_hydro(1,i) + hp%col(i) = dist_prmts_hydro(2,i) + hp%phase(i) = dist_prmts_hydro(3,i) + hp%cp(i) = dist_prmts_hydro(4,i) + hp%dmin(i) = dist_prmts_hydro(5,i) + hp%dmax(i) = dist_prmts_hydro(6,i) + hp%apm(i) = dist_prmts_hydro(7,i) + hp%bpm(i) = dist_prmts_hydro(8,i) + hp%rho(i) = dist_prmts_hydro(9,i) + hp%p1(i) = dist_prmts_hydro(10,i) + hp%p2(i) = dist_prmts_hydro(11,i) + hp%p3(i) = dist_prmts_hydro(12,i) + enddo + +! // setup scaling arrays + hp%fc = -999. + hp%scaled = .false. + hp%z_flag = .false. + hp%rho_eff = -999. + hp%ifc = -9 + hp%idd = -9 + + + end subroutine load_hydrometeor_classes Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/load_mie_table.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/load_mie_table.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/load_mie_table.F90 (revision 1280) @@ -0,0 +1,69 @@ + subroutine load_mie_table(mie_table_name,mt) + use radar_simulator_types + implicit none + +! Purpose: +! Loads the Mie table data +! Part of Quickbeam v1.03 +! http://reef.atmos.colostate.edu/haynes/radarsim +! +! Inputs: +! [mie_table_name] Mie table input file +! +! Outputs: +! [mt] structure of Mie table data +! +! Created from Quickbeam v1.02 08/24/2006 by Roger Marchand + +! ----- INPUT ----- + character*200, intent(in) :: mie_table_name + +! ----- OUTPUT ----- + type(mie), intent(out) :: mt + +! ----- INTERNAL ----- + integer :: i + + integer*4 :: dummy_in(4) + + open(51,file=mie_table_name,action='read') + + read(51,*) dummy_in + + if(dummy_in(1).ne. mt_nfreq .or. & + dummy_in(2).ne. mt_ntt .or. & + dummy_in(3).ne. mt_nf .or. & + dummy_in(4).ne. mt_nd) then + + print *,'Mie file is of size :',dummy_in(:) + print *,' expected a size of:',mt_nfreq, mt_ntt,mt_nf,mt_nf + print *,' change paramters in radar_simulator_types.f90 ?? ' + stop + endif + + read(51,*) mt%freq + read(51,*) mt%tt + read(51,*) mt%f + read(51,*) mt%phase + read(51,*) mt%D + read(51,*) mt%qext + read(51,*) mt%qbsca + + close(51) + +! // create arrays of liquid/ice temperature + cnt_liq = 0 + cnt_ice = 0 + do i=1,mt_ntt + if (mt%phase(i) == 0) cnt_liq = cnt_liq + 1 + if (mt%phase(i) == 1) cnt_ice = cnt_ice + 1 + enddo + allocate(mt_ttl(cnt_liq),mt_tti(cnt_ice)) + do i=1,cnt_liq + mt_ttl(i) = mt%tt(i) + enddo + do i=1,cnt_ice + mt_tti(i) = mt%tt(cnt_liq+i) + enddo + + end subroutine load_mie_table Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/math_lib.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/math_lib.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/math_lib.F90 (revision 1280) @@ -0,0 +1,395 @@ +! MATH_LIB: Mathematics procedures for F90 +! Compiled/Modified: +! 07/01/06 John Haynes (haynes@atmos.colostate.edu) +! +! gamma (function) +! path_integral (function) +! avint (subroutine) + + module math_lib + implicit none + + contains + +! ---------------------------------------------------------------------------- +! function GAMMA +! ---------------------------------------------------------------------------- + function gamma(x) + implicit none +! +! Purpose: +! Returns the gamma function +! +! Input: +! [x] value to compute gamma function of +! +! Returns: +! gamma(x) +! +! Coded: +! 02/02/06 John Haynes (haynes@atmos.colostate.edu) +! (original code of unknown origin) + +! ----- INPUTS ----- + real*8, intent(in) :: x + +! ----- OUTPUTS ----- + real*8 :: gamma + +! ----- INTERNAL ----- + real*8 :: pi,ga,z,r,gr + real*8 :: g(26) + integer :: k,m1,m + + pi = acos(-1.) + if (x ==int(x)) then + if (x > 0.0) then + ga=1.0 + m1=x-1 + do k=2,m1 + ga=ga*k + enddo + else + ga=1.0+300 + endif + else + if (abs(x) > 1.0) then + z=abs(x) + m=int(z) + r=1.0 + do k=1,m + r=r*(z-k) + enddo + z=z-m + else + z=x + endif + data g/1.0,0.5772156649015329, & + -0.6558780715202538, -0.420026350340952d-1, & + 0.1665386113822915,-.421977345555443d-1, & + -.96219715278770d-2, .72189432466630d-2, & + -.11651675918591d-2, -.2152416741149d-3, & + .1280502823882d-3, -.201348547807d-4, & + -.12504934821d-5, .11330272320d-5, & + -.2056338417d-6, .61160950d-8, & + .50020075d-8, -.11812746d-8, & + .1043427d-9, .77823d-11, & + -.36968d-11, .51d-12, & + -.206d-13, -.54d-14, .14d-14, .1d-15/ + gr=g(26) + do k=25,1,-1 + gr=gr*z+g(k) + enddo + ga=1.0/(gr*z) + if (abs(x) > 1.0) then + ga=ga*r + if (x < 0.0) ga=-pi/(x*ga*sin(pi*x)) + endif + endif + gamma = ga + return + end function gamma + +! ---------------------------------------------------------------------------- +! function PATH_INTEGRAL +! ---------------------------------------------------------------------------- + function path_integral(f,s,i1,i2) + use m_mrgrnk + use array_lib + implicit none +! +! Purpose: +! evalues the integral (f ds) between f(index=i1) and f(index=i2) +! using the AVINT procedure +! +! Inputs: +! [f] functional values +! [s] abscissa values +! [i1] index of lower limit +! [i2] index of upper limit +! +! Returns: +! result of path integral +! +! Notes: +! [s] may be in forward or reverse numerical order +! +! Requires: +! mrgrnk package +! +! Created: +! 02/02/06 John Haynes (haynes@atmos.colostate.edu) + +! ----- INPUTS ----- + real*8, intent(in), dimension(:) :: f,s + integer, intent(in) :: i1, i2 + +! ---- OUTPUTS ----- + real*8 :: path_integral + +! ----- INTERNAL ----- + real*8 :: sumo, deltah, val + integer*4 :: nelm, j + integer*4, dimension(i2-i1+1) :: idx + real*8, dimension(i2-i1+1) :: f_rev, s_rev + + nelm = i2-i1+1 + if (nelm > 3) then + call mrgrnk(s(i1:i2),idx) + s_rev = s(idx) + f_rev = f(idx) + call avint(f_rev(i1:i2),s_rev(i1:i2),(i2-i1+1), & + s_rev(i1),s_rev(i2), val) + path_integral = val + else + sumo = 0. + do j=i1,i2 + deltah = abs(s(i1+1)-s(i1)) + sumo = sumo + f(j)*deltah + enddo + path_integral = sumo + endif + ! print *, sumo + + return + end function path_integral + +! ---------------------------------------------------------------------------- +! subroutine AVINT +! ---------------------------------------------------------------------------- + subroutine avint ( ftab, xtab, ntab, a_in, b_in, result ) + implicit none +! +! Purpose: +! estimate the integral of unevenly spaced data +! +! Inputs: +! [ftab] functional values +! [xtab] abscissa values +! [ntab] number of elements of [ftab] and [xtab] +! [a] lower limit of integration +! [b] upper limit of integration +! +! Outputs: +! [result] approximate value of integral +! +! Reference: +! From SLATEC libraries, in public domain +! +!*********************************************************************** +! +! AVINT estimates the integral of unevenly spaced data. +! +! Discussion: +! +! The method uses overlapping parabolas and smoothing. +! +! Modified: +! +! 30 October 2000 +! 4 January 2008, A. Bodas-Salcedo. Error control for XTAB taken out of +! loop to allow vectorization. +! +! Reference: +! +! Philip Davis and Philip Rabinowitz, +! Methods of Numerical Integration, +! Blaisdell Publishing, 1967. +! +! P E Hennion, +! Algorithm 77, +! Interpolation, Differentiation and Integration, +! Communications of the Association for Computing Machinery, +! Volume 5, page 96, 1962. +! +! Parameters: +! +! Input, real ( kind = 8 ) FTAB(NTAB), the function values, +! FTAB(I) = F(XTAB(I)). +! +! Input, real ( kind = 8 ) XTAB(NTAB), the abscissas at which the +! function values are given. The XTAB's must be distinct +! and in ascending order. +! +! Input, integer NTAB, the number of entries in FTAB and +! XTAB. NTAB must be at least 3. +! +! Input, real ( kind = 8 ) A, the lower limit of integration. A should +! be, but need not be, near one endpoint of the interval +! (X(1), X(NTAB)). +! +! Input, real ( kind = 8 ) B, the upper limit of integration. B should +! be, but need not be, near one endpoint of the interval +! (X(1), X(NTAB)). +! +! Output, real ( kind = 8 ) RESULT, the approximate value of the integral. + + integer, intent(in) :: ntab + + integer,parameter :: KR8 = selected_real_kind(15,300) + real ( kind = KR8 ), intent(in) :: a_in + real ( kind = KR8 ) a + real ( kind = KR8 ) atemp + real ( kind = KR8 ), intent(in) :: b_in + real ( kind = KR8 ) b + real ( kind = KR8 ) btemp + real ( kind = KR8 ) ca + real ( kind = KR8 ) cb + real ( kind = KR8 ) cc + real ( kind = KR8 ) ctemp + real ( kind = KR8 ), intent(in) :: ftab(ntab) + integer i + integer ihi + integer ilo + integer ind + real ( kind = KR8 ), intent(out) :: result + real ( kind = KR8 ) sum1 + real ( kind = KR8 ) syl + real ( kind = KR8 ) term1 + real ( kind = KR8 ) term2 + real ( kind = KR8 ) term3 + real ( kind = KR8 ) x1 + real ( kind = KR8 ) x2 + real ( kind = KR8 ) x3 + real ( kind = KR8 ), intent(in) :: xtab(ntab) + logical lerror + + lerror = .false. + a = a_in + b = b_in + + if ( ntab < 3 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'AVINT - Fatal error!' + write ( *, '(a,i6)' ) ' NTAB is less than 3. NTAB = ', ntab + stop + end if + + do i = 2, ntab + if ( xtab(i) <= xtab(i-1) ) then + lerror = .true. + exit + end if + end do + + if (lerror) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'AVINT - Fatal error!' + write ( *, '(a)' ) ' XTAB(I) is not greater than XTAB(I-1).' + write ( *, '(a,i6)' ) ' Here, I = ', i + write ( *, '(a,g14.6)' ) ' XTAB(I-1) = ', xtab(i-1) + write ( *, '(a,g14.6)' ) ' XTAB(I) = ', xtab(i) + stop + end if + + result = 0.0D+00 + + if ( a == b ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'AVINT - Warning!' + write ( *, '(a)' ) ' A = B, integral=0.' + return + end if +! +! If B < A, temporarily switch A and B, and store sign. +! + if ( b < a ) then + syl = b + b = a + a = syl + ind = -1 + else + syl = a + ind = 1 + end if +! +! Bracket A and B between XTAB(ILO) and XTAB(IHI). +! + ilo = 1 + ihi = ntab + + do i = 1, ntab + if ( a <= xtab(i) ) then + exit + end if + ilo = ilo + 1 + end do + + ilo = max ( 2, ilo ) + ilo = min ( ilo, ntab - 1 ) + + do i = 1, ntab + if ( xtab(i) <= b ) then + exit + end if + ihi = ihi - 1 + end do + + ihi = min ( ihi, ntab - 1 ) + ihi = max ( ilo, ihi - 1 ) +! +! Carry out approximate integration from XTAB(ILO) to XTAB(IHI). +! + sum1 = 0.0D+00 + + do i = ilo, ihi + + x1 = xtab(i-1) + x2 = xtab(i) + x3 = xtab(i+1) + + term1 = ftab(i-1) / ( ( x1 - x2 ) * ( x1 - x3 ) ) + term2 = ftab(i) / ( ( x2 - x1 ) * ( x2 - x3 ) ) + term3 = ftab(i+1) / ( ( x3 - x1 ) * ( x3 - x2 ) ) + + atemp = term1 + term2 + term3 + + btemp = - ( x2 + x3 ) * term1 & + - ( x1 + x3 ) * term2 & + - ( x1 + x2 ) * term3 + + ctemp = x2 * x3 * term1 + x1 * x3 * term2 + x1 * x2 * term3 + + if ( i <= ilo ) then + ca = atemp + cb = btemp + cc = ctemp + else + ca = 0.5D+00 * ( atemp + ca ) + cb = 0.5D+00 * ( btemp + cb ) + cc = 0.5D+00 * ( ctemp + cc ) + end if + + sum1 = sum1 & + + ca * ( x2**3 - syl**3 ) / 3.0D+00 & + + cb * 0.5D+00 * ( x2**2 - syl**2 ) & + + cc * ( x2 - syl ) + + ca = atemp + cb = btemp + cc = ctemp + + syl = x2 + + end do + + result = sum1 & + + ca * ( b**3 - syl**3 ) / 3.0D+00 & + + cb * 0.5D+00 * ( b**2 - syl**2 ) & + + cc * ( b - syl ) +! +! Restore original values of A and B, reverse sign of integral +! because of earlier switch. +! + if ( ind /= 1 ) then + ind = 1 + syl = b + b = a + a = syl + result = -result + end if + + return + end subroutine avint + + end module math_lib Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/mrgrnk.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/mrgrnk.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/mrgrnk.F90 (revision 1280) @@ -0,0 +1,410 @@ +Module m_mrgrnk +Integer, Parameter :: kdp = selected_real_kind(15) +public :: mrgrnk +private :: kdp +private :: I_mrgrnk, D_mrgrnk +interface mrgrnk + module procedure D_mrgrnk, I_mrgrnk +end interface mrgrnk +contains + +Subroutine D_mrgrnk (XDONT, IRNGT) +! __________________________________________________________ +! MRGRNK = Merge-sort ranking of an array +! For performance reasons, the first 2 passes are taken +! out of the standard loop, and use dedicated coding. +! __________________________________________________________ +! __________________________________________________________ + Real (kind=kdp), Dimension (:), Intent (In) :: XDONT + Integer, Dimension (:), Intent (Out) :: IRNGT +! __________________________________________________________ + Real (kind=kdp) :: XVALA, XVALB +! + Integer, Dimension (SIZE(IRNGT)) :: JWRKT + Integer :: LMTNA, LMTNC, IRNG1, IRNG2 + Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB +! + NVAL = Min (SIZE(XDONT), SIZE(IRNGT)) + Select Case (NVAL) + Case (:0) + Return + Case (1) + IRNGT (1) = 1 + Return + Case Default + Continue + End Select +! +! Fill-in the index array, creating ordered couples +! + Do IIND = 2, NVAL, 2 + If (XDONT(IIND-1) <= XDONT(IIND)) Then + IRNGT (IIND-1) = IIND - 1 + IRNGT (IIND) = IIND + Else + IRNGT (IIND-1) = IIND + IRNGT (IIND) = IIND - 1 + End If + End Do + If (Modulo(NVAL, 2) /= 0) Then + IRNGT (NVAL) = NVAL + End If +! +! We will now have ordered subsets A - B - A - B - ... +! and merge A and B couples into C - C - ... +! + LMTNA = 2 + LMTNC = 4 +! +! First iteration. The length of the ordered subsets goes from 2 to 4 +! + Do + If (NVAL <= 2) Exit +! +! Loop on merges of A and B into C +! + Do IWRKD = 0, NVAL - 1, 4 + If ((IWRKD+4) > NVAL) Then + If ((IWRKD+2) >= NVAL) Exit +! +! 1 2 3 +! + If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit +! +! 1 3 2 +! + If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNGT (IWRKD+3) + IRNGT (IWRKD+3) = IRNG2 +! +! 3 1 2 +! + Else + IRNG1 = IRNGT (IWRKD+1) + IRNGT (IWRKD+1) = IRNGT (IWRKD+3) + IRNGT (IWRKD+3) = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNG1 + End If + Exit + End If +! +! 1 2 3 4 +! + If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle +! +! 1 3 x x +! + If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNGT (IWRKD+3) + If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then +! 1 3 2 4 + IRNGT (IWRKD+3) = IRNG2 + Else +! 1 3 4 2 + IRNGT (IWRKD+3) = IRNGT (IWRKD+4) + IRNGT (IWRKD+4) = IRNG2 + End If +! +! 3 x x x +! + Else + IRNG1 = IRNGT (IWRKD+1) + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+1) = IRNGT (IWRKD+3) + If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then + IRNGT (IWRKD+2) = IRNG1 + If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then +! 3 1 2 4 + IRNGT (IWRKD+3) = IRNG2 + Else +! 3 1 4 2 + IRNGT (IWRKD+3) = IRNGT (IWRKD+4) + IRNGT (IWRKD+4) = IRNG2 + End If + Else +! 3 4 1 2 + IRNGT (IWRKD+2) = IRNGT (IWRKD+4) + IRNGT (IWRKD+3) = IRNG1 + IRNGT (IWRKD+4) = IRNG2 + End If + End If + End Do +! +! The Cs become As and Bs +! + LMTNA = 4 + Exit + End Do +! +! Iteration loop. Each time, the length of the ordered subsets +! is doubled. +! + Do + If (LMTNA >= NVAL) Exit + IWRKF = 0 + LMTNC = 2 * LMTNC +! +! Loop on merges of A and B into C +! + Do + IWRK = IWRKF + IWRKD = IWRKF + 1 + JINDA = IWRKF + LMTNA + IWRKF = IWRKF + LMTNC + If (IWRKF >= NVAL) Then + If (JINDA >= NVAL) Exit + IWRKF = NVAL + End If + IINDA = 1 + IINDB = JINDA + 1 +! +! Shortcut for the case when the max of A is smaller +! than the min of B. This line may be activated when the +! initial set is already close to sorted. +! +! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE +! +! One steps in the C subset, that we build in the final rank array +! +! Make a copy of the rank array for the merge iteration +! + JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA) +! + XVALA = XDONT (JWRKT(IINDA)) + XVALB = XDONT (IRNGT(IINDB)) +! + Do + IWRK = IWRK + 1 +! +! We still have unprocessed values in both A and B +! + If (XVALA > XVALB) Then + IRNGT (IWRK) = IRNGT (IINDB) + IINDB = IINDB + 1 + If (IINDB > IWRKF) Then +! Only A still with unprocessed values + IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA) + Exit + End If + XVALB = XDONT (IRNGT(IINDB)) + Else + IRNGT (IWRK) = JWRKT (IINDA) + IINDA = IINDA + 1 + If (IINDA > LMTNA) Exit! Only B still with unprocessed values + XVALA = XDONT (JWRKT(IINDA)) + End If +! + End Do + End Do +! +! The Cs become As and Bs +! + LMTNA = 2 * LMTNA + End Do +! + Return +! +End Subroutine D_mrgrnk + +Subroutine I_mrgrnk (XDONT, IRNGT) +! __________________________________________________________ +! MRGRNK = Merge-sort ranking of an array +! For performance reasons, the first 2 passes are taken +! out of the standard loop, and use dedicated coding. +! __________________________________________________________ +! __________________________________________________________ + Integer, Dimension (:), Intent (In) :: XDONT + Integer, Dimension (:), Intent (Out) :: IRNGT +! __________________________________________________________ + Integer :: XVALA, XVALB +! + Integer, Dimension (SIZE(IRNGT)) :: JWRKT + Integer :: LMTNA, LMTNC, IRNG1, IRNG2 + Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB +! + NVAL = Min (SIZE(XDONT), SIZE(IRNGT)) + Select Case (NVAL) + Case (:0) + Return + Case (1) + IRNGT (1) = 1 + Return + Case Default + Continue + End Select +! +! Fill-in the index array, creating ordered couples +! + Do IIND = 2, NVAL, 2 + If (XDONT(IIND-1) <= XDONT(IIND)) Then + IRNGT (IIND-1) = IIND - 1 + IRNGT (IIND) = IIND + Else + IRNGT (IIND-1) = IIND + IRNGT (IIND) = IIND - 1 + End If + End Do + If (Modulo(NVAL, 2) /= 0) Then + IRNGT (NVAL) = NVAL + End If +! +! We will now have ordered subsets A - B - A - B - ... +! and merge A and B couples into C - C - ... +! + LMTNA = 2 + LMTNC = 4 +! +! First iteration. The length of the ordered subsets goes from 2 to 4 +! + Do + If (NVAL <= 2) Exit +! +! Loop on merges of A and B into C +! + Do IWRKD = 0, NVAL - 1, 4 + If ((IWRKD+4) > NVAL) Then + If ((IWRKD+2) >= NVAL) Exit +! +! 1 2 3 +! + If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit +! +! 1 3 2 +! + If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNGT (IWRKD+3) + IRNGT (IWRKD+3) = IRNG2 +! +! 3 1 2 +! + Else + IRNG1 = IRNGT (IWRKD+1) + IRNGT (IWRKD+1) = IRNGT (IWRKD+3) + IRNGT (IWRKD+3) = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNG1 + End If + Exit + End If +! +! 1 2 3 4 +! + If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle +! +! 1 3 x x +! + If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNGT (IWRKD+3) + If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then +! 1 3 2 4 + IRNGT (IWRKD+3) = IRNG2 + Else +! 1 3 4 2 + IRNGT (IWRKD+3) = IRNGT (IWRKD+4) + IRNGT (IWRKD+4) = IRNG2 + End If +! +! 3 x x x +! + Else + IRNG1 = IRNGT (IWRKD+1) + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+1) = IRNGT (IWRKD+3) + If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then + IRNGT (IWRKD+2) = IRNG1 + If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then +! 3 1 2 4 + IRNGT (IWRKD+3) = IRNG2 + Else +! 3 1 4 2 + IRNGT (IWRKD+3) = IRNGT (IWRKD+4) + IRNGT (IWRKD+4) = IRNG2 + End If + Else +! 3 4 1 2 + IRNGT (IWRKD+2) = IRNGT (IWRKD+4) + IRNGT (IWRKD+3) = IRNG1 + IRNGT (IWRKD+4) = IRNG2 + End If + End If + End Do +! +! The Cs become As and Bs +! + LMTNA = 4 + Exit + End Do +! +! Iteration loop. Each time, the length of the ordered subsets +! is doubled. +! + Do + If (LMTNA >= NVAL) Exit + IWRKF = 0 + LMTNC = 2 * LMTNC +! +! Loop on merges of A and B into C +! + Do + IWRK = IWRKF + IWRKD = IWRKF + 1 + JINDA = IWRKF + LMTNA + IWRKF = IWRKF + LMTNC + If (IWRKF >= NVAL) Then + If (JINDA >= NVAL) Exit + IWRKF = NVAL + End If + IINDA = 1 + IINDB = JINDA + 1 +! +! Shortcut for the case when the max of A is smaller +! than the min of B. This line may be activated when the +! initial set is already close to sorted. +! +! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE +! +! One steps in the C subset, that we build in the final rank array +! +! Make a copy of the rank array for the merge iteration +! + JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA) +! + XVALA = XDONT (JWRKT(IINDA)) + XVALB = XDONT (IRNGT(IINDB)) +! + Do + IWRK = IWRK + 1 +! +! We still have unprocessed values in both A and B +! + If (XVALA > XVALB) Then + IRNGT (IWRK) = IRNGT (IINDB) + IINDB = IINDB + 1 + If (IINDB > IWRKF) Then +! Only A still with unprocessed values + IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA) + Exit + End If + XVALB = XDONT (IRNGT(IINDB)) + Else + IRNGT (IWRK) = JWRKT (IINDA) + IINDA = IINDA + 1 + If (IINDA > LMTNA) Exit! Only B still with unprocessed values + XVALA = XDONT (JWRKT(IINDA)) + End If +! + End Do + End Do +! +! The Cs become As and Bs +! + LMTNA = 2 * LMTNA + End Do +! + Return +! +End Subroutine I_mrgrnk +end module m_mrgrnk Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/optics_lib.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/optics_lib.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/optics_lib.F90 (revision 1280) @@ -0,0 +1,747 @@ +! OPTICS_LIB: Optical proecures for for F90 +! Compiled/Modified: +! 07/01/06 John Haynes (haynes@atmos.colostate.edu) +! +! m_wat (subroutine) +! m_ice (subroutine) +! mie_int (subroutine) + + module optics_lib + implicit none + + contains + +! ---------------------------------------------------------------------------- +! subroutine M_WAT +! ---------------------------------------------------------------------------- + subroutine m_wat(freq, t, n_r, n_i) + implicit none +! +! Purpose: +! compute complex index of refraction of liquid water +! +! Inputs: +! [freq] frequency (GHz) +! [t] temperature (C) +! +! Outputs: +! [n_r] real part index of refraction +! [n_i] imaginary part index of refraction +! +! Reference: +! Based on the work of Ray (1972) +! +! Coded: +! 03/22/05 John Haynes (haynes@atmos.colostate.edu) + +! ----- INPUTS ----- + real*8, intent(in) :: freq,t + +! ----- OUTPUTS ----- + real*8, intent(out) :: n_r, n_i + +! ----- INTERNAL ----- + real*8 ld,es,ei,a,ls,sg,tm1,cos1,sin1 + real*8 e_r,e_i + real*8 pi + complex*16 e_comp, sq + + ld = 100.*2.99792458E8/(freq*1E9) + es = 78.54*(1-(4.579E-3*(t-25.)+1.19E-5*(t-25.)**2 & + -2.8E-8*(t-25.)**3)) + ei = 5.27137+0.021647*t-0.00131198*t**2 + a = -(16.8129/(t+273.))+0.0609265 + ls = 0.00033836*exp(2513.98/(t+273.)) + sg = 12.5664E8 + + tm1 = (ls/ld)**(1-a) + pi = acos(-1.D0) + cos1 = cos(0.5*a*pi) + sin1 = sin(0.5*a*pi) + + e_r = ei + (((es-ei)*(1.+tm1*sin1))/(1.+2*tm1*sin1+tm1**2)) + e_i = (((es-ei)*tm1*cos1)/(1.+2*tm1*sin1+tm1**2)) & + +((sg*ld)/1.885E11) + + e_comp = dcmplx(e_r,e_i) + sq = sqrt(e_comp) + + n_r = real(sq) + n_i = aimag(sq) + + return + end subroutine m_wat + +! ---------------------------------------------------------------------------- +! subroutine M_ICE +! ---------------------------------------------------------------------------- + subroutine m_ice(freq,t,n_r,n_i) + implicit none +! +! Purpose: +! compute complex index of refraction of ice +! +! Inputs: +! [freq] frequency (GHz) +! [t] temperature (C) +! +! Outputs: +! [n_r] real part index of refraction +! [n_i] imaginary part index of refraction +! +! Reference: +! Fortran 90 port from IDL of REFICE by Stephen G. Warren +! +! Modified: +! 05/31/05 John Haynes (haynes@atmos.colostate.edu) + +! ----- INPUTS ----- + real*8, intent(in) :: freq, t + +! ----- OUTPUTS ----- + real*8, intent(out) :: n_r,n_i + +! Parameters: + integer*2 :: i,lt1,lt2,nwl,nwlt + parameter(nwl=468,nwlt=62) + + real*8 :: alam,cutice,pi,t1,t2,tk,wlmax,wlmin, & + x,x1,x2,y,y1,y2,ylo,yhi + + real*8 :: & + tabim(nwl),tabimt(nwlt,4),tabre(nwl),tabret(nwlt,4),temref(4), & + wl(nwl),wlt(nwlt) + +! Defines wavelength dependent complex index of refraction for ice. +! Allowable wavelength range extends from 0.045 microns to 8.6 meter +! temperature dependence only considered beyond 167 microns. +! +! interpolation is done n_r vs. log(xlam) +! n_r vs. t +! log(n_i) vs. log(xlam) +! log(n_i) vs. t +! +! Stephen G. Warren - 1983 +! Dept. of Atmospheric Sciences +! University of Washington +! Seattle, Wa 98195 +! +! Based on +! +! Warren,S.G.,1984. +! Optical constants of ice from the ultraviolet to the microwave. +! Applied Optics,23,1206-1225 +! +! Reference temperatures are -1.0,-5.0,-20.0, and -60.0 deg C + + data temref/272.16,268.16,253.16,213.16/ + + data wlmin,wlmax/0.045,8.6e6/ + data cutice/167.0/ + + data (wl(i),i=1,114)/ & + 0.4430e-01,0.4510e-01,0.4590e-01,0.4680e-01,0.4770e-01,0.4860e-01, & + 0.4960e-01,0.5060e-01,0.5170e-01,0.5280e-01,0.5390e-01,0.5510e-01, & + 0.5640e-01,0.5770e-01,0.5900e-01,0.6050e-01,0.6200e-01,0.6360e-01, & + 0.6530e-01,0.6700e-01,0.6890e-01,0.7080e-01,0.7290e-01,0.7380e-01, & + 0.7510e-01,0.7750e-01,0.8000e-01,0.8270e-01,0.8550e-01,0.8860e-01, & + 0.9180e-01,0.9300e-01,0.9540e-01,0.9920e-01,0.1033e+00,0.1078e+00, & + 0.1100e+00,0.1127e+00,0.1140e+00,0.1181e+00,0.1210e+00,0.1240e+00, & + 0.1272e+00,0.1295e+00,0.1305e+00,0.1319e+00,0.1333e+00,0.1348e+00, & + 0.1362e+00,0.1370e+00,0.1378e+00,0.1387e+00,0.1393e+00,0.1409e+00, & + 0.1425e+00,0.1435e+00,0.1442e+00,0.1450e+00,0.1459e+00,0.1468e+00, & + 0.1476e+00,0.1480e+00,0.1485e+00,0.1494e+00,0.1512e+00,0.1531e+00, & + 0.1540e+00,0.1550e+00,0.1569e+00,0.1580e+00,0.1589e+00,0.1610e+00, & + 0.1625e+00,0.1648e+00,0.1669e+00,0.1692e+00,0.1713e+00,0.1737e+00, & + 0.1757e+00,0.1779e+00,0.1802e+00,0.1809e+00,0.1821e+00,0.1833e+00, & + 0.1843e+00,0.1850e+00,0.1860e+00,0.1870e+00,0.1880e+00,0.1890e+00, & + 0.1900e+00,0.1910e+00,0.1930e+00,0.1950e+00,0.2100e+00,0.2500e+00, & + 0.3000e+00,0.3500e+00,0.4000e+00,0.4100e+00,0.4200e+00,0.4300e+00, & + 0.4400e+00,0.4500e+00,0.4600e+00,0.4700e+00,0.4800e+00,0.4900e+00, & + 0.5000e+00,0.5100e+00,0.5200e+00,0.5300e+00,0.5400e+00,0.5500e+00/ + data (wl(i),i=115,228)/ & + 0.5600e+00,0.5700e+00,0.5800e+00,0.5900e+00,0.6000e+00,0.6100e+00, & + 0.6200e+00,0.6300e+00,0.6400e+00,0.6500e+00,0.6600e+00,0.6700e+00, & + 0.6800e+00,0.6900e+00,0.7000e+00,0.7100e+00,0.7200e+00,0.7300e+00, & + 0.7400e+00,0.7500e+00,0.7600e+00,0.7700e+00,0.7800e+00,0.7900e+00, & + 0.8000e+00,0.8100e+00,0.8200e+00,0.8300e+00,0.8400e+00,0.8500e+00, & + 0.8600e+00,0.8700e+00,0.8800e+00,0.8900e+00,0.9000e+00,0.9100e+00, & + 0.9200e+00,0.9300e+00,0.9400e+00,0.9500e+00,0.9600e+00,0.9700e+00, & + 0.9800e+00,0.9900e+00,0.1000e+01,0.1010e+01,0.1020e+01,0.1030e+01, & + 0.1040e+01,0.1050e+01,0.1060e+01,0.1070e+01,0.1080e+01,0.1090e+01, & + 0.1100e+01,0.1110e+01,0.1120e+01,0.1130e+01,0.1140e+01,0.1150e+01, & + 0.1160e+01,0.1170e+01,0.1180e+01,0.1190e+01,0.1200e+01,0.1210e+01, & + 0.1220e+01,0.1230e+01,0.1240e+01,0.1250e+01,0.1260e+01,0.1270e+01, & + 0.1280e+01,0.1290e+01,0.1300e+01,0.1310e+01,0.1320e+01,0.1330e+01, & + 0.1340e+01,0.1350e+01,0.1360e+01,0.1370e+01,0.1380e+01,0.1390e+01, & + 0.1400e+01,0.1410e+01,0.1420e+01,0.1430e+01,0.1440e+01,0.1449e+01, & + 0.1460e+01,0.1471e+01,0.1481e+01,0.1493e+01,0.1504e+01,0.1515e+01, & + 0.1527e+01,0.1538e+01,0.1563e+01,0.1587e+01,0.1613e+01,0.1650e+01, & + 0.1680e+01,0.1700e+01,0.1730e+01,0.1760e+01,0.1800e+01,0.1830e+01, & + 0.1840e+01,0.1850e+01,0.1855e+01,0.1860e+01,0.1870e+01,0.1890e+01/ + data (wl(i),i=229,342)/ & + 0.1905e+01,0.1923e+01,0.1942e+01,0.1961e+01,0.1980e+01,0.2000e+01, & + 0.2020e+01,0.2041e+01,0.2062e+01,0.2083e+01,0.2105e+01,0.2130e+01, & + 0.2150e+01,0.2170e+01,0.2190e+01,0.2220e+01,0.2240e+01,0.2245e+01, & + 0.2250e+01,0.2260e+01,0.2270e+01,0.2290e+01,0.2310e+01,0.2330e+01, & + 0.2350e+01,0.2370e+01,0.2390e+01,0.2410e+01,0.2430e+01,0.2460e+01, & + 0.2500e+01,0.2520e+01,0.2550e+01,0.2565e+01,0.2580e+01,0.2590e+01, & + 0.2600e+01,0.2620e+01,0.2675e+01,0.2725e+01,0.2778e+01,0.2817e+01, & + 0.2833e+01,0.2849e+01,0.2865e+01,0.2882e+01,0.2899e+01,0.2915e+01, & + 0.2933e+01,0.2950e+01,0.2967e+01,0.2985e+01,0.3003e+01,0.3021e+01, & + 0.3040e+01,0.3058e+01,0.3077e+01,0.3096e+01,0.3115e+01,0.3135e+01, & + 0.3155e+01,0.3175e+01,0.3195e+01,0.3215e+01,0.3236e+01,0.3257e+01, & + 0.3279e+01,0.3300e+01,0.3322e+01,0.3345e+01,0.3367e+01,0.3390e+01, & + 0.3413e+01,0.3436e+01,0.3460e+01,0.3484e+01,0.3509e+01,0.3534e+01, & + 0.3559e+01,0.3624e+01,0.3732e+01,0.3775e+01,0.3847e+01,0.3969e+01, & + 0.4099e+01,0.4239e+01,0.4348e+01,0.4387e+01,0.4444e+01,0.4505e+01, & + 0.4547e+01,0.4560e+01,0.4580e+01,0.4719e+01,0.4904e+01,0.5000e+01, & + 0.5100e+01,0.5200e+01,0.5263e+01,0.5400e+01,0.5556e+01,0.5714e+01, & + 0.5747e+01,0.5780e+01,0.5814e+01,0.5848e+01,0.5882e+01,0.6061e+01, & + 0.6135e+01,0.6250e+01,0.6289e+01,0.6329e+01,0.6369e+01,0.6410e+01/ + data (wl(i),i=343,456)/ & + 0.6452e+01,0.6494e+01,0.6579e+01,0.6667e+01,0.6757e+01,0.6897e+01, & + 0.7042e+01,0.7143e+01,0.7246e+01,0.7353e+01,0.7463e+01,0.7576e+01, & + 0.7692e+01,0.7812e+01,0.7937e+01,0.8065e+01,0.8197e+01,0.8333e+01, & + 0.8475e+01,0.8696e+01,0.8929e+01,0.9091e+01,0.9259e+01,0.9524e+01, & + 0.9804e+01,0.1000e+02,0.1020e+02,0.1031e+02,0.1042e+02,0.1053e+02, & + 0.1064e+02,0.1075e+02,0.1087e+02,0.1100e+02,0.1111e+02,0.1136e+02, & + 0.1163e+02,0.1190e+02,0.1220e+02,0.1250e+02,0.1282e+02,0.1299e+02, & + 0.1316e+02,0.1333e+02,0.1351e+02,0.1370e+02,0.1389e+02,0.1408e+02, & + 0.1429e+02,0.1471e+02,0.1515e+02,0.1538e+02,0.1563e+02,0.1613e+02, & + 0.1639e+02,0.1667e+02,0.1695e+02,0.1724e+02,0.1818e+02,0.1887e+02, & + 0.1923e+02,0.1961e+02,0.2000e+02,0.2041e+02,0.2083e+02,0.2222e+02, & + 0.2260e+02,0.2305e+02,0.2360e+02,0.2460e+02,0.2500e+02,0.2600e+02, & + 0.2857e+02,0.3100e+02,0.3333e+02,0.3448e+02,0.3564e+02,0.3700e+02, & + 0.3824e+02,0.3960e+02,0.4114e+02,0.4276e+02,0.4358e+02,0.4458e+02, & + 0.4550e+02,0.4615e+02,0.4671e+02,0.4736e+02,0.4800e+02,0.4878e+02, & + 0.5003e+02,0.5128e+02,0.5275e+02,0.5350e+02,0.5424e+02,0.5500e+02, & + 0.5574e+02,0.5640e+02,0.5700e+02,0.5746e+02,0.5840e+02,0.5929e+02, & + 0.6000e+02,0.6100e+02,0.6125e+02,0.6250e+02,0.6378e+02,0.6467e+02, & + 0.6558e+02,0.6655e+02,0.6760e+02,0.6900e+02,0.7053e+02,0.7300e+02/ + data (wl(i),i=457,468)/ & + 0.7500e+02,0.7629e+02,0.8000e+02,0.8297e+02,0.8500e+02,0.8680e+02, & + 0.9080e+02,0.9517e+02,0.1000e+03,0.1200e+03,0.1500e+03,0.1670e+03/ + data wlt/ & + 0.1670e+03,0.1778e+03,0.1884e+03, & + 0.1995e+03,0.2113e+03,0.2239e+03,0.2371e+03,0.2512e+03,0.2661e+03, & + 0.2818e+03,0.2985e+03,0.3162e+03,0.3548e+03,0.3981e+03,0.4467e+03, & + 0.5012e+03,0.5623e+03,0.6310e+03,0.7943e+03,0.1000e+04,0.1259e+04, & + 0.2500e+04,0.5000e+04,0.1000e+05,0.2000e+05,0.3200e+05,0.3500e+05, & + 0.4000e+05,0.4500e+05,0.5000e+05,0.6000e+05,0.7000e+05,0.9000e+05, & + 0.1110e+06,0.1200e+06,0.1300e+06,0.1400e+06,0.1500e+06,0.1600e+06, & + 0.1700e+06,0.1800e+06,0.2000e+06,0.2500e+06,0.2900e+06,0.3200e+06, & + 0.3500e+06,0.3800e+06,0.4000e+06,0.4500e+06,0.5000e+06,0.6000e+06, & + 0.6400e+06,0.6800e+06,0.7200e+06,0.7600e+06,0.8000e+06,0.8400e+06, & + 0.9000e+06,0.1000e+07,0.2000e+07,0.5000e+07,0.8600e+07/ + data (tabre(i),i=1,114)/ & + 0.83441, 0.83676, 0.83729, 0.83771, 0.83827, 0.84038, & + 0.84719, 0.85522, 0.86047, 0.86248, 0.86157, 0.86093, & + 0.86419, 0.86916, 0.87764, 0.89296, 0.91041, 0.93089, & + 0.95373, 0.98188, 1.02334, 1.06735, 1.11197, 1.13134, & + 1.15747, 1.20045, 1.23840, 1.27325, 1.32157, 1.38958, & + 1.41644, 1.40906, 1.40063, 1.40169, 1.40934, 1.40221, & + 1.39240, 1.38424, 1.38075, 1.38186, 1.39634, 1.40918, & + 1.40256, 1.38013, 1.36303, 1.34144, 1.32377, 1.30605, & + 1.29054, 1.28890, 1.28931, 1.30190, 1.32025, 1.36302, & + 1.41872, 1.45834, 1.49028, 1.52128, 1.55376, 1.57782, & + 1.59636, 1.60652, 1.61172, 1.61919, 1.62522, 1.63404, & + 1.63689, 1.63833, 1.63720, 1.63233, 1.62222, 1.58269, & + 1.55635, 1.52453, 1.50320, 1.48498, 1.47226, 1.45991, & + 1.45115, 1.44272, 1.43498, 1.43280, 1.42924, 1.42602, & + 1.42323, 1.42143, 1.41897, 1.41660, 1.41434, 1.41216, & + 1.41006, 1.40805, 1.40423, 1.40067, 1.38004, 1.35085, & + 1.33394, 1.32492, 1.31940, 1.31854, 1.31775, 1.31702, & + 1.31633, 1.31569, 1.31509, 1.31452, 1.31399, 1.31349, & + 1.31302, 1.31257, 1.31215, 1.31175, 1.31136, 1.31099/ + data (tabre(i),i=115,228)/ & + 1.31064, 1.31031, 1.30999, 1.30968, 1.30938, 1.30909, & + 1.30882, 1.30855, 1.30829, 1.30804, 1.30780, 1.30756, & + 1.30733, 1.30710, 1.30688, 1.30667, 1.30646, 1.30625, & + 1.30605, 1.30585, 1.30566, 1.30547, 1.30528, 1.30509, & + 1.30491, 1.30473, 1.30455, 1.30437, 1.30419, 1.30402, & + 1.30385, 1.30367, 1.30350, 1.30333, 1.30316, 1.30299, & + 1.30283, 1.30266, 1.30249, 1.30232, 1.30216, 1.30199, & + 1.30182, 1.30166, 1.30149, 1.30132, 1.30116, 1.30099, & + 1.30082, 1.30065, 1.30048, 1.30031, 1.30014, 1.29997, & + 1.29979, 1.29962, 1.29945, 1.29927, 1.29909, 1.29891, & + 1.29873, 1.29855, 1.29837, 1.29818, 1.29800, 1.29781, & + 1.29762, 1.29743, 1.29724, 1.29705, 1.29686, 1.29666, & + 1.29646, 1.29626, 1.29605, 1.29584, 1.29563, 1.29542, & + 1.29521, 1.29499, 1.29476, 1.29453, 1.29430, 1.29406, & + 1.29381, 1.29355, 1.29327, 1.29299, 1.29272, 1.29252, & + 1.29228, 1.29205, 1.29186, 1.29167, 1.29150, 1.29130, & + 1.29106, 1.29083, 1.29025, 1.28962, 1.28891, 1.28784, & + 1.28689, 1.28623, 1.28521, 1.28413, 1.28261, 1.28137, & + 1.28093, 1.28047, 1.28022, 1.27998, 1.27948, 1.27849/ + data (tabre(i),i=229,342)/ & + 1.27774, 1.27691, 1.27610, 1.27535, 1.27471, 1.27404, & + 1.27329, 1.27240, 1.27139, 1.27029, 1.26901, 1.26736, & + 1.26591, 1.26441, 1.26284, 1.26036, 1.25860, 1.25815, & + 1.25768, 1.25675, 1.25579, 1.25383, 1.25179, 1.24967, & + 1.24745, 1.24512, 1.24266, 1.24004, 1.23725, 1.23270, & + 1.22583, 1.22198, 1.21548, 1.21184, 1.20790, 1.20507, & + 1.20209, 1.19566, 1.17411, 1.14734, 1.10766, 1.06739, & + 1.04762, 1.02650, 1.00357, 0.98197, 0.96503, 0.95962, & + 0.97269, 0.99172, 1.00668, 1.02186, 1.04270, 1.07597, & + 1.12954, 1.21267, 1.32509, 1.42599, 1.49656, 1.55095, & + 1.59988, 1.63631, 1.65024, 1.64278, 1.62691, 1.61284, & + 1.59245, 1.57329, 1.55770, 1.54129, 1.52654, 1.51139, & + 1.49725, 1.48453, 1.47209, 1.46125, 1.45132, 1.44215, & + 1.43366, 1.41553, 1.39417, 1.38732, 1.37735, 1.36448, & + 1.35414, 1.34456, 1.33882, 1.33807, 1.33847, 1.34053, & + 1.34287, 1.34418, 1.34634, 1.34422, 1.33453, 1.32897, & + 1.32333, 1.31800, 1.31432, 1.30623, 1.29722, 1.28898, & + 1.28730, 1.28603, 1.28509, 1.28535, 1.28813, 1.30156, & + 1.30901, 1.31720, 1.31893, 1.32039, 1.32201, 1.32239/ + data (tabre(i),i=343,456)/ & + 1.32149, 1.32036, 1.31814, 1.31705, 1.31807, 1.31953, & + 1.31933, 1.31896, 1.31909, 1.31796, 1.31631, 1.31542, & + 1.31540, 1.31552, 1.31455, 1.31193, 1.30677, 1.29934, & + 1.29253, 1.28389, 1.27401, 1.26724, 1.25990, 1.24510, & + 1.22241, 1.19913, 1.17150, 1.15528, 1.13700, 1.11808, & + 1.10134, 1.09083, 1.08734, 1.09254, 1.10654, 1.14779, & + 1.20202, 1.25825, 1.32305, 1.38574, 1.44478, 1.47170, & + 1.49619, 1.51652, 1.53328, 1.54900, 1.56276, 1.57317, & + 1.58028, 1.57918, 1.56672, 1.55869, 1.55081, 1.53807, & + 1.53296, 1.53220, 1.53340, 1.53289, 1.51705, 1.50097, & + 1.49681, 1.49928, 1.50153, 1.49856, 1.49053, 1.46070, & + 1.45182, 1.44223, 1.43158, 1.41385, 1.40676, 1.38955, & + 1.34894, 1.31039, 1.26420, 1.23656, 1.21663, 1.20233, & + 1.19640, 1.19969, 1.20860, 1.22173, 1.24166, 1.28175, & + 1.32784, 1.38657, 1.46486, 1.55323, 1.60379, 1.61877, & + 1.62963, 1.65712, 1.69810, 1.72065, 1.74865, 1.76736, & + 1.76476, 1.75011, 1.72327, 1.68490, 1.62398, 1.59596, & + 1.58514, 1.59917, 1.61405, 1.66625, 1.70663, 1.73713, & + 1.76860, 1.80343, 1.83296, 1.85682, 1.87411, 1.89110/ + data (tabre(i),i=457,468)/ & + 1.89918, 1.90432, 1.90329, 1.88744, 1.87499, 1.86702, & + 1.85361, 1.84250, 1.83225, 1.81914, 1.82268, 1.82961/ + data (tabret(i,1),i=1,nwlt)/ & + 1.82961, 1.83258, 1.83149, & + 1.82748, 1.82224, 1.81718, 1.81204, 1.80704, 1.80250, & + 1.79834, 1.79482, 1.79214, 1.78843, 1.78601, 1.78434, & + 1.78322, 1.78248, 1.78201, 1.78170, 1.78160, 1.78190, & + 1.78300, 1.78430, 1.78520, 1.78620, 1.78660, 1.78680, & + 1.78690, 1.78700, 1.78700, 1.78710, 1.78710, 1.78720, & + 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, & + 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, & + 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, & + 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, & + 1.78720, 1.78720, 1.78720, 1.78720, 1.78800/ + data (tabret(i,2),i=1,nwlt)/ & + 1.82961, 1.83258, 1.83149, 1.82748, & + 1.82224, 1.81718, 1.81204, 1.80704, 1.80250, 1.79834, & + 1.79482, 1.79214, 1.78843, 1.78601, 1.78434, 1.78322, & + 1.78248, 1.78201, 1.78170, 1.78160, 1.78190, 1.78300, & + 1.78430, 1.78520, 1.78610, 1.78630, 1.78640, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78720/ + data(tabret(i,3),i=1,nwlt)/ & + 1.82961, 1.83258, 1.83149, 1.82748, 1.82224, & + 1.81718, 1.81204, 1.80704, 1.80250, 1.79834, 1.79482, & + 1.79214, 1.78843, 1.78601, 1.78434, 1.78322, 1.78248, & + 1.78201, 1.78160, 1.78140, 1.78160, 1.78220, 1.78310, & + 1.78380, 1.78390, 1.78400, 1.78400, 1.78400, 1.78400, & + 1.78400, 1.78390, 1.78380, 1.78370, 1.78370, 1.78370, & + 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, & + 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, & + 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, & + 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, & + 1.78370, 1.78400, 1.78450/ + data (tabret(i,4),i=1,nwlt)/ & + 1.82961, 1.83258, 1.83149, 1.82748, 1.82224, 1.81718, & + 1.81204, 1.80704, 1.80250, 1.79834, 1.79482, 1.79214, & + 1.78843, 1.78601, 1.78434, 1.78322, 1.78248, 1.78201, & + 1.78150, 1.78070, 1.78010, 1.77890, 1.77790, 1.77730, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77800/ + data(tabim(i),i=1,114)/ & + 0.1640e+00,0.1730e+00,0.1830e+00,0.1950e+00,0.2080e+00,0.2230e+00, & + 0.2400e+00,0.2500e+00,0.2590e+00,0.2680e+00,0.2790e+00,0.2970e+00, & + 0.3190e+00,0.3400e+00,0.3660e+00,0.3920e+00,0.4160e+00,0.4400e+00, & + 0.4640e+00,0.4920e+00,0.5170e+00,0.5280e+00,0.5330e+00,0.5340e+00, & + 0.5310e+00,0.5240e+00,0.5100e+00,0.5000e+00,0.4990e+00,0.4680e+00, & + 0.3800e+00,0.3600e+00,0.3390e+00,0.3180e+00,0.2910e+00,0.2510e+00, & + 0.2440e+00,0.2390e+00,0.2390e+00,0.2440e+00,0.2470e+00,0.2240e+00, & + 0.1950e+00,0.1740e+00,0.1720e+00,0.1800e+00,0.1940e+00,0.2130e+00, & + 0.2430e+00,0.2710e+00,0.2890e+00,0.3340e+00,0.3440e+00,0.3820e+00, & + 0.4010e+00,0.4065e+00,0.4050e+00,0.3890e+00,0.3770e+00,0.3450e+00, & + 0.3320e+00,0.3150e+00,0.2980e+00,0.2740e+00,0.2280e+00,0.1980e+00, & + 0.1720e+00,0.1560e+00,0.1100e+00,0.8300e-01,0.5800e-01,0.2200e-01, & + 0.1000e-01,0.3000e-02,0.1000e-02,0.3000e-03,0.1000e-03,0.3000e-04, & + 0.1000e-04,0.3000e-05,0.1000e-05,0.7000e-06,0.4000e-06,0.2000e-06, & + 0.1000e-06,0.6377e-07,0.3750e-07,0.2800e-07,0.2400e-07,0.2200e-07, & + 0.1900e-07,0.1750e-07,0.1640e-07,0.1590e-07,0.1325e-07,0.8623e-08, & + 0.5504e-08,0.3765e-08,0.2710e-08,0.2510e-08,0.2260e-08,0.2080e-08, & + 0.1910e-08,0.1540e-08,0.1530e-08,0.1550e-08,0.1640e-08,0.1780e-08, & + 0.1910e-08,0.2140e-08,0.2260e-08,0.2540e-08,0.2930e-08,0.3110e-08/ + data(tabim(i),i=115,228)/ & + 0.3290e-08,0.3520e-08,0.4040e-08,0.4880e-08,0.5730e-08,0.6890e-08, & + 0.8580e-08,0.1040e-07,0.1220e-07,0.1430e-07,0.1660e-07,0.1890e-07, & + 0.2090e-07,0.2400e-07,0.2900e-07,0.3440e-07,0.4030e-07,0.4300e-07, & + 0.4920e-07,0.5870e-07,0.7080e-07,0.8580e-07,0.1020e-06,0.1180e-06, & + 0.1340e-06,0.1400e-06,0.1430e-06,0.1450e-06,0.1510e-06,0.1830e-06, & + 0.2150e-06,0.2650e-06,0.3350e-06,0.3920e-06,0.4200e-06,0.4440e-06, & + 0.4740e-06,0.5110e-06,0.5530e-06,0.6020e-06,0.7550e-06,0.9260e-06, & + 0.1120e-05,0.1330e-05,0.1620e-05,0.2000e-05,0.2250e-05,0.2330e-05, & + 0.2330e-05,0.2170e-05,0.1960e-05,0.1810e-05,0.1740e-05,0.1730e-05, & + 0.1700e-05,0.1760e-05,0.1820e-05,0.2040e-05,0.2250e-05,0.2290e-05, & + 0.3040e-05,0.3840e-05,0.4770e-05,0.5760e-05,0.6710e-05,0.8660e-05, & + 0.1020e-04,0.1130e-04,0.1220e-04,0.1290e-04,0.1320e-04,0.1350e-04, & + 0.1330e-04,0.1320e-04,0.1320e-04,0.1310e-04,0.1320e-04,0.1320e-04, & + 0.1340e-04,0.1390e-04,0.1420e-04,0.1480e-04,0.1580e-04,0.1740e-04, & + 0.1980e-04,0.2500e-04,0.5400e-04,0.1040e-03,0.2030e-03,0.2708e-03, & + 0.3511e-03,0.4299e-03,0.5181e-03,0.5855e-03,0.5899e-03,0.5635e-03, & + 0.5480e-03,0.5266e-03,0.4394e-03,0.3701e-03,0.3372e-03,0.2410e-03, & + 0.1890e-03,0.1660e-03,0.1450e-03,0.1280e-03,0.1030e-03,0.8600e-04, & + 0.8220e-04,0.8030e-04,0.8500e-04,0.9900e-04,0.1500e-03,0.2950e-03/ + data(tabim(i),i=229,342)/ & + 0.4687e-03,0.7615e-03,0.1010e-02,0.1313e-02,0.1539e-02,0.1588e-02, & + 0.1540e-02,0.1412e-02,0.1244e-02,0.1068e-02,0.8414e-03,0.5650e-03, & + 0.4320e-03,0.3500e-03,0.2870e-03,0.2210e-03,0.2030e-03,0.2010e-03, & + 0.2030e-03,0.2140e-03,0.2320e-03,0.2890e-03,0.3810e-03,0.4620e-03, & + 0.5480e-03,0.6180e-03,0.6800e-03,0.7300e-03,0.7820e-03,0.8480e-03, & + 0.9250e-03,0.9200e-03,0.8920e-03,0.8700e-03,0.8900e-03,0.9300e-03, & + 0.1010e-02,0.1350e-02,0.3420e-02,0.7920e-02,0.2000e-01,0.3800e-01, & + 0.5200e-01,0.6800e-01,0.9230e-01,0.1270e+00,0.1690e+00,0.2210e+00, & + 0.2760e+00,0.3120e+00,0.3470e+00,0.3880e+00,0.4380e+00,0.4930e+00, & + 0.5540e+00,0.6120e+00,0.6250e+00,0.5930e+00,0.5390e+00,0.4910e+00, & + 0.4380e+00,0.3720e+00,0.3000e+00,0.2380e+00,0.1930e+00,0.1580e+00, & + 0.1210e+00,0.1030e+00,0.8360e-01,0.6680e-01,0.5400e-01,0.4220e-01, & + 0.3420e-01,0.2740e-01,0.2200e-01,0.1860e-01,0.1520e-01,0.1260e-01, & + 0.1060e-01,0.8020e-02,0.6850e-02,0.6600e-02,0.6960e-02,0.9160e-02, & + 0.1110e-01,0.1450e-01,0.2000e-01,0.2300e-01,0.2600e-01,0.2900e-01, & + 0.2930e-01,0.3000e-01,0.2850e-01,0.1730e-01,0.1290e-01,0.1200e-01, & + 0.1250e-01,0.1340e-01,0.1400e-01,0.1750e-01,0.2400e-01,0.3500e-01, & + 0.3800e-01,0.4200e-01,0.4600e-01,0.5200e-01,0.5700e-01,0.6900e-01, & + 0.7000e-01,0.6700e-01,0.6500e-01,0.6400e-01,0.6200e-01,0.5900e-01/ + data(tabim(i),i=343,456)/ & + 0.5700e-01,0.5600e-01,0.5500e-01,0.5700e-01,0.5800e-01,0.5700e-01, & + 0.5500e-01,0.5500e-01,0.5400e-01,0.5200e-01,0.5200e-01,0.5200e-01, & + 0.5200e-01,0.5000e-01,0.4700e-01,0.4300e-01,0.3900e-01,0.3700e-01, & + 0.3900e-01,0.4000e-01,0.4200e-01,0.4400e-01,0.4500e-01,0.4600e-01, & + 0.4700e-01,0.5100e-01,0.6500e-01,0.7500e-01,0.8800e-01,0.1080e+00, & + 0.1340e+00,0.1680e+00,0.2040e+00,0.2480e+00,0.2800e+00,0.3410e+00, & + 0.3790e+00,0.4090e+00,0.4220e+00,0.4220e+00,0.4030e+00,0.3890e+00, & + 0.3740e+00,0.3540e+00,0.3350e+00,0.3150e+00,0.2940e+00,0.2710e+00, & + 0.2460e+00,0.1980e+00,0.1640e+00,0.1520e+00,0.1420e+00,0.1280e+00, & + 0.1250e+00,0.1230e+00,0.1160e+00,0.1070e+00,0.7900e-01,0.7200e-01, & + 0.7600e-01,0.7500e-01,0.6700e-01,0.5500e-01,0.4500e-01,0.2900e-01, & + 0.2750e-01,0.2700e-01,0.2730e-01,0.2890e-01,0.3000e-01,0.3400e-01, & + 0.5300e-01,0.7550e-01,0.1060e+00,0.1350e+00,0.1761e+00,0.2229e+00, & + 0.2746e+00,0.3280e+00,0.3906e+00,0.4642e+00,0.5247e+00,0.5731e+00, & + 0.6362e+00,0.6839e+00,0.7091e+00,0.6790e+00,0.6250e+00,0.5654e+00, & + 0.5433e+00,0.5292e+00,0.5070e+00,0.4883e+00,0.4707e+00,0.4203e+00, & + 0.3771e+00,0.3376e+00,0.3056e+00,0.2835e+00,0.3170e+00,0.3517e+00, & + 0.3902e+00,0.4509e+00,0.4671e+00,0.4779e+00,0.4890e+00,0.4899e+00, & + 0.4873e+00,0.4766e+00,0.4508e+00,0.4193e+00,0.3880e+00,0.3433e+00/ + data(tabim(i),i=457,468)/ & + 0.3118e+00,0.2935e+00,0.2350e+00,0.1981e+00,0.1865e+00,0.1771e+00, & + 0.1620e+00,0.1490e+00,0.1390e+00,0.1200e+00,0.9620e-01,0.8300e-01/ + data(tabimt(i,1),i=1,nwlt)/ & + 0.8300e-01,0.6900e-01,0.5700e-01, & + 0.4560e-01,0.3790e-01,0.3140e-01,0.2620e-01,0.2240e-01,0.1960e-01, & + 0.1760e-01,0.1665e-01,0.1620e-01,0.1550e-01,0.1470e-01,0.1390e-01, & + 0.1320e-01,0.1250e-01,0.1180e-01,0.1060e-01,0.9540e-02,0.8560e-02, & + 0.6210e-02,0.4490e-02,0.3240e-02,0.2340e-02,0.1880e-02,0.1740e-02, & + 0.1500e-02,0.1320e-02,0.1160e-02,0.8800e-03,0.6950e-03,0.4640e-03, & + 0.3400e-03,0.3110e-03,0.2940e-03,0.2790e-03,0.2700e-03,0.2640e-03, & + 0.2580e-03,0.2520e-03,0.2490e-03,0.2540e-03,0.2640e-03,0.2740e-03, & + 0.2890e-03,0.3050e-03,0.3150e-03,0.3460e-03,0.3820e-03,0.4620e-03, & + 0.5000e-03,0.5500e-03,0.5950e-03,0.6470e-03,0.6920e-03,0.7420e-03, & + 0.8200e-03,0.9700e-03,0.1950e-02,0.5780e-02,0.9700e-02/ + data(tabimt(i,2),i=1,nwlt)/ & + 0.8300e-01,0.6900e-01,0.5700e-01,0.4560e-01, & + 0.3790e-01,0.3140e-01,0.2620e-01,0.2240e-01,0.1960e-01,0.1760e-01, & + 0.1665e-01,0.1600e-01,0.1500e-01,0.1400e-01,0.1310e-01,0.1230e-01, & + 0.1150e-01,0.1080e-01,0.9460e-02,0.8290e-02,0.7270e-02,0.4910e-02, & + 0.3300e-02,0.2220e-02,0.1490e-02,0.1140e-02,0.1060e-02,0.9480e-03, & + 0.8500e-03,0.7660e-03,0.6300e-03,0.5200e-03,0.3840e-03,0.2960e-03, & + 0.2700e-03,0.2520e-03,0.2440e-03,0.2360e-03,0.2300e-03,0.2280e-03, & + 0.2250e-03,0.2200e-03,0.2160e-03,0.2170e-03,0.2200e-03,0.2250e-03, & + 0.2320e-03,0.2390e-03,0.2600e-03,0.2860e-03,0.3560e-03,0.3830e-03, & + 0.4150e-03,0.4450e-03,0.4760e-03,0.5080e-03,0.5400e-03,0.5860e-03, & + 0.6780e-03,0.1280e-02,0.3550e-02,0.5600e-02/ + data(tabimt(i,3),i=1,nwlt)/ & + 0.8300e-01,0.6900e-01,0.5700e-01,0.4560e-01,0.3790e-01, & + 0.3140e-01,0.2620e-01,0.2190e-01,0.1880e-01,0.1660e-01,0.1540e-01, & + 0.1470e-01,0.1350e-01,0.1250e-01,0.1150e-01,0.1060e-01,0.9770e-02, & + 0.9010e-02,0.7660e-02,0.6520e-02,0.5540e-02,0.3420e-02,0.2100e-02, & + 0.1290e-02,0.7930e-03,0.5700e-03,0.5350e-03,0.4820e-03,0.4380e-03, & + 0.4080e-03,0.3500e-03,0.3200e-03,0.2550e-03,0.2120e-03,0.2000e-03, & + 0.1860e-03,0.1750e-03,0.1660e-03,0.1560e-03,0.1490e-03,0.1440e-03, & + 0.1350e-03,0.1210e-03,0.1160e-03,0.1160e-03,0.1170e-03,0.1200e-03, & + 0.1230e-03,0.1320e-03,0.1440e-03,0.1680e-03,0.1800e-03,0.1900e-03, & + 0.2090e-03,0.2160e-03,0.2290e-03,0.2400e-03,0.2600e-03,0.2920e-03, & + 0.6100e-03,0.1020e-02,0.1810e-02/ + data(tabimt(i,4),i=1,nwlt)/ & + 0.8300e-01,0.6900e-01,0.5700e-01,0.4450e-01,0.3550e-01,0.2910e-01, & + 0.2440e-01,0.1970e-01,0.1670e-01,0.1400e-01,0.1235e-01,0.1080e-01, & + 0.8900e-02,0.7340e-02,0.6400e-02,0.5600e-02,0.5000e-02,0.4520e-02, & + 0.3680e-02,0.2990e-02,0.2490e-02,0.1550e-02,0.9610e-03,0.5950e-03, & + 0.3690e-03,0.2670e-03,0.2510e-03,0.2290e-03,0.2110e-03,0.1960e-03, & + 0.1730e-03,0.1550e-03,0.1310e-03,0.1130e-03,0.1060e-03,0.9900e-04, & + 0.9300e-04,0.8730e-04,0.8300e-04,0.7870e-04,0.7500e-04,0.6830e-04, & + 0.5600e-04,0.4960e-04,0.4550e-04,0.4210e-04,0.3910e-04,0.3760e-04, & + 0.3400e-04,0.3100e-04,0.2640e-04,0.2510e-04,0.2430e-04,0.2390e-04, & + 0.2370e-04,0.2380e-04,0.2400e-04,0.2460e-04,0.2660e-04,0.4450e-04, & + 0.8700e-04,0.1320e-03/ + + pi = acos(-1.0) + n_r=0.0 + n_i=0.0 + +! // convert frequency to wavelength (um) + alam=3E5/freq + if((alam < wlmin) .or. (alam > wlmax)) then + print *, 'm_ice: wavelength out of bounds' + stop + endif + +! // convert temperature to K + tk = t + 273.16 + + if (alam < cutice) then + +! // region from 0.045 microns to 167.0 microns - no temperature depend + do i=2,nwl + if(alam < wl(i)) continue + enddo + x1=log(wl(i-1)) + x2=log(wl(i)) + y1=tabre(i-1) + y2=tabre(i) + x=log(alam) + y=((x-x1)*(y2-y1)/(x2-x1))+y1 + n_r=y + y1=log(abs(tabim(i-1))) + y2=log(abs(tabim(i))) + y=((x-x1)*(y2-y1)/(x2-x1))+y1 + n_i=exp(y) + + else + +! // region from 167.0 microns to 8.6 meters - temperature dependence + if(tk > temref(1)) tk=temref(1) + if(tk < temref(4)) tk=temref(4) + do 11 i=2,4 + if(tk.ge.temref(i)) go to 12 + 11 continue + 12 lt1=i + lt2=i-1 + do 13 i=2,nwlt + if(alam.le.wlt(i)) go to 14 + 13 continue + 14 x1=log(wlt(i-1)) + x2=log(wlt(i)) + y1=tabret(i-1,lt1) + y2=tabret(i,lt1) + x=log(alam) + ylo=((x-x1)*(y2-y1)/(x2-x1))+y1 + y1=tabret(i-1,lt2) + y2=tabret(i,lt2) + yhi=((x-x1)*(y2-y1)/(x2-x1))+y1 + t1=temref(lt1) + t2=temref(lt2) + y=((tk-t1)*(yhi-ylo)/(t2-t1))+ylo + n_r=y + y1=log(abs(tabimt(i-1,lt1))) + y2=log(abs(tabimt(i,lt1))) + ylo=((x-x1)*(y2-y1)/(x2-x1))+y1 + y1=log(abs(tabimt(i-1,lt2))) + y2=log(abs(tabimt(i,lt2))) + yhi=((x-x1)*(y2-y1)/(x2-x1))+y1 + y=((tk-t1)*(yhi-ylo)/(t2-t1))+ylo + n_i=exp(y) + + endif + + end subroutine m_ice + +! ---------------------------------------------------------------------------- +! subroutine MIEINT +! ---------------------------------------------------------------------------- +! +! General purpose Mie scattering routine for single particles +! Author: R Grainger 1990 +! History: +! G Thomas, March 2005: Added calculation of Phase function and +! code to ensure correct calculation of backscatter coeficient +! Options/Extend_Source +! + Subroutine MieInt(Dx, SCm, Inp, Dqv, Dqxt, Dqsc, Dbsc, Dg, Xs1, Xs2, DPh, Error) + + Integer * 2 Imaxx + Parameter (Imaxx = 12000) + Real * 4 RIMax ! largest real part of refractive index + Parameter (RIMax = 2.5) + Real * 4 IRIMax ! largest imaginary part of refractive index + Parameter (IRIMax = -2) + Integer * 2 Itermax + Parameter (Itermax = 12000 * 2.5) + ! must be large enough to cope with the + ! largest possible nmx = x * abs(scm) + 15 + ! or nmx = Dx + 4.05*Dx**(1./3.) + 2.0 + Integer * 2 Imaxnp + Parameter (Imaxnp = 10000) ! Change this as required +! INPUT + Real * 8 Dx + Complex * 16 SCm + Integer * 4 Inp + Real * 8 Dqv(Inp) +! OUTPUT + Complex * 16 Xs1(InP) + Complex * 16 Xs2(InP) + Real * 8 Dqxt + Real * 8 Dqsc + Real * 8 Dg + Real * 8 Dbsc + Real * 8 DPh(InP) + Integer * 4 Error +! LOCAL + Integer * 2 I + Integer * 2 NStop + Integer * 2 NmX + Integer * 4 N ! N*N > 32767 ie N > 181 + Integer * 4 Inp2 + Real * 8 Chi,Chi0,Chi1 + Real * 8 APsi,APsi0,APsi1 + Real * 8 Pi0(Imaxnp) + Real * 8 Pi1(Imaxnp) + Real * 8 Taun(Imaxnp) + Real * 8 Psi,Psi0,Psi1 + Complex * 8 Ir + Complex * 16 Cm + Complex * 16 A,ANM1,APB + Complex * 16 B,BNM1,AMB + Complex * 16 D(Itermax) + Complex * 16 Sp(Imaxnp) + Complex * 16 Sm(Imaxnp) + Complex * 16 Xi,Xi0,Xi1 + Complex * 16 Y +! ACCELERATOR VARIABLES + Integer * 2 Tnp1 + Integer * 2 Tnm1 + Real * 8 Dn + Real * 8 Rnx + Real * 8 S(Imaxnp) + Real * 8 T(Imaxnp) + Real * 8 Turbo + Real * 8 A2 + Complex * 16 A1 + + If ((Dx.Gt.Imaxx) .Or. (InP.Gt.ImaxNP)) Then + Error = 1 + Return + EndIf + Cm = SCm + Ir = 1 / Cm + Y = Dx * Cm + If (Dx.Lt.0.02) Then + NStop = 2 + Else + If (Dx.Le.8.0) Then + NStop = Dx + 4.00*Dx**(1./3.) + 2.0 + Else + If (Dx.Lt. 4200.0) Then + NStop = Dx + 4.05*Dx**(1./3.) + 2.0 + Else + NStop = Dx + 4.00*Dx**(1./3.) + 2.0 + End If + End If + End If + NmX = Max(Real(NStop),Real(Abs(Y))) + 15. + If (Nmx .gt. Itermax) then + Error = 1 + Return + End If + Inp2 = Inp+1 + D(NmX) = Dcmplx(0,0) + Do N = Nmx-1,1,-1 + A1 = (N+1) / Y + D(N) = A1 - 1/(A1+D(N+1)) + End Do + Do I =1,Inp2 + Sm(I) = Dcmplx(0,0) + Sp(I) = Dcmplx(0,0) + Pi0(I) = 0 + Pi1(I) = 1 + End Do + Psi0 = Cos(Dx) + Psi1 = Sin(Dx) + Chi0 =-Sin(Dx) + Chi1 = Cos(Dx) + APsi0 = Psi0 + APsi1 = Psi1 + Xi0 = Dcmplx(APsi0,Chi0) + Xi1 = Dcmplx(APsi1,Chi1) + Dg = 0 + Dqsc = 0 + Dqxt = 0 + Tnp1 = 1 + Do N = 1,Nstop + DN = N + Tnp1 = Tnp1 + 2 + Tnm1 = Tnp1 - 2 + A2 = Tnp1 / (DN*(DN+1D0)) + Turbo = (DN+1D0) / DN + Rnx = DN/Dx + Psi = Dble(Tnm1)*Psi1/Dx - Psi0 + APsi = Psi + Chi = Tnm1*Chi1/Dx - Chi0 + Xi = Dcmplx(APsi,Chi) + A = ((D(N)*Ir+Rnx)*APsi-APsi1) / ((D(N)*Ir+Rnx)* Xi- Xi1) + B = ((D(N)*Cm+Rnx)*APsi-APsi1) / ((D(N)*Cm+Rnx)* Xi- Xi1) + Dqxt = Tnp1 * Dble(A + B) + Dqxt + Dqsc = Tnp1 * (A*Conjg(A) + B*Conjg(B)) + Dqsc + If (N.Gt.1) then + Dg = Dg + (dN*dN - 1) * Dble(ANM1*Conjg(A) + BNM1 * Conjg(B)) / dN + TNM1 * Dble(ANM1*Conjg(BNM1)) / (dN*dN - dN) + End If + Anm1 = A + Bnm1 = B + APB = A2 * (A + B) + AMB = A2 * (A - B) + Do I = 1,Inp2 + If (I.GT.Inp) Then + S(I) = -Pi1(I) + Else + S(I) = Dqv(I) * Pi1(I) + End If + T(I) = S(I) - Pi0(I) + Taun(I) = N*T(I) - Pi0(I) + Sp(I) = APB * (Pi1(I) + Taun(I)) + Sp(I) + Sm(I) = AMB * (Pi1(I) - Taun(I)) + Sm(I) + Pi0(I) = Pi1(I) + Pi1(I) = S(I) + T(I)*Turbo + End Do + Psi0 = Psi1 + Psi1 = Psi + Apsi1 = Psi1 + Chi0 = Chi1 + Chi1 = Chi + Xi1 = Dcmplx(APsi1,Chi1) + End Do + If (Dg .GT.0) Dg = 2 * Dg / Dqsc + Dqsc = 2 * Dqsc / Dx**2 + Dqxt = 2 * Dqxt / Dx**2 + Do I = 1,Inp + Xs1(I) = (Sp(I)+Sm(I)) / 2 + Xs2(I) = (Sp(I)-Sm(I)) / 2 + Dph(I) = 2 * Dble(Xs1(I)*Conjg(Xs1(I)) + Xs2(I)*Conjg(Xs2(I))) / (Dx**2 * Dqsc) + End Do + Dbsc = 4 * Abs(( (Sp(Inp2)+Sm(Inp2))/2 )**2) / Dx**2 + Error = 0 + Return + End subroutine MieInt + + end module optics_lib Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/pf_to_mr.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/pf_to_mr.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/pf_to_mr.F (revision 1280) @@ -0,0 +1,128 @@ +! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation +! nor the names of its contributors may be used to endorse or promote products derived from +! this software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + subroutine pf_to_mr(npoints,nlev,ncol,rain_ls,snow_ls,grpl_ls, + & rain_cv,snow_cv,prec_frac, + & p,t,mx_rain_ls,mx_snow_ls,mx_grpl_ls, + & mx_rain_cv,mx_snow_cv) + + + implicit none + + INTEGER npoints ! number of model points in the horizontal + INTEGER nlev ! number of model levels in column + INTEGER ncol ! number of subcolumns + + INTEGER i,j,ilev,ibox + + REAL rain_ls(npoints,nlev),snow_ls(npoints,nlev) ! large-scale precipitation flux + REAL grpl_ls(npoints,nlev) + REAL rain_cv(npoints,nlev),snow_cv(npoints,nlev) ! convective precipitation flux + + REAL prec_frac(npoints,ncol,nlev) ! 0 -> clear sky + ! 1 -> LS precipitation + ! 2 -> CONV precipitation + ! 3 -> both + REAL mx_rain_ls(npoints,ncol,nlev),mx_snow_ls(npoints,ncol,nlev) + REAL mx_grpl_ls(npoints,ncol,nlev) + REAL mx_rain_cv(npoints,ncol,nlev),mx_snow_cv(npoints,ncol,nlev) + REAL p(npoints,nlev),t(npoints,nlev) + REAL ar,as,ag,br,bs,bg,nr,ns,ng,rho0,rhor,rhos,rhog,rho + REAL term1r,term1s,term1g,term2r,term2s,term2g,term3 + REAL term4r_ls,term4s_ls,term4g_ls,term4r_cv,term4s_cv + REAL term1x2r,term1x2s,term1x2g,t123r,t123s,t123g + + ! method from Khairoutdinov and Randall (2003 JAS) + + ! --- List of constants from Appendix B + ! Constant in fall speed formula + ar=842. + as=4.84 + ag=94.5 + ! Exponent in fall speed formula + br=0.8 + bs=0.25 + bg=0.5 + ! Intercept parameter + nr=8.*1000.*1000. + ns=3.*1000.*1000. + ng=4.*1000.*1000. + ! Densities for air and hydrometeors + rho0=1.29 + rhor=1000. + rhos=100. + rhog=400. + ! Term 1 of Eq. (A19). + term1r=ar*17.8379/6. + term1s=as*8.28508/6. + term1g=ag*11.6317/6. + ! Term 2 of Eq. (A19). + term2r=(3.14159265*rhor*nr)**(-br/4.) + term2s=(3.14159265*rhos*ns)**(-bs/4.) + term2g=(3.14159265*rhog*ng)**(-bg/4.) + + term1x2r=term1r*term2r + term1x2s=term1s*term2s + term1x2g=term1g*term2g + do ilev=1,nlev + do j=1,npoints + rho=p(j,ilev)/(287.05*t(j,ilev)) + term3=(rho0/rho)**0.5 + ! Term 4 of Eq. (A19). + t123r=term1x2r*term3 + t123s=term1x2s*term3 + t123g=term1x2g*term3 + term4r_ls=rain_ls(j,ilev)/(t123r) + term4s_ls=snow_ls(j,ilev)/(t123s) + term4g_ls=grpl_ls(j,ilev)/(t123g) + term4r_cv=rain_cv(j,ilev)/(t123r) + term4s_cv=snow_cv(j,ilev)/(t123s) + do ibox=1,ncol + mx_rain_ls(j,ibox,ilev)=0. + mx_snow_ls(j,ibox,ilev)=0. + mx_grpl_ls(j,ibox,ilev)=0. + mx_rain_cv(j,ibox,ilev)=0. + mx_snow_cv(j,ibox,ilev)=0. + if ((prec_frac(j,ibox,ilev) .eq. 1.) .or. + & (prec_frac(j,ibox,ilev) .eq. 3.)) then + mx_rain_ls(j,ibox,ilev)= + & (term4r_ls**(1./(1.+br/4.)))/rho + mx_snow_ls(j,ibox,ilev)= + & (term4s_ls**(1./(1.+bs/4.)))/rho + mx_grpl_ls(j,ibox,ilev)= + & (term4g_ls**(1./(1.+bg/4.)))/rho + endif + if ((prec_frac(j,ibox,ilev) .eq. 2.) .or. + & (prec_frac(j,ibox,ilev) .eq. 3.)) then + mx_rain_cv(j,ibox,ilev)= + & (term4r_cv**(1./(1.+br/4.)))/rho + mx_snow_cv(j,ibox,ilev)= + & (term4s_cv**(1./(1.+bs/4.)))/rho + endif + enddo ! loop over ncol + enddo ! loop over npoints + enddo ! loop over nlev + + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/phys_cosp.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/phys_cosp.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/phys_cosp.F90 (revision 1280) @@ -0,0 +1,465 @@ +! Simulateur COSP : Cfmip Observation Simulator Package +! ISCCP, Radar (QuickBeam), Lidar et Parasol (ACTSIM), MISR, RTTOVS +!Idelkadi Abderrahmane Aout-Septembre 2009 + + + subroutine phys_cosp( itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf, & + overlaplmdz,Nptslmdz,Nlevlmdz,lon,lat, presnivs, & + ref_liq,ref_ice,fracTerLic,u_wind,v_wind,phi,ph,p,skt,t, & + sh,rh,tca,cca,mr_lsliq,mr_lsice,fl_lsrainI,fl_lssnowI, & + fl_ccrainI,fl_ccsnowI,mr_ozone,dtau_s,dem_s) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!! Inputs : +! itap, !Increment de la physiq +! dtime, !Pas de temps physiq +! overlap, !Overlap type in SCOPS +! Npoints, !Nb de points de la grille physiq +! Nlevels, !Nb de niveaux verticaux +! Ncolumns, !Number of subcolumns +! lon,lat, !Longitudes et latitudes de la grille LMDZ +! ref_liq,ref_ice, !Rayons effectifs des particules liq et ice (en microm) +! fracTerLic, !Fraction terre a convertir en masque +! u_wind,v_wind, !Vents a 10m ??? +! phi, !Geopotentiel +! ph, !pression pour chaque inter-couche +! p, !Pression aux milieux des couches +! skt,t, !Temp au sol et temp 3D +! sh, !Humidite specifique +! rh, !Humidite relatif +! tca, !Fraction nuageuse +! cca !Fraction nuageuse convective +! mr_lsliq, !Liq Cloud water content +! mr_lsice, !Ice Cloud water content +! mr_ccliq, !Convective Cloud Liquid water content +! mr_ccice, !Cloud ice water content +! fl_lsrain, !Large scale precipitation lic +! fl_lssnow, !Large scale precipitation ice +! fl_ccrain, !Convective precipitation lic +! fl_ccsnow, !Convective precipitation ice +! mr_ozone, !Concentration ozone (Kg/Kg) +! dem_s !Cloud optical emissivity +! dtau_s !Cloud optical thickness +! emsfc_lw = 1. !Surface emissivity dans radlwsw.F90 + +!!! Outputs : +! calipso2D, !Lidar Low/heigh/Mean/Total-level Cloud Fraction +! calipso3D, !Lidar Cloud Fraction (532 nm) +! cfadlidar, !Lidar Scattering Ratio CFAD (532 nm) +! parasolrefl, !PARASOL-like mono-directional reflectance +! atb, !Lidar Attenuated Total Backscatter (532 nm) +! betamol, !Lidar Molecular Backscatter (532 nm) +! cfaddbze, !Radar Reflectivity Factor CFAD (94 GHz) +! clcalipso2, !Cloud frequency of occurrence as seen by CALIPSO but not CloudSat +! dbze, !Efective_reflectivity_factor +! cltlidarradar, !Lidar and Radar Total Cloud Fraction +! clMISR, !Cloud Fraction as Calculated by the MISR Simulator +! clisccp2, !Cloud Fraction as Calculated by the ISCCP Simulator +! boxtauisccp, !Optical Depth in Each Column as Calculated by the ISCCP Simulator +! boxptopisccp, !Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator +! tclisccp, !Total Cloud Fraction as Calculated by the ISCCP Simulator +! ctpisccp, !Mean Cloud Top Pressure as Calculated by the ISCCP Simulator +! tauisccp, !Mean Optical Depth as Calculated by the ISCCP Simulator +! albisccp, !Mean Cloud Albedo as Calculated by the ISCCP Simulator +! meantbisccp, !Mean all-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator +! meantbclrisccp !Mean clear-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + USE MOD_COSP + USE mod_phys_lmdz_para + use ioipsl + use iophy + + IMPLICIT NONE + + ! Local variables + character(len=64) :: cosp_input_nl='cosp_input_nl.txt' + character(len=64) :: cosp_output_nl='cosp_output_nl.txt' + character(len=512), save :: finput ! Input file name + character(len=512), save :: cmor_nl + integer, save :: isccp_topheight,isccp_topheight_direction,overlap + integer,save :: Ncolumns ! Number of subcolumns in SCOPS + integer,parameter :: Ncollmdz=20 + integer, save :: Npoints ! Number of gridpoints + integer, save :: Nlevels ! Number of levels + Integer :: Nptslmdz,Nlevlmdz ! Nb de points issus de physiq.F + integer, save :: Nlr ! Number of levels in statistical outputs + integer, save :: Npoints_it ! Max number of gridpoints to be processed in one iteration + integer :: i + type(cosp_config),save :: cfg ! Configuration options + type(cosp_gridbox) :: gbx ! Gridbox information. Input for COSP + type(cosp_subgrid) :: sgx ! Subgrid outputs + type(cosp_sgradar) :: sgradar ! Output from radar simulator + type(cosp_sglidar) :: sglidar ! Output from lidar simulator + type(cosp_isccp) :: isccp ! Output from ISCCP simulator + type(cosp_misr) :: misr ! Output from MISR simulator + type(cosp_vgrid) :: vgrid ! Information on vertical grid of stats + type(cosp_radarstats) :: stradar ! Summary statistics from radar simulator + type(cosp_lidarstats) :: stlidar ! Summary statistics from lidar simulator + + integer :: t0,t1,count_rate,count_max + integer :: Nlon,Nlat,geomode + real,save :: radar_freq,k2,ZenAng,co2,ch4,n2o,co,emsfc_lw + integer,dimension(RTTOV_MAX_CHANNELS),save :: Channels + real,dimension(RTTOV_MAX_CHANNELS),save :: Surfem + integer, save :: surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay + integer, save :: Nprmts_max_hydro,Naero,Nprmts_max_aero,lidar_ice_type + integer, save :: platform,satellite,Instrument,Nchannels + logical, save :: use_vgrid,csat_vgrid,use_precipitation_fluxes,use_reff + +! Declaration necessaires pour les sorties IOIPSL + integer :: ii,idayref + real :: zjulian,zstoday,zstomth,zstohf,zout,ecrit_day,ecrit_hf,ecrit_mth + integer :: nhori,nvert,nvertp,nvertisccp,nvertm,nvertcol + integer, save :: nid_day_cosp,nid_mth_cosp,nid_hf_cosp + logical, save :: debut_cosp=.true. + integer :: itau_wcosp + character(len=10),dimension(Ncollmdz) :: chcol=(/'c01','c02','c03','c04','c05','c06','c07','c08','c09','c10', & + 'c11','c12','c13','c14','c15','c16','c17','c18','c19','c20'/) + real,dimension(Ncollmdz) :: column_ax + integer, save :: Nlevout + + include "dimensions.h" + include "temps.h" + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Input variables from LMDZ-GCM + integer :: overlaplmdz ! overlap type: 1=max, 2=rand, 3=max/rand ! cosp input (output lmdz) +! real,dimension(Npoints,Nlevels) :: height,phi,p,ph,T,sh,rh,tca,cca,mr_lsliq,mr_lsice,mr_ccliq,mr_ccice, & + real,dimension(Nptslmdz,Nlevlmdz) :: height,phi,p,ph,T,sh,rh,tca,cca,mr_lsliq,mr_lsice,mr_ccliq,mr_ccice, & + fl_lsrain,fl_lssnow,fl_ccrain,fl_ccsnow,fl_lsgrpl, & + zlev,mr_ozone,radliq,radice,dtau_s,dem_s,ref_liq,ref_ice + real,dimension(Nptslmdz,Nlevlmdz) :: fl_lsrainI,fl_lssnowI,fl_ccrainI,fl_ccsnowI + real,dimension(Nptslmdz) :: lon,lat,skt,fracTerLic,u_wind,v_wind + real,dimension(Nlevlmdz) :: presnivs + integer :: itap,k,ip + real :: dtime,freq_cosp + +! + namelist/COSP_INPUT/cmor_nl,overlap,isccp_topheight,isccp_topheight_direction, & + npoints,npoints_it,ncolumns,nlevels,use_vgrid,nlr,csat_vgrid,finput, & + radar_freq,surface_radar,use_mie_tables, & + use_gas_abs,do_ray,melt_lay,k2,Nprmts_max_hydro,Naero,Nprmts_max_aero, & + lidar_ice_type,use_precipitation_fluxes,use_reff, & + platform,satellite,Instrument,Nchannels, & + Channels,Surfem,ZenAng,co2,ch4,n2o,co + +!---------------- End of declaration of variables -------------- + + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Read namelist with COSP inputs +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + if (debut_cosp) then +! Lecture du namelist input + open(10,file=cosp_input_nl,status='old') + read(10,nml=cosp_input) + close(10) +! Clefs Outputs + call read_cosp_output_nl(cosp_output_nl,cfg) + + if ( (Ncollmdz.ne.Ncolumns).or.(Nptslmdz.ne.Npoints).or.(Nlevlmdz.ne.Nlevels) ) then + print*,'Nb points Horiz, Vert, Sub-col passes par physiq.F = ', & + Nptslmdz, Nlevlmdz, Ncollmdz + print*,'Nb points Horiz, Vert, Sub-col lus dans namelist = ', & + Npoints, Nlevels, Ncolumns + print*,'Nb points Horiz, Vert, Sub-col passes par physiq.F est different de celui lu par namelist ' + call abort + endif + + if (overlaplmdz.ne.overlap) then + print*,'Attention overlaplmdz different de overlap lu dans namelist ' + endif + print*,'Fin lecture Namelists, debut_cosp =',debut_cosp + + print*,' Cles sorties cosp :' + print*,' Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim', & + cfg%Lradar_sim,cfg%Llidar_sim,cfg%Lisccp_sim,cfg%Lmisr_sim,cfg%Lrttov_sim + + endif ! debut_cosp + + print*,'Debut phys_cosp itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf ', & + itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Allocate local arrays +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! call system_clock(t0,count_rate,count_max) !!! Only for testing purposes + + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Allocate memory for gridbox type +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Allocating memory for gridbox type...' + + call construct_cosp_gridbox(float(itap),radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, & + Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, & + lidar_ice_type,isccp_topheight,isccp_topheight_direction,overlap,emsfc_lw, & + use_precipitation_fluxes,use_reff, & + Platform,Satellite,Instrument,Nchannels,ZenAng, & + channels(1:Nchannels),surfem(1:Nchannels),co2,ch4,n2o,co,gbx) + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Here code to populate input structure +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + print *, 'Populating input structure...' + gbx%longitude = lon + gbx%latitude = lat + + gbx%p = p ! + gbx%ph = ph + gbx%zlev_half = phi/9.81 + + do k = 1, Nlevels-1 + do ip = 1, Npoints + zlev(ip,k) = phi(ip,k)/9.81 + (phi(ip,k+1)-phi(ip,k))/9.81 * (ph(ip,k)-ph(ip,k+1))/p(ip,k) + enddo + enddo + do ip = 1, Npoints + zlev(ip,Nlevels) = zlev(ip,Nlevels-1)+ 2.*(phi(ip,Nlevels)/9.81-zlev(ip,Nlevels-1)) + END DO + gbx%zlev = zlev + + gbx%T = T + gbx%q = rh*100. + gbx%sh = sh + gbx%cca = cca !convective_cloud_amount (1) + gbx%tca = tca ! total_cloud_amount (1) + gbx%psfc = ph(:,1) !pression de surface + gbx%skt = skt !Skin temperature (K) + + do ip = 1, Npoints + if (fracTerLic(ip).ge.0.5) then + gbx%land(ip) = 1. + else + gbx%land(ip) = 0. + endif + enddo + gbx%mr_ozone = mr_ozone !mass_fraction_of_ozone_in_air (kg/kg) +! A voir l equivalent LMDZ (u10m et v10m) + gbx%u_wind = u_wind !eastward_wind (m s-1) + gbx%v_wind = v_wind !northward_wind +! Attention + gbx%sunlit = 1 + +! A voir l equivalent LMDZ + mr_ccliq = 0.0 + mr_ccice = 0.0 + gbx%mr_hydro(:,:,I_LSCLIQ) = mr_lsliq !mixing_ratio_large_scale_cloud_liquid (kg/kg) + gbx%mr_hydro(:,:,I_LSCICE) = mr_lsice !mixing_ratio_large_scale_cloud_ic + gbx%mr_hydro(:,:,I_CVCLIQ) = mr_ccliq !mixing_ratio_convective_cloud_liquid + gbx%mr_hydro(:,:,I_CVCICE) = mr_ccice !mixing_ratio_convective_cloud_ice +! A revoir + fl_lsrain = fl_lsrainI + fl_ccrainI + fl_lssnow = fl_lssnowI + fl_ccsnowI + gbx%rain_ls = fl_lsrain !flux_large_scale_cloud_rain (kg m^-2 s^-1) + gbx%snow_ls = fl_lssnow !flux_large_scale_cloud_snow +! A voir l equivalent LMDZ + fl_lsgrpl=0. + fl_ccsnow = 0. + fl_ccrain = 0. + gbx%grpl_ls = fl_lsgrpl !flux_large_scale_cloud_graupel + gbx%rain_cv = fl_ccrain !flux_convective_cloud_rain + gbx%snow_cv = fl_ccsnow !flux_convective_cloud_snow + +!Attention Teste +! do k = 1, Nlevels +! do ip = 1, Npoints +!! liquid particles : +! radliq(ip,k) = 12.0e-06 +! if (k.le.3) radliq(ip,k) = 11.0e-06 + +! ice particles : +! if ( (t(ip,k)-273.15).gt.-81.4 ) then +! radice(ip,k) = (0.71*(t(ip,k)-273.15)+61.29)*1e-6 +! else +! radice(ip,k) = 3.5*1e-6 +! endif +! END DO +! END DO + +! gbx%Reff(:,:,I_LSCLIQ) = radliq +! gbx%Reff(:,:,I_LSCICE) = radice +! gbx%Reff(:,:,I_CVCLIQ) = radliq +! gbx%Reff(:,:,I_CVCICE) = radice +! print*,'radliq(1,:)=',radliq(1,:) +! print*,'radice(1,:)=',radice(1,:) + + gbx%Reff(:,:,I_LSCLIQ) = ref_liq*1e-6 + gbx%Reff(:,:,I_LSCICE) = ref_ice*1e-6 + gbx%Reff(:,:,I_CVCLIQ) = ref_liq*1e-6 + gbx%Reff(:,:,I_CVCICE) = ref_ice*1e-6 +! print*,'ref_liq(1,:)=',ref_liq(1,:)*1e-6 +! print*,'ref_liq(1,:)=',ref_ice(1,:)*1e-6 + + ! ISCCP simulator + gbx%dtau_s = dtau_s + gbx%dtau_c = 0. + gbx%dem_s = dem_s + gbx%dem_c = 0. + +! Surafce emissivity + emsfc_lw = 1. + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Define new vertical grid +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Defining new vertical grid...' + call construct_cosp_vgrid(gbx,Nlr,use_vgrid,csat_vgrid,vgrid) + + if (debut_cosp) then +! Creer le fichier de sorie, definir les variable de sortie + ! Axe verticale (Pa ou Km) + Nlevout = vgrid%Nlvgrid + + do ii=1,Ncolumns + column_ax(ii) = float(ii) + enddo + + include "ini_histmthCOSP.h" + include "ini_histdayCOSP.h" + include "ini_histhfCOSP.h" + + +! print*,'Fin Initialisation des sorties COSP, debut_cosp =',debut_cosp +! print*,'R_UNDEF=',R_UNDEF + + debut_cosp=.false. + endif ! debut_cosp + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Allocate memory for other types +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Allocating memory for other types...' + call construct_cosp_subgrid(Npoints, Ncolumns, Nlevels, sgx) + call construct_cosp_sgradar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,sgradar) + call construct_cosp_radarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar) + call construct_cosp_sglidar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar) + call construct_cosp_lidarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar) + call construct_cosp_isccp(cfg,Npoints,Ncolumns,Nlevels,isccp) + call construct_cosp_misr(cfg,Npoints,misr) +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Call simulator +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Calling simulator...' + call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar) +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Write outputs to CMOR-compliant NetCDF +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +! A traiter le cas ou l on a des valeurs indefinies +! Attention teste + +! if(1.eq.0)then + + + do k = 1,Nlevout + do ip = 1,Npoints + if(stlidar%lidarcld(ip,k).eq.R_UNDEF)then + stlidar%lidarcld(ip,k)=0. + endif + enddo + + + do ii= 1,SR_BINS + do ip = 1,Npoints + if(stlidar%cfad_sr(ip,ii,k).eq.R_UNDEF)then + stlidar%cfad_sr(ip,ii,k)=0. + endif + enddo + enddo + enddo + + do ip = 1,Npoints + do k = 1,Nlevlmdz + if(sglidar%beta_mol(ip,k).eq.R_UNDEF)then + sglidar%beta_mol(ip,k)=0. + endif + + do ii= 1,Ncolumns + if(sglidar%beta_tot(ip,ii,k).eq.R_UNDEF)then + sglidar%beta_tot(ip,ii,k)=0. + endif + enddo + + enddo !k = 1,Nlevlmdz + enddo !ip = 1,Npoints + + do k = 1,LIDAR_NCAT + do ip = 1,Npoints + if(stlidar%cldlayer(ip,k).eq.R_UNDEF)then + stlidar%cldlayer(ip,k)=0. + endif + enddo + enddo + +! endif + + do ip = 1,Npoints + if(isccp%totalcldarea(ip).eq.-1.E+30)then + isccp%totalcldarea(ip)=0. + endif + if(isccp%meanptop(ip).eq.-1.E+30)then + isccp%meanptop(ip)=0. + endif + if(isccp%meantaucld(ip).eq.-1.E+30)then + isccp%meantaucld(ip)=0. + endif + if(isccp%meanalbedocld(ip).eq.-1.E+30)then + isccp%meanalbedocld(ip)=0. + endif + if(isccp%meantb(ip).eq.-1.E+30)then + isccp%meantb(ip)=0. + endif + if(isccp%meantbclr(ip).eq.-1.E+30)then + isccp%meantbclr(ip)=0. + endif + + do k=1,7 + do ii=1,7 + if(isccp%fq_isccp(ip,ii,k).eq.-1.E+30)then + isccp%fq_isccp(ip,ii,k)=0. + endif + enddo + enddo + + do ii=1,Ncolumns + if(isccp%boxtau(ip,ii).eq.-1.E+30)then + isccp%boxtau(ip,ii)=0. + endif + enddo + + do ii=1,Ncolumns + if(isccp%boxptop(ip,ii).eq.-1.E+30)then + isccp%boxptop(ip,ii)=0. + endif + enddo + enddo + + include "write_histmthCOSP.h" + include "write_histdayCOSP.h" + include "write_histhfCOSP.h" + + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Deallocate memory in derived types +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Deallocating memory...' + call free_cosp_gridbox(gbx) + call free_cosp_subgrid(sgx) + call free_cosp_sgradar(sgradar) + call free_cosp_radarstats(stradar) + call free_cosp_sglidar(sglidar) + call free_cosp_lidarstats(stlidar) + call free_cosp_isccp(isccp) + call free_cosp_misr(misr) + call free_cosp_vgrid(vgrid) + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Time in s. Only for testing purposes +! call system_clock(t1,count_rate,count_max) +! print *,(t1-t0)*1.0/count_rate + +end subroutine phys_cosp Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/phys_cosp.F90.prev =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/phys_cosp.F90.prev (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/phys_cosp.F90.prev (revision 1280) @@ -0,0 +1,456 @@ +! Simulateur COSP : Cfmip Observation Simulator Package +! ISCCP, Radar (QuickBeam), Lidar et Parasol (ACTSIM), MISR, RTTOVS +!Idelkadi Abderrahmane Aout-Septembre 2009 + + subroutine phys_cosp( itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf, & + overlaplmdz,Nptslmdz,Nlevlmdz,lon,lat, presnivs, & + ref_liq,ref_ice,fracTerLic,u_wind,v_wind,phi,ph,p,skt,t, & + sh,rh,tca,cca,mr_lsliq,mr_lsice,fl_lsrainI,fl_lssnowI, & + fl_ccrainI,fl_ccsnowI,mr_ozone,dtau_s,dem_s) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!! Inputs : +! itap, !Increment de la physiq +! dtime, !Pas de temps physiq +! overlap, !Overlap type in SCOPS +! Npoints, !Nb de points de la grille physiq +! Nlevels, !Nb de niveaux verticaux +! Ncolumns, !Number of subcolumns +! lon,lat, !Longitudes et latitudes de la grille LMDZ +! ref_liq,ref_ice, !Rayons effectifs des particules liq et ice (en microm) +! fracTerLic, !Fraction terre a convertir en masque +! u_wind,v_wind, !Vents a 10m ??? +! phi, !Geopotentiel +! ph, !pression pour chaque inter-couche +! p, !Pression aux milieux des couches +! skt,t, !Temp au sol et temp 3D +! sh, !Humidite specifique +! rh, !Humidite relatif +! tca, !Fraction nuageuse +! cca !Fraction nuageuse convective +! mr_lsliq, !Liq Cloud water content +! mr_lsice, !Ice Cloud water content +! mr_ccliq, !Convective Cloud Liquid water content +! mr_ccice, !Cloud ice water content +! fl_lsrain, !Large scale precipitation lic +! fl_lssnow, !Large scale precipitation ice +! fl_ccrain, !Convective precipitation lic +! fl_ccsnow, !Convective precipitation ice +! mr_ozone, !Concentration ozone (Kg/Kg) +! dem_s !Cloud optical emissivity +! dtau_s !Cloud optical thickness +! emsfc_lw = 1. !Surface emissivity dans radlwsw.F90 + +!!! Outputs : +! calipso2D, !Lidar Low/heigh/Mean/Total-level Cloud Fraction +! calipso3D, !Lidar Cloud Fraction (532 nm) +! cfadlidar, !Lidar Scattering Ratio CFAD (532 nm) +! parasolrefl, !PARASOL-like mono-directional reflectance +! atb, !Lidar Attenuated Total Backscatter (532 nm) +! betamol, !Lidar Molecular Backscatter (532 nm) +! cfaddbze, !Radar Reflectivity Factor CFAD (94 GHz) +! clcalipso2, !Cloud frequency of occurrence as seen by CALIPSO but not CloudSat +! dbze, !Efective_reflectivity_factor +! cltlidarradar, !Lidar and Radar Total Cloud Fraction +! clMISR, !Cloud Fraction as Calculated by the MISR Simulator +! clisccp2, !Cloud Fraction as Calculated by the ISCCP Simulator +! boxtauisccp, !Optical Depth in Each Column as Calculated by the ISCCP Simulator +! boxptopisccp, !Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator +! tclisccp, !Total Cloud Fraction as Calculated by the ISCCP Simulator +! ctpisccp, !Mean Cloud Top Pressure as Calculated by the ISCCP Simulator +! tauisccp, !Mean Optical Depth as Calculated by the ISCCP Simulator +! albisccp, !Mean Cloud Albedo as Calculated by the ISCCP Simulator +! meantbisccp, !Mean all-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator +! meantbclrisccp !Mean clear-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + USE MOD_COSP + USE mod_phys_lmdz_para + use ioipsl + use iophy + + IMPLICIT NONE + + ! Local variables + character(len=64) :: cosp_input_nl='cosp_input_nl.txt' + character(len=64) :: cosp_output_nl='cosp_output_nl.txt' + character(len=512), save :: finput ! Input file name + character(len=512), save :: cmor_nl + integer, save :: isccp_topheight,isccp_topheight_direction,overlap + integer,save :: Ncolumns ! Number of subcolumns in SCOPS + integer,parameter :: Ncollmdz=20 + integer, save :: Npoints ! Number of gridpoints + integer, save :: Nlevels ! Number of levels + Integer :: Nptslmdz,Nlevlmdz ! Nb de points issus de physiq.F + integer, save :: Nlr ! Number of levels in statistical outputs + integer, save :: Npoints_it ! Max number of gridpoints to be processed in one iteration + integer :: i + type(cosp_config),save :: cfg ! Configuration options + type(cosp_gridbox) :: gbx ! Gridbox information. Input for COSP + type(cosp_subgrid) :: sgx ! Subgrid outputs + type(cosp_sgradar) :: sgradar ! Output from radar simulator + type(cosp_sglidar) :: sglidar ! Output from lidar simulator + type(cosp_isccp) :: isccp ! Output from ISCCP simulator + type(cosp_misr) :: misr ! Output from MISR simulator + type(cosp_vgrid) :: vgrid ! Information on vertical grid of stats + type(cosp_radarstats) :: stradar ! Summary statistics from radar simulator + type(cosp_lidarstats) :: stlidar ! Summary statistics from lidar simulator + + integer :: t0,t1,count_rate,count_max + integer :: Nlon,Nlat,geomode + real,save :: radar_freq,k2,ZenAng,co2,ch4,n2o,co,emsfc_lw + integer,dimension(RTTOV_MAX_CHANNELS),save :: Channels + real,dimension(RTTOV_MAX_CHANNELS),save :: Surfem + integer, save :: surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay + integer, save :: Nprmts_max_hydro,Naero,Nprmts_max_aero,lidar_ice_type + integer, save :: platform,satellite,Instrument,Nchannels + logical, save :: use_vgrid,csat_vgrid,use_precipitation_fluxes,use_reff + +! Declaration necessaires pour les sorties IOIPSL + integer :: ii,idayref + real :: zjulian,zstoday,zstomth,zstohf,zout,ecrit_day,ecrit_hf,ecrit_mth + integer :: nhori,nvert,nvertp,nvertisccp,nvertm,nvertcol + integer, save :: nid_day_cosp,nid_mth_cosp,nid_hf_cosp + logical, save :: debut_cosp=.true. + integer :: itau_wcosp + character(len=10),dimension(Ncollmdz) :: chcol=(/'c01','c02','c03','c04','c05','c06','c07','c08','c09','c10', & + 'c11','c12','c13','c14','c15','c16','c17','c18','c19','c20'/) + real,dimension(Ncollmdz) :: column_ax + integer, save :: Nlevout + + include "dimensions.h" + include "temps.h" + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Input variables from LMDZ-GCM + integer :: overlaplmdz ! overlap type: 1=max, 2=rand, 3=max/rand ! cosp input (output lmdz) +! real,dimension(Npoints,Nlevels) :: height,phi,p,ph,T,sh,rh,tca,cca,mr_lsliq,mr_lsice,mr_ccliq,mr_ccice, & + real,dimension(Nptslmdz,Nlevlmdz) :: height,phi,p,ph,T,sh,rh,tca,cca,mr_lsliq,mr_lsice,mr_ccliq,mr_ccice, & + fl_lsrain,fl_lssnow,fl_ccrain,fl_ccsnow,fl_lsgrpl, & + zlev,mr_ozone,radliq,radice,dtau_s,dem_s + real,dimension(Nptslmdz,Nlevlmdz) :: fl_lsrainI,fl_lssnowI,fl_ccrainI,fl_ccsnowI + real,dimension(Nptslmdz) :: lon,lat,skt,fracTerLic,u_wind,v_wind + real,dimension(Nlevlmdz) :: presnivs + real :: ref_liq,ref_ice + integer :: itap,k,ip + real :: dtime,freq_cosp + +! + namelist/COSP_INPUT/cmor_nl,overlap,isccp_topheight,isccp_topheight_direction, & + npoints,npoints_it,ncolumns,nlevels,use_vgrid,nlr,csat_vgrid,finput, & + radar_freq,surface_radar,use_mie_tables, & + use_gas_abs,do_ray,melt_lay,k2,Nprmts_max_hydro,Naero,Nprmts_max_aero, & + lidar_ice_type,use_precipitation_fluxes,use_reff, & + platform,satellite,Instrument,Nchannels, & + Channels,Surfem,ZenAng,co2,ch4,n2o,co + +!---------------- End of declaration of variables -------------- + + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Read namelist with COSP inputs +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + if (debut_cosp) then +! Lecture du namelist input + open(10,file=cosp_input_nl,status='old') + read(10,nml=cosp_input) + close(10) +! Clefs Outputs + call read_cosp_output_nl(cosp_output_nl,cfg) + + if ( (Ncollmdz.ne.Ncolumns).or.(Nptslmdz.ne.Npoints).or.(Nlevlmdz.ne.Nlevels) ) then + print*,'Nb points Horiz, Vert, Sub-col passes par physiq.F = ', & + Nptslmdz, Nlevlmdz, Ncollmdz + print*,'Nb points Horiz, Vert, Sub-col lus dans namelist = ', & + Npoints, Nlevels, Ncolumns + print*,'Nb points Horiz, Vert, Sub-col passes par physiq.F est different de celui lu par namelist ' + call abort + endif + + if (overlaplmdz.ne.overlap) then + print*,'Attention overlaplmdz different de overlap lu dans namelist ' + endif + print*,'Fin lecture Namelists, debut_cosp =',debut_cosp + + endif ! debut_cosp + + print*,'Debut phys_cosp itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf ', & + itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Allocate local arrays +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! call system_clock(t0,count_rate,count_max) !!! Only for testing purposes + + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Allocate memory for gridbox type +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Allocating memory for gridbox type...' + print*,'Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro ',Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro + print*,' Cles sorties cosp :' + print*,' Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim', & + cfg%Lradar_sim,cfg%Llidar_sim,cfg%Lisccp_sim,cfg%Lmisr_sim,cfg%Lrttov_sim + call construct_cosp_gridbox(float(itap),radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, & + Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, & + lidar_ice_type,isccp_topheight,isccp_topheight_direction,overlap,emsfc_lw, & + use_precipitation_fluxes,use_reff, & + Platform,Satellite,Instrument,Nchannels,ZenAng, & + channels(1:Nchannels),surfem(1:Nchannels),co2,ch4,n2o,co,gbx) + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Here code to populate input structure +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + print *, 'Populating input structure...' + gbx%longitude = lon + gbx%latitude = lat + + gbx%p = p ! + gbx%ph = ph + gbx%zlev_half = phi/9.81 + + do k = 1, Nlevels-1 + do ip = 1, Npoints + zlev(ip,k) = phi(ip,k)/9.81 + (phi(ip,k+1)-phi(ip,k))/9.81 * (ph(ip,k)-ph(ip,k+1))/p(ip,k) + enddo + enddo + do ip = 1, Npoints + zlev(ip,Nlevels) = zlev(ip,Nlevels-1)+ 2.*(phi(ip,Nlevels)/9.81-zlev(ip,Nlevels-1)) + END DO + gbx%zlev = zlev + + gbx%T = T + gbx%q = rh*100. + gbx%sh = sh + gbx%cca = cca !convective_cloud_amount (1) + gbx%tca = tca ! total_cloud_amount (1) + gbx%psfc = ph(:,1) !pression de surface + gbx%skt = skt !Skin temperature (K) + + do ip = 1, Npoints + if (fracTerLic(ip).ge.0.5) then + gbx%land(ip) = 1. + else + gbx%land(ip) = 0. + endif + enddo + gbx%mr_ozone = mr_ozone !mass_fraction_of_ozone_in_air (kg/kg) +! A voir l equivalent LMDZ (u10m et v10m) + gbx%u_wind = u_wind !eastward_wind (m s-1) + gbx%v_wind = v_wind !northward_wind +! Attention + gbx%sunlit = 1 + +! A voir l equivalent LMDZ + mr_ccliq = 0.0 + mr_ccice = 0.0 + gbx%mr_hydro(:,:,I_LSCLIQ) = mr_lsliq !mixing_ratio_large_scale_cloud_liquid (kg/kg) + gbx%mr_hydro(:,:,I_LSCICE) = mr_lsice !mixing_ratio_large_scale_cloud_ic + gbx%mr_hydro(:,:,I_CVCLIQ) = mr_ccliq !mixing_ratio_convective_cloud_liquid + gbx%mr_hydro(:,:,I_CVCICE) = mr_ccice !mixing_ratio_convective_cloud_ice +! A revoir + fl_lsrain = fl_lsrainI + fl_ccrainI + fl_lssnow = fl_lssnowI + fl_ccsnowI + gbx%rain_ls = fl_lsrain !flux_large_scale_cloud_rain (kg m^-2 s^-1) + gbx%snow_ls = fl_lssnow !flux_large_scale_cloud_snow +! A voir l equivalent LMDZ + fl_lsgrpl=0. + fl_ccsnow = 0. + fl_ccrain = 0. + gbx%grpl_ls = fl_lsgrpl !flux_large_scale_cloud_graupel + gbx%rain_cv = fl_ccrain !flux_convective_cloud_rain + gbx%snow_cv = fl_ccsnow !flux_convective_cloud_snow + +!Attention Teste + do k = 1, Nlevels + do ip = 1, Npoints +! liquid particles : + radliq(ip,k) = 12.0e-06 + if (k.le.3) radliq(ip,k) = 11.0e-06 + +! ice particles : + if ( (t(ip,k)-273.15).gt.-81.4 ) then + radice(ip,k) = (0.71*(t(ip,k)-273.15)+61.29)*1e-6 + else + radice(ip,k) = 3.5*1e-6 + endif + END DO + END DO + gbx%Reff(:,:,I_LSCLIQ) = radliq + gbx%Reff(:,:,I_LSCICE) = radice + gbx%Reff(:,:,I_CVCLIQ) = radliq + gbx%Reff(:,:,I_CVCICE) = radice + + ! ISCCP simulator + gbx%dtau_s = dtau_s + print*,'dtau_s(1,:)=',gbx%dtau_s(1,:) + gbx%dtau_c = 0. + gbx%dem_s = dem_s + print*,'dem_s(1,:)=',gbx%dem_s(1,:) + gbx%dem_c = 0. + +! Surafce emissivity + emsfc_lw = 1. + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Define new vertical grid +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Defining new vertical grid...' + call construct_cosp_vgrid(gbx,Nlr,use_vgrid,csat_vgrid,vgrid) + + if (debut_cosp) then +! Creer le fichier de sorie, definir les variable de sortie + ! Axe verticale (Pa ou Km) + Nlevout = vgrid%Nlvgrid + + do ii=1,Ncolumns + column_ax(ii) = float(ii) + enddo + + include "ini_histmthCOSP.h" + include "ini_histdayCOSP.h" + include "ini_histhfCOSP.h" + + print*,'Fin Initialisation des sorties COSP, debut_cosp =',debut_cosp + print*,'R_UNDEF=',R_UNDEF + + debut_cosp=.false. + endif ! debut_cosp + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Allocate memory for other types +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Allocating memory for other types...' + call construct_cosp_subgrid(Npoints, Ncolumns, Nlevels, sgx) + call construct_cosp_sgradar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,sgradar) + call construct_cosp_radarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar) + call construct_cosp_sglidar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar) + call construct_cosp_lidarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar) + call construct_cosp_isccp(cfg,Npoints,Ncolumns,Nlevels,isccp) + call construct_cosp_misr(cfg,Npoints,misr) +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Call simulator +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Calling simulator...' + call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar) + print*,'stlidar%lidarcld(1,:)=',stlidar%lidarcld(1,:) +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Write outputs to CMOR-compliant NetCDF +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +! A traiter le cas ou l on a des valeurs indefinies +! Attention teste + +! if(1.eq.0)then + + + do k = 1,Nlevout +! do ip = 1,Npoints +! if(stlidar%lidarcld(ip,k).eq.R_UNDEF)then +! stlidar%lidarcld(ip,k)=0. +! endif +! enddo + + + do ii= 1,SR_BINS + do ip = 1,Npoints + if(stlidar%cfad_sr(ip,ii,k).eq.R_UNDEF)then + stlidar%cfad_sr(ip,ii,k)=0. + endif + enddo + enddo + enddo + + do ip = 1,Npoints + do k = 1,Nlevlmdz + if(sglidar%beta_mol(ip,k).eq.R_UNDEF)then + sglidar%beta_mol(ip,k)=0. + endif + + do ii= 1,Ncolumns + if(sglidar%beta_tot(ip,ii,k).eq.R_UNDEF)then + sglidar%beta_tot(ip,ii,k)=0. + endif + enddo + + enddo !k = 1,Nlevlmdz + enddo !ip = 1,Npoints + + do k = 1,LIDAR_NCAT + do ip = 1,Npoints + if(stlidar%cldlayer(ip,k).eq.R_UNDEF)then + stlidar%cldlayer(ip,k)=0. + endif + enddo + enddo + +! endif + + do ip = 1,Npoints + if(isccp%totalcldarea(ip).eq.-1.E+30)then + isccp%totalcldarea(ip)=0. + endif + if(isccp%meanptop(ip).eq.-1.E+30)then + isccp%meanptop(ip)=0. + endif + if(isccp%meantaucld(ip).eq.-1.E+30)then + isccp%meantaucld(ip)=0. + endif + if(isccp%meanalbedocld(ip).eq.-1.E+30)then + isccp%meanalbedocld(ip)=0. + endif + if(isccp%meantb(ip).eq.-1.E+30)then + isccp%meantb(ip)=0. + endif + if(isccp%meantbclr(ip).eq.-1.E+30)then + isccp%meantbclr(ip)=0. + endif + + do k=1,7 + do ii=1,7 + if(isccp%fq_isccp(ip,ii,k).eq.-1.E+30)then + isccp%fq_isccp(ip,ii,k)=0. + endif + enddo + enddo + + do ii=1,Ncolumns + if(isccp%boxtau(ip,ii).eq.-1.E+30)then + isccp%boxtau(ip,ii)=0. + endif + enddo + + do ii=1,Ncolumns + if(isccp%boxptop(ip,ii).eq.-1.E+30)then + isccp%boxptop(ip,ii)=0. + endif + enddo + enddo + + include "write_histmthCOSP.h" + include "write_histdayCOSP.h" + include "write_histhfCOSP.h" + + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Deallocate memory in derived types +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Deallocating memory...' + call free_cosp_gridbox(gbx) + call free_cosp_subgrid(sgx) + call free_cosp_sgradar(sgradar) + call free_cosp_radarstats(stradar) + call free_cosp_sglidar(sglidar) + call free_cosp_lidarstats(stlidar) + call free_cosp_isccp(isccp) + call free_cosp_misr(misr) + call free_cosp_vgrid(vgrid) + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Time in s. Only for testing purposes +! call system_clock(t1,count_rate,count_max) +! print *,(t1-t0)*1.0/count_rate + +end subroutine phys_cosp Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/prec_scops.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/prec_scops.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/prec_scops.F (revision 1280) @@ -0,0 +1,268 @@ +! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation +! nor the names of its contributors may be used to endorse or promote products derived from +! this software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + subroutine prec_scops(npoints,nlev,ncol,ls_p_rate,cv_p_rate, + & frac_out,prec_frac) + + + implicit none + + INTEGER npoints ! number of model points in the horizontal + INTEGER nlev ! number of model levels in column + INTEGER ncol ! number of subcolumns + + INTEGER i,j,ilev,ibox,cv_col + + REAL ls_p_rate(npoints,nlev),cv_p_rate(npoints,nlev) + + REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into + ! Equivalent of BOX in original version, but + ! indexed by column then row, rather than + ! by row then column + !TOA to SURFACE!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + REAL prec_frac(npoints,ncol,nlev) ! 0 -> clear sky + ! 1 -> LS precipitation + ! 2 -> CONV precipitation + ! 3 -> both + !TOA to SURFACE!!!!!!!!!!!!!!!!!! + + INTEGER flag_ls, flag_cv + INTEGER frac_out_ls(npoints,ncol),frac_out_cv(npoints,ncol) !flag variables for + ! stratiform cloud and convective cloud in the vertical column + + cv_col = 0.05*ncol + if (cv_col .eq. 0) cv_col=1 + + do ilev=1,nlev + do ibox=1,ncol + do j=1,npoints + prec_frac(j,ibox,ilev) = 0 + enddo + enddo + enddo + + do j=1,npoints + do ibox=1,ncol + frac_out_ls(j,ibox)=0 + frac_out_cv(j,ibox)=0 + flag_ls=0 + flag_cv=0 + do ilev=1,nlev + if (frac_out(j,ibox,ilev) .eq. 1) then + flag_ls=1 + endif + if (frac_out(j,ibox,ilev) .eq. 2) then + flag_cv=1 + endif + enddo !loop over nlev + if (flag_ls .eq. 1) then + frac_out_ls(j,ibox)=1 + endif + if (flag_cv .eq. 1) then + frac_out_cv(j,ibox)=1 + endif + enddo ! loop over ncol + enddo ! loop over npoints + +! initialize the top layer + do j=1,npoints + flag_ls=0 + flag_cv=0 + + if (ls_p_rate(j,1) .gt. 0.) then + do ibox=1,ncol ! possibility ONE + if (frac_out(j,ibox,1) .eq. 1) then + prec_frac(j,ibox,1) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + if (flag_ls .eq. 0) then ! possibility THREE + do ibox=1,ncol + if (frac_out(j,ibox,2) .eq. 1) then + prec_frac(j,ibox,1) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + endif + if (flag_ls .eq. 0) then ! possibility Four + do ibox=1,ncol + if (frac_out_ls(j,ibox) .eq. 1) then + prec_frac(j,ibox,1) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + endif + if (flag_ls .eq. 0) then ! possibility Five + do ibox=1,ncol +! prec_frac(j,1:ncol,1) = 1 + prec_frac(j,ibox,1) = 1 + enddo ! loop over ncol + endif + endif + ! There is large scale precipitation + + if (cv_p_rate(j,1) .gt. 0.) then + do ibox=1,ncol ! possibility ONE + if (frac_out(j,ibox,1) .eq. 2) then + if (prec_frac(j,ibox,1) .eq. 0) then + prec_frac(j,ibox,1) = 2 + else + prec_frac(j,ibox,1) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + if (flag_cv .eq. 0) then ! possibility THREE + do ibox=1,ncol + if (frac_out(j,ibox,2) .eq. 2) then + if (prec_frac(j,ibox,1) .eq. 0) then + prec_frac(j,ibox,1) = 2 + else + prec_frac(j,ibox,1) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + endif + if (flag_cv .eq. 0) then ! possibility Four + do ibox=1,ncol + if (frac_out_cv(j,ibox) .eq. 1) then + if (prec_frac(j,ibox,1) .eq. 0) then + prec_frac(j,ibox,1) = 2 + else + prec_frac(j,ibox,1) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + endif + if (flag_cv .eq. 0) then ! possibility Five + do ibox=1,cv_col + if (prec_frac(j,ibox,1) .eq. 0) then + prec_frac(j,ibox,1) = 2 + else + prec_frac(j,ibox,1) = 3 + endif + enddo !loop over cv_col + endif + endif + ! There is convective precipitation + + enddo ! loop over npoints +! end of initializing the top layer + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! working on the levels from top to surface + do ilev=2,nlev + do j=1,npoints + flag_ls=0 + flag_cv=0 + + if (ls_p_rate(j,ilev) .gt. 0.) then + do ibox=1,ncol ! possibility ONE&TWO + if ((frac_out(j,ibox,ilev) .eq. 1) .or. + & ((prec_frac(j,ibox,ilev-1) .eq. 1) + & .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then + prec_frac(j,ibox,ilev) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + if ((flag_ls .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE + do ibox=1,ncol + if (frac_out(j,ibox,ilev+1) .eq. 1) then + prec_frac(j,ibox,ilev) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + endif + if (flag_ls .eq. 0) then ! possibility Four + do ibox=1,ncol + if (frac_out_ls(j,ibox) .eq. 1) then + prec_frac(j,ibox,ilev) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + endif + if (flag_ls .eq. 0) then ! possibility Five + do ibox=1,ncol +! prec_frac(j,1:ncol,ilev) = 1 + prec_frac(j,ibox,ilev) = 1 + enddo ! loop over ncol + endif + endif ! There is large scale precipitation + + if (cv_p_rate(j,ilev) .gt. 0.) then + do ibox=1,ncol ! possibility ONE&TWO + if ((frac_out(j,ibox,ilev) .eq. 2) .or. + & ((prec_frac(j,ibox,ilev-1) .eq. 2) + & .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then + if (prec_frac(j,ibox,ilev) .eq. 0) then + prec_frac(j,ibox,ilev) = 2 + else + prec_frac(j,ibox,ilev) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + if ((flag_cv .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE + do ibox=1,ncol + if (frac_out(j,ibox,ilev+1) .eq. 2) then + if (prec_frac(j,ibox,ilev) .eq. 0) then + prec_frac(j,ibox,ilev) = 2 + else + prec_frac(j,ibox,ilev) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + endif + if (flag_cv .eq. 0) then ! possibility Four + do ibox=1,ncol + if (frac_out_cv(j,ibox) .eq. 1) then + if (prec_frac(j,ibox,ilev) .eq. 0) then + prec_frac(j,ibox,ilev) = 2 + else + prec_frac(j,ibox,ilev) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + endif + if (flag_cv .eq. 0) then ! possibility Five + do ibox=1,cv_col + if (prec_frac(j,ibox,ilev) .eq. 0) then + prec_frac(j,ibox,ilev) = 2 + else + prec_frac(j,ibox,ilev) = 3 + endif + enddo !loop over cv_col + endif + endif ! There is convective precipitation + + enddo ! loop over npoints + enddo ! loop over nlev + + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/radar_simulator.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/radar_simulator.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/radar_simulator.F90 (revision 1280) @@ -0,0 +1,511 @@ + subroutine radar_simulator(freq,k2,do_ray,use_gas_abs,use_mie_table,mt, & + nhclass,hp,nprof,ngate,nsizes,D,hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix, & + rh_matrix,Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe, & + g_to_vol_in,g_to_vol_out) + +! rh_matrix,Ze_non,Ze_ray,kr_matrix,g_atten_to_vol,dBZe) + + use m_mrgrnk + use array_lib + use math_lib + use optics_lib + use radar_simulator_types + implicit none + +! Purpose: +! Simulates a vertical profile of radar reflectivity +! Part of QuickBeam v1.04 by John Haynes & Roger Marchand +! +! Inputs: +! [freq] radar frequency (GHz), can be anything unless +! use_mie_table=1, in which case one of 94,35,13.8,9.6,3 +! [k2] |K|^2, the dielectric constant, set to -1 to use the +! frequency dependent default +! [do_ray] 1=do Rayleigh calcs, 0=not +! [use_gas_abs] 1=do gaseous abs calcs, 0=not, +! 2=use same as first profile (undocumented) +! [use_mie_table] 1=use Mie tables, 0=not +! [mt] Mie look up table +! [nhclass] number of hydrometeor types +! [hp] structure that defines hydrometeor types +! [nprof] number of hydrometeor profiles +! [ngate] number of vertical layers +! [nsizes] number of discrete particles in [D] +! [D] array of discrete particles (um) +! +! (The following 5 arrays must be in order from closest to the radar +! to farthest...) +! [hgt_matrix] height of hydrometeors (km) +! [hm_matrix] table of hydrometeor mixing rations (g/kg) +! [re_matrix] OPTIONAL table of hydrometeor effective radii (microns) +! [p_matrix] pressure profile (hPa) +! [t_matrix] temperature profile (C) +! [rh_matrix] relative humidity profile (%) +! +! Outputs: +! [Ze_non] radar reflectivity without attenuation (dBZ) +! [Ze_ray] Rayleigh reflectivity (dBZ) +! [h_atten_to_vol] attenuation by hydromets, radar to vol (dB) +! [g_atten_to_vol] gaseous atteunation, radar to vol (dB) +! [dBZe] effective radar reflectivity factor (dBZ) +! +! Optional: +! [g_to_vol_in] integrated atten due to gases, r>v (dB). +! If present then is used as gaseous absorption, independently of the +! value in use_gas_abs +! [g_to_vol_out] integrated atten due to gases, r>v (dB). +! If present then gaseous absorption for each profile is returned here. +! +! Created: +! 11/28/2005 John Haynes (haynes@atmos.colostate.edu) +! Modified: +! 09/2006 placed into subroutine form, scaling factors (Roger Marchand,JMH) +! 08/2007 added equivalent volume spheres, Z and N scalling most distrubtion types (Roger Marchand) +! 01/2008 'Do while' to determine if hydrometeor(s) present in volume +! changed for vectorization purposes (A. Bodas-Salcedo) + +! ----- INPUTS ----- + type(mie), intent(in) :: mt + type(class_param), intent(inout) :: hp + real*8, intent(in) :: freq,k2 + integer, intent(in) :: do_ray,use_gas_abs,use_mie_table, & + nhclass,nprof,ngate,nsizes + real*8, dimension(nsizes), intent(in) :: D + real*8, dimension(nprof,ngate), intent(in) :: hgt_matrix, p_matrix, & + t_matrix,rh_matrix + real*8, dimension(nhclass,nprof,ngate), intent(in) :: hm_matrix + real*8, dimension(nhclass,nprof,ngate), intent(inout) :: re_matrix + +! ----- OUTPUTS ----- + real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, & + g_atten_to_vol,dBZe,h_atten_to_vol + +! ----- OPTIONAL ----- + real*8, optional, dimension(ngate,nprof) :: & + g_to_vol_in,g_to_vol_out ! integrated atten due to gases, r>v (dB). This allows to output and then input + ! the same gaseous absorption in different calls. Optional to allow compatibility + ! with original version. A. Bodas April 2008. + +! real*8, dimension(nprof,ngate) :: kr_matrix + +! ----- INTERNAL ----- + integer :: & + phase, & ! 0=liquid, 1=ice + ns ! number of discrete drop sizes + + integer*4, dimension(ngate) :: & + hydro ! 1=hydrometeor in vol, 0=none + real*8 :: & + rho_a, & ! air density (kg m^-3) + gases ! function: 2-way gas atten (dB/km) + + real*8, dimension(:), allocatable :: & + Di, Deq, & ! discrete drop sizes (um) + Ni, Ntemp, & ! discrete concentrations (cm^-3 um^-1) + rhoi ! discrete densities (kg m^-3) + + real*8, dimension(ngate) :: & + z_vol, & ! effective reflectivity factor (mm^6/m^3) + z_ray, & ! reflectivity factor, Rayleigh only (mm^6/m^3) + kr_vol, & ! attenuation coefficient hydro (dB/km) + g_vol, & ! attenuation coefficient gases (dB/km) + a_to_vol, & ! integrated atten due to hydometeors, r>v (dB) + g_to_vol ! integrated atten due to gases, r>v (dB) + + + integer,parameter :: KR8 = selected_real_kind(15,300) + real*8, parameter :: xx = -1.0_KR8 + real*8, dimension(:), allocatable :: xxa + real*8 :: kr, ze, zr, pi, scale_factor, tc, Re, ld, tmp1, ze2, kr2,apm,bpm + integer*4 :: tp, i, j, k, pr, itt, iff + + real*8 bin_length,step,base,step_list(25),base_list(25) + integer*4 iRe_type,n,max_bin + + logical :: g_to_vol_in_present, g_to_vol_out_present + + ! Logicals to avoid calling present within the loops + g_to_vol_in_present = present(g_to_vol_in) + g_to_vol_out_present = present(g_to_vol_out) + + ! set up Re bins for z_scalling + bin_length=50; + max_bin=25 + + step_list(1)=1 + base_list(1)=75 + do j=2,max_bin + step_list(j)=3*(j-1); + if(step_list(j)>bin_length) then + step_list(j)=bin_length; + endif + base_list(j)=base_list(j-1)+floor(bin_length/step_list(j-1)); + enddo + + + pi = acos(-1.0) + if (use_mie_table == 1) iff = infind(mt%freq,freq,sort=1) + + + ! // loop over each profile (nprof) + do pr=1,nprof + +! ----- calculations for each volume ----- + z_vol(:) = 0 + z_ray(:) = 0 + kr_vol(:) = 0 + hydro(:) = 0 + +! // loop over eacho range gate (ngate) + do k=1,ngate + +! :: determine if hydrometeor(s) present in volume + hydro(k) = 0 + do j=1,nhclass ! Do while changed for vectorization purposes (A. B-S) + if ((hm_matrix(j,pr,k) > 1E-12) .and. (hp%dtype(j) > 0)) then + hydro(k) = 1 + exit + endif + enddo + + if (hydro(k) == 1) then +! :: if there is hydrometeor in the volume + + rho_a = (p_matrix(pr,k)*100.)/(287*(t_matrix(pr,k)+273.15)) + +! :: loop over hydrometeor type + do tp=1,nhclass + + if (hm_matrix(tp,pr,k) <= 1E-12) cycle + + phase = hp%phase(tp) + if(phase==0) then + itt = infind(mt_ttl,t_matrix(pr,k)) + else + itt = infind(mt_tti,t_matrix(pr,k)) + endif + + ! calculate Re if we have an exponential distribution with fixed No ... precipitation type particle + if( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8) then + + apm=hp%apm(tp) + bpm=hp%bpm(tp) + + if ((hp%rho(tp) > 0) .and. (apm < 0)) then + apm = (pi/6)*hp%rho(tp) + bpm = 3. + endif + + tmp1 = 1./(1.+bpm) + ld = ((apm*gamma(1.+bpm)*hp%p1(tp))/(rho_a*hm_matrix(tp,pr,k)*1E-3))**tmp1 + + Re = 1.5E6/ld + + re_matrix(tp,pr,k) = Re; + + endif + + if(re_matrix(tp,pr,k).eq.0) then + + iRe_type=1 + Re=0 + else + iRe_type=1 + Re=re_matrix(tp,pr,k) + + n=floor(Re/bin_length) + if(n==0) then + if(Re<25) then + step=0.5 + base=0 + else + step=1 + base=25 + endif + else + if(n>max_bin) then + n=max_bin + endif + + step=step_list(n) + base=base_list(n) + endif + + iRe_type=floor(Re/step) + + if(iRe_type.lt.1) then + iRe_type=1 + endif + + Re=step*(iRe_type+0.5) + iRe_type=iRe_type+base-floor(n*bin_length/step) + + ! make sure iRe_type is within bounds + if(iRe_type.ge.nRe_types) then + + ! print *, tp, re_matrix(tp,pr,k), Re, iRe_type + + ! no scaling allowed + Re=re_matrix(tp,pr,k) + + iRe_type=nRe_types + hp%z_flag(tp,itt,iRe_type)=.false. + hp%scaled(tp,iRe_type)=.false. + endif + endif + + ! use Ze_scaled, Zr_scaled, and kr_scaled ... if know them + ! if not we will calculate Ze, Zr, and Kr from the distribution parameters + if( .not. hp%z_flag(tp,itt,iRe_type) ) then + +! :: create a distribution of hydrometeors within volume + select case(hp%dtype(tp)) + case(4) + ns = 1 + allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns)) + if (use_mie_table == 1) allocate(mt_qext(ns),mt_qbsca(ns),Ntemp(ns)) + Di = hp%p1(tp) + Ni = 0. + case default + ns = nsizes + allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns)) + if (use_mie_table == 1) allocate(mt_qext(ns),mt_qbsca(ns),Ntemp(ns)) + Di = D + Ni = 0. + end select + +! :: create a DSD (using scaling factor if applicable) + ! hp%scaled(tp,iRe_type)=.false. ! turn off N scaling + + call dsd(hm_matrix(tp,pr,k),Re,Di,Ni,ns,hp%dtype(tp),rho_a, & + t_matrix(pr,k),hp%dmin(tp),hp%dmax(tp),hp%apm(tp),hp%bpm(tp), & + hp%rho(tp),hp%p1(tp),hp%p2(tp),hp%p3(tp),hp%fc(tp,1:ns,iRe_type), & + hp%scaled(tp,iRe_type)) + +! :: calculate particle density + ! if ((hp%rho_eff(tp,1,iRe_type) < 0) .and. (phase == 1)) then + if (phase == 1) then + if (hp%rho(tp) < 0) then + + ! MG Mie approach - adjust density of sphere with D = D_characteristic to match particle density + ! hp%rho_eff(tp,1:ns,iRe_type) = (6/pi)*hp%apm(tp)*(Di*1E-6)**(hp%bpm(tp)-3) !MG Mie approach + + ! as the particle size gets small it is possible that the mass to size relationship of + ! (given by power law in hclass.data) can produce impossible results + ! where the mass is larger than a solid sphere of ice. + ! This loop ensures that no ice particle can have more mass/density larger than an ice sphere. + ! do i=1,ns + ! if(hp%rho_eff(tp,i,iRe_type) > 917 ) then + ! hp%rho_eff(tp,i,iRe_type) = 917 + !endif + !enddo + + ! alternative is to use equivalent volume spheres. + hp%rho_eff(tp,1:ns,iRe_type) = 917 ! solid ice == equivalent volume approach + Deq = ( ( 6/pi*hp%apm(tp)/917 ) ** (1.0/3.0) ) * & + ( (Di*1E-6) ** (hp%bpm(tp)/3.0) ) * 1E6 ! Di now really Deq in microns. + + else + + ! hp%rho_eff(tp,1:ns,iRe_type) = hp%rho(tp) !MG Mie approach + + ! Equivalent volume sphere (solid ice rho_ice=917 kg/m^3). + hp%rho_eff(tp,1:ns,iRe_type) = 917 + Deq=Di * ((hp%rho(tp)/917)**(1.0/3.0)) + + endif + + ! if using equivalent volume spheres + if (use_mie_table == 1) then + + Ntemp=Ni + + ! Find N(Di) from N(Deq) which we know + do i=1,ns + j=infind(Deq,Di(i)) + Ni(i)=Ntemp(j) + enddo + else + ! just use Deq and D variable input to mie code + Di=Deq; + endif + + endif + rhoi = hp%rho_eff(tp,1:ns,iRe_type) + +! :: calculate effective reflectivity factor of volume + if (use_mie_table == 1) then + + if ((hp%dtype(tp) == 4) .and. (hp%idd(tp) < 0)) then + hp%idd(tp) = infind(mt%D,Di(1)) + endif + + if (phase == 0) then + + ! itt = infind(mt_ttl,t_matrix(pr,k)) + select case(hp%dtype(tp)) + case(4) + mt_qext(1) = mt%qext(hp%idd(tp),itt,1,iff) + mt_qbsca(1) = mt%qbsca(hp%idd(tp),itt,1,iff) + case default + mt_qext = mt%qext(:,itt,1,iff) + mt_qbsca = mt%qbsca(:,itt,1,iff) + end select + + call zeff(freq,Di,Ni,ns,k2,mt_ttl(itt),0,do_ray, & + ze,zr,kr,mt_qext,mt_qbsca,xx) + + else + + ! itt = infind(mt_tti,t_matrix(pr,k)) + select case(hp%dtype(tp)) + case(4) + if (hp%ifc(tp,1,iRe_type) < 0) then + hp%ifc(tp,1,iRe_type) = infind(mt%f,rhoi(1)/917.) + endif + mt_qext(1) = & + mt%qext(hp%idd(tp),itt+cnt_liq,hp%ifc(tp,1,iRe_type),iff) + mt_qbsca(1) = & + mt%qbsca(hp%idd(tp),itt+cnt_liq,hp%ifc(tp,1,iRe_type),iff) + case default + do i=1,ns + if (hp%ifc(tp,i,iRe_type) < 0) then + hp%ifc(tp,i,iRe_type) = infind(mt%f,rhoi(i)/917.) + endif + mt_qext(i) = mt%qext(i,itt+cnt_liq,hp%ifc(tp,i,iRe_type),iff) + mt_qbsca(i) = mt%qbsca(i,itt+cnt_liq,hp%ifc(tp,i,iRe_type),iff) + enddo + end select + + call zeff(freq,Di,Ni,ns,k2,mt_tti(itt),1,do_ray, & + ze,zr,kr,mt_qext,mt_qbsca,xx) + + endif + + else + + xxa = -9.9 + call zeff(freq,Di,Ni,ns,k2,t_matrix(pr,k),phase,do_ray, & + ze,zr,kr,xxa,xxa,rhoi) + + + endif ! end of use mie table + + ! xxa = -9.9 + !call zeff(freq,Di,Ni,ns,k2,t_matrix(pr,k),phase,do_ray, & + ! ze2,zr,kr2,xxa,xxa,rhoi) + + ! if(abs(ze2-ze)/ze2 > 0.1) then + ! if(abs(kr2-kr)/kr2 > 0.1) then + + ! write(*,*) pr,k,tp,ze2,ze2-ze,abs(ze2-ze)/ze2,itt+cnt_liq,iff + ! write(*,*) pr,k,tp,ze2,kr2,kr2-kr,abs(kr2-kr)/kr2 + ! stop + + !endif + + deallocate(Di,Ni,rhoi,xxa,Deq) + if (use_mie_table == 1) deallocate(mt_qext,mt_qbsca,Ntemp) + + else ! can use z scaling + + if( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8 ) then + + ze = hp%Ze_scaled(tp,itt,iRe_type) + zr = hp%Zr_scaled(tp,itt,iRe_type) + kr = hp%kr_scaled(tp,itt,iRe_type) + + else + scale_factor=rho_a*hm_matrix(tp,pr,k) + + zr = hp%Zr_scaled(tp,itt,iRe_type) * scale_factor + ze = hp%Ze_scaled(tp,itt,iRe_type) * scale_factor + kr = hp%kr_scaled(tp,itt,iRe_type) * scale_factor + endif + + endif ! end z_scaling + + ! kr=0 + + kr_vol(k) = kr_vol(k) + kr + z_vol(k) = z_vol(k) + ze + z_ray(k) = z_ray(k) + zr + + ! construct Ze_scaled, Zr_scaled, and kr_scaled ... if we can + if( .not. hp%z_flag(tp,itt,iRe_type) .and. 1.eq.1 ) then + + if( ( (hp%dtype(tp)==1 .or. hp%dtype(tp)==5 .or. hp%dtype(tp)==2) .and. abs(hp%p1(tp)+1) < 1E-8 ) .or. & + ( hp%dtype(tp)==3 .or. hp%dtype(tp)==4 ) & + ) then + + scale_factor=rho_a*hm_matrix(tp,pr,k) + + hp%Ze_scaled(tp,itt,iRe_type) = ze/ scale_factor + hp%Zr_scaled(tp,itt,iRe_type) = zr/ scale_factor + hp%kr_scaled(tp,itt,iRe_type) = kr/ scale_factor + + hp%z_flag(tp,itt,iRe_type)=.True. + + elseif( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8 ) then + + hp%Ze_scaled(tp,itt,iRe_type) = ze + hp%Zr_scaled(tp,itt,iRe_type) = zr + hp%kr_scaled(tp,itt,iRe_type) = kr + + hp%z_flag(tp,itt,iRe_type)=.True. + endif + + endif + + enddo ! end loop of tp (hydrometeor type) + + else +! :: volume is hydrometeor-free + + kr_vol(k) = 0 + z_vol(k) = -999 + z_ray(k) = -999 + + endif + +! :: attenuation due to hydrometeors between radar and volume + a_to_vol(k) = 2*path_integral(kr_vol,hgt_matrix(pr,:),1,k-1) + +! :: attenuation due to gaseous absorption between radar and volume + if (g_to_vol_in_present) then + g_to_vol(k) = g_to_vol_in(k,pr) + else + if ( (use_gas_abs == 1) .or. ((use_gas_abs == 2) .and. (pr == 1)) ) then + g_vol(k) = gases(p_matrix(pr,k),t_matrix(pr,k)+273.15, & + rh_matrix(pr,k),freq) + g_to_vol(k) = path_integral(g_vol,hgt_matrix(pr,:),1,k-1) + elseif (use_gas_abs == 0) then + g_to_vol(k) = 0 + endif + endif + +! kr_matrix(pr,:)=kr_vol + +! :: store results in matrix for return to calling program + h_atten_to_vol(pr,k)=a_to_vol(k) + g_atten_to_vol(pr,k)=g_to_vol(k) + if ((do_ray == 1) .and. (z_ray(k) > 0)) then + Ze_ray(pr,k) = 10*log10(z_ray(k)) + else + Ze_ray(pr,k) = -999 + endif + if (z_vol(k) > 0) then + dBZe(pr,k) = 10*log10(z_vol(k))-a_to_vol(k)-g_to_vol(k) + Ze_non(pr,k) = 10*log10(z_vol(k)) + else + dBZe(pr,k) = -999 + Ze_non(pr,k) = -999 + endif + + enddo ! end loop of k (range gate) + ! Output array with gaseous absorption + if (g_to_vol_out_present) g_to_vol_out(:,pr) = g_to_vol + enddo ! end loop over pr (profile) + + end subroutine radar_simulator + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/radar_simulator_types.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/radar_simulator_types.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/radar_simulator_types.F90 (revision 1280) @@ -0,0 +1,53 @@ + module radar_simulator_types + +! Collection of common variables and types +! Part of QuickBeam v1.03 by John Haynes +! http://reef.atmos.colostate.edu/haynes/radarsim + + integer, parameter :: & + maxhclass = 20 ,& ! max number of hydrometeor classes + nd = 85 ,& ! number of discrete particles + nRe_types = 250 ! number or Re size bins allowed in N and Z_scaled look up table + + real*8, parameter :: & + dmin = 0.1 ,& ! min size of discrete particle + dmax = 10000. ! max size of discrete particle + + integer, parameter :: & + mt_nfreq = 5 , & + mt_ntt = 39 , & ! num temperatures in table + mt_nf = 14 , & ! number of ice fractions in table + mt_nd = 85 ! num discrete mode-p drop sizes in table + + +! ---- hydrometeor class type ----- + + type class_param + real*8, dimension(maxhclass) :: p1,p2,p3,dmin,dmax,apm,bpm,rho + integer, dimension(maxhclass) :: dtype,col,cp,phase + logical, dimension(maxhclass,nRe_types) :: scaled + logical, dimension(maxhclass,mt_ntt,nRe_types) :: z_flag + real*8, dimension(maxhclass,mt_ntt,nRe_types) :: Ze_scaled,Zr_scaled,kr_scaled + real*8, dimension(maxhclass,nd,nRe_types) :: fc, rho_eff + integer, dimension(maxhclass,nd,nRe_types) :: ifc + integer, dimension(maxhclass) :: idd + end type class_param + +! ----- mie table structure ----- + + type mie + real*8 :: freq(mt_nfreq), tt(mt_ntt), f(mt_nf), D(mt_nd) + real*8, dimension(mt_nd,mt_ntt,mt_nf,mt_nfreq) :: qext, qbsca + integer :: phase(mt_ntt) + end type mie + + real*8, dimension(:), allocatable :: & + mt_ttl, & ! liquid temperatures (C) + mt_tti, & ! ice temperatures (C) + mt_qext, mt_qbsca ! extincion/backscatter efficiency + + integer*4 :: & + cnt_liq, & ! liquid temperature count + cnt_ice ! ice temperature count + + end module radar_simulator_types Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/read_cosp_output_nl.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/read_cosp_output_nl.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/read_cosp_output_nl.F90 (revision 1280) @@ -0,0 +1,193 @@ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------- SUBROUTINE READ_COSP_OUTPUT_NL ------------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE READ_COSP_OUTPUT_NL(cosp_nl,cfg) + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + character(len=*),intent(in) :: cosp_nl + type(cosp_config),intent(out) :: cfg + ! Local variables + integer :: i + + logical, save :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim, & + Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, & + Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2,Lcllcalipso, & + Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp,Ltclisccp, & + Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, & + Lfrac_out,Lbeta_mol532,Ltbrttov + namelist/COSP_OUTPUT/Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim, & + Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, & + Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2, & + Lcllcalipso,Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp, & + Ltclisccp,Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, & + Lfrac_out,Lbeta_mol532,Ltbrttov + + do i=1,N_OUT_LIST + cfg%out_list(i)='' + enddo + open(10,file=cosp_nl,status='old') + read(10,nml=cosp_output) + close(10) + +! print*,' Cles sorties cosp :' +! print*,' Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim', & +! Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim + + ! Deal with dependencies + if (.not.Lradar_sim) then + Lcfad_dbze94 = .false. + Lclcalipso2 = .false. + Lcltlidarradar = .false. + Ldbze94 = .false. + endif + if (.not.Llidar_sim) then + Latb532 = .false. + Lcfad_lidarsr532 = .false. + Lclcalipso2 = .false. + Lclcalipso = .false. + Lclhcalipso = .false. + Lcllcalipso = .false. + Lclmcalipso = .false. + Lcltcalipso = .false. + Lcltlidarradar = .false. + Lparasol_refl = .false. + Lbeta_mol532 = .false. + endif + if (.not.Lisccp_sim) then + Lalbisccp = .false. + Lboxptopisccp = .false. + Lboxtauisccp = .false. + Lclisccp2 = .false. + Lctpisccp = .false. + Ltauisccp = .false. + Ltclisccp = .false. + Lmeantbisccp = .false. + Lmeantbclrisccp = .false. + endif + if (.not.Lmisr_sim) then + LclMISR = .false. + endif + if (.not.Lrttov_sim) then + Ltbrttov = .false. + endif + if ((.not.Lradar_sim).and.(.not.Llidar_sim).and. & + (.not.Lisccp_sim).and.(.not.Lmisr_sim)) then + Lfrac_out = .false. + endif + + ! Diagnostics that use Radar and Lidar + if (((Lclcalipso2).or.(Lcltlidarradar)).and.((Lradar_sim).or.(Llidar_sim))) then + Lclcalipso2 = .true. + Lcltlidarradar = .true. + Llidar_sim = .true. + Lradar_sim = .true. + endif + + cfg%Lstats = .false. + if ((Lradar_sim).or.(Llidar_sim).or.(Lisccp_sim)) cfg%Lstats = .true. + + ! Copy instrument flags to cfg structure + cfg%Lradar_sim = Lradar_sim + cfg%Llidar_sim = Llidar_sim + cfg%Lisccp_sim = Lisccp_sim + cfg%Lmisr_sim = Lmisr_sim + cfg%Lrttov_sim = Lrttov_sim + + ! Flag to control output to file + cfg%Lwrite_output = .false. + if (cfg%Lstats.or.cfg%Lmisr_sim.or.cfg%Lrttov_sim) then + cfg%Lwrite_output = .true. + endif + + ! Output diagnostics + i = 1 + if (Lalbisccp) cfg%out_list(i) = 'albisccp' + i = i+1 + if (Latb532) cfg%out_list(i) = 'atb532' + i = i+1 + if (Lboxptopisccp) cfg%out_list(i) = 'boxptopisccp' + i = i+1 + if (Lboxtauisccp) cfg%out_list(i) = 'boxtauisccp' + i = i+1 + if (Lcfad_dbze94) cfg%out_list(i) = 'cfad_dbze94' + i = i+1 + if (Lcfad_lidarsr532) cfg%out_list(i) = 'cfad_lidarsr532' + i = i+1 + if (Lclcalipso2) cfg%out_list(i) = 'clcalipso2' + i = i+1 + if (Lclcalipso) cfg%out_list(i) = 'clcalipso' + i = i+1 + if (Lclhcalipso) cfg%out_list(i) = 'clhcalipso' + i = i+1 + if (Lclisccp2) cfg%out_list(i) = 'clisccp2' + i = i+1 + if (Lcllcalipso) cfg%out_list(i) = 'cllcalipso' + i = i+1 + if (Lclmcalipso) cfg%out_list(i) = 'clmcalipso' + i = i+1 + if (Lcltcalipso) cfg%out_list(i) = 'cltcalipso' + i = i+1 + if (Lcltlidarradar) cfg%out_list(i) = 'cltlidarradar' + i = i+1 + if (Lctpisccp) cfg%out_list(i) = 'ctpisccp' + i = i+1 + if (Ldbze94) cfg%out_list(i) = 'dbze94' + i = i+1 + if (Ltauisccp) cfg%out_list(i) = 'tauisccp' + i = i+1 + if (Ltclisccp) cfg%out_list(i) = 'tclisccp' + i = i+1 + if (Llongitude) cfg%out_list(i) = 'lon' + i = i+1 + if (Llatitude) cfg%out_list(i) = 'lat' + i = i+1 + if (Lparasol_refl) cfg%out_list(i) = 'parasol_refl' + i = i+1 + if (LclMISR) cfg%out_list(i) = 'clMISR' + i = i+1 + if (Lmeantbisccp) cfg%out_list(i) = 'meantbisccp' + i = i+1 + if (Lmeantbclrisccp) cfg%out_list(i) = 'meantbclrisccp' + i = i+1 + if (Lfrac_out) cfg%out_list(i) = 'frac_out' + i = i+1 + if (Lbeta_mol532) cfg%out_list(i) = 'beta_mol532' + i = i+1 + if (Ltbrttov) cfg%out_list(i) = 'tbrttov' + + if (i /= N_OUT_LIST) then + print *, 'COSP_IO: wrong number of output diagnostics' + stop + endif + + ! Copy diagnostic flags to cfg structure + cfg%Lalbisccp = Lalbisccp + cfg%Latb532 = Latb532 + cfg%Lboxptopisccp = Lboxptopisccp + cfg%Lboxtauisccp = Lboxtauisccp + cfg%Lcfad_dbze94 = Lcfad_dbze94 + cfg%Lcfad_lidarsr532 = Lcfad_lidarsr532 + cfg%Lclcalipso2 = Lclcalipso2 + cfg%Lclcalipso = Lclcalipso + cfg%Lclhcalipso = Lclhcalipso + cfg%Lclisccp2 = Lclisccp2 + cfg%Lcllcalipso = Lcllcalipso + cfg%Lclmcalipso = Lclmcalipso + cfg%Lcltcalipso = Lcltcalipso + cfg%Lcltlidarradar = Lcltlidarradar + cfg%Lctpisccp = Lctpisccp + cfg%Ldbze94 = Ldbze94 + cfg%Ltauisccp = Ltauisccp + cfg%Ltclisccp = Ltclisccp + cfg%Llongitude = Llongitude + cfg%Llatitude = Llatitude + cfg%Lparasol_refl = Lparasol_refl + cfg%LclMISR = LclMISR + cfg%Lmeantbisccp = Lmeantbisccp + cfg%Lmeantbclrisccp = Lmeantbclrisccp + cfg%Lfrac_out = Lfrac_out + cfg%Lbeta_mol532 = Lbeta_mol532 + cfg%Ltbrttov = Ltbrttov + + END SUBROUTINE READ_COSP_OUTPUT_NL + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/scops.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/scops.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/scops.F (revision 1280) @@ -0,0 +1,335 @@ + subroutine scops(npoints,nlev,ncol,seed,cc,conv, + & overlap,frac_out,ncolprint) + + +! *****************************COPYRIGHT**************************** +! (c) British Crown Copyright 2009, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the +! following conditions are met: +! +! * Redistributions of source code must retain the above +! copyright notice, this list of conditions and the following +! disclaimer. +! * Redistributions in binary form must reproduce the above +! copyright notice, this list of conditions and the following +! disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its +! contributors may be used to endorse or promote products +! derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! *****************************COPYRIGHT******************************* +! *****************************COPYRIGHT******************************* +! *****************************COPYRIGHT******************************* + + implicit none + + INTEGER npoints ! number of model points in the horizontal + INTEGER nlev ! number of model levels in column + INTEGER ncol ! number of subcolumns + + + INTEGER overlap ! overlap type + ! 1=max + ! 2=rand + ! 3=max/rand + REAL cc(npoints,nlev) + ! input cloud cover in each model level (fraction) + ! NOTE: This is the HORIZONTAL area of each + ! grid box covered by clouds + + REAL conv(npoints,nlev) + ! input convective cloud cover in each model + ! level (fraction) + ! NOTE: This is the HORIZONTAL area of each + ! grid box covered by convective clouds + + INTEGER i,j,ilev,ibox,ncolprint,ilev2 + + REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into + ! Equivalent of BOX in original version, but + ! indexed by column then row, rather than + ! by row then column + + + INTEGER seed(npoints) + ! seed values for marsaglia random number generator + ! It is recommended that the seed is set + ! to a different value for each model + ! gridbox it is called on, as it is + ! possible that the choice of the same + ! seed value every time may introduce some + ! statistical bias in the results, particularly + ! for low values of NCOL. + + REAL tca(npoints,0:nlev) ! total cloud cover in each model level (fraction) + ! with extra layer of zeroes on top + ! in this version this just contains the values input + ! from cc but with an extra level + + REAL threshold(npoints,ncol) ! pointer to position in gridbox + REAL maxocc(npoints,ncol) ! Flag for max overlapped conv cld + REAL maxosc(npoints,ncol) ! Flag for max overlapped strat cld + + REAL boxpos(npoints,ncol) ! ordered pointer to position in gridbox + + REAL threshold_min(npoints,ncol) ! minimum value to define range in with new threshold + ! is chosen + + REAL ran(npoints) ! vector of random numbers + + INTEGER irand,i2_16,huge32,overflow_32 ! variables for RNG + PARAMETER(huge32=2147483647) + i2_16=65536 + + do ibox=1,ncol + do j=1,npoints + boxpos(j,ibox)=(ibox-.5)/ncol + enddo + enddo + +! ---------------------------------------------------! +! Initialise working variables +! ---------------------------------------------------! + +! Initialised frac_out to zero + + do ilev=1,nlev + do ibox=1,ncol + do j=1,npoints + frac_out(j,ibox,ilev)=0.0 + enddo + enddo + enddo + +! assign 2d tca array using 1d input array cc + + do j=1,npoints + tca(j,0)=0 + enddo + + do ilev=1,nlev + do j=1,npoints + tca(j,ilev)=cc(j,ilev) + enddo + enddo + + if (ncolprint.ne.0) then + write (6,'(a)') 'frac_out_pp_rev:' + do j=1,npoints,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(8f5.2)') + & ((frac_out(j,ibox,ilev),ibox=1,ncolprint),ilev=1,nlev) + + enddo + write (6,'(a)') 'ncol:' + write (6,'(I3)') ncol + endif + if (ncolprint.ne.0) then + write (6,'(a)') 'last_frac_pp:' + do j=1,npoints,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(8f5.2)') (tca(j,0)) + enddo + endif + +! ---------------------------------------------------! +! ALLOCATE CLOUD INTO BOXES, FOR NCOLUMNS, NLEVELS +! frac_out is the array that contains the information +! where 0 is no cloud, 1 is a stratiform cloud and 2 is a +! convective cloud + + !loop over vertical levels + DO 200 ilev = 1,nlev + +! Initialise threshold + + IF (ilev.eq.1) then + ! If max overlap + IF (overlap.eq.1) then + ! select pixels spread evenly + ! across the gridbox + DO ibox=1,ncol + do j=1,npoints + threshold(j,ibox)=boxpos(j,ibox) + enddo + enddo + ELSE + DO ibox=1,ncol + include 'congvec.h' + ! select random pixels from the non-convective + ! part the gridbox ( some will be converted into + ! convective pixels below ) + do j=1,npoints + threshold(j,ibox)= + & conv(j,ilev)+(1-conv(j,ilev))*ran(j) + enddo + enddo + ENDIF + IF (ncolprint.ne.0) then + write (6,'(a)') 'threshold_nsf2:' + do j=1,npoints,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint) + enddo + ENDIF + ENDIF + + IF (ncolprint.ne.0) then + write (6,'(a)') 'ilev:' + write (6,'(I2)') ilev + ENDIF + + DO ibox=1,ncol + + ! All versions + do j=1,npoints + if (boxpos(j,ibox).le.conv(j,ilev)) then + maxocc(j,ibox) = 1. + else + maxocc(j,ibox) = 0. + end if + enddo + + ! Max overlap + if (overlap.eq.1) then + do j=1,npoints + threshold_min(j,ibox)=conv(j,ilev) + maxosc(j,ibox)=1 + enddo + endif + + ! Random overlap + if (overlap.eq.2) then + do j=1,npoints + threshold_min(j,ibox)=conv(j,ilev) + maxosc(j,ibox)=0 + enddo + endif + + ! Max/Random overlap + if (overlap.eq.3) then + do j=1,npoints + threshold_min(j,ibox)=max(conv(j,ilev), + & min(tca(j,ilev-1),tca(j,ilev))) + if (threshold(j,ibox) + & .lt.min(tca(j,ilev-1),tca(j,ilev)) + & .and.(threshold(j,ibox).gt.conv(j,ilev))) then + maxosc(j,ibox)= 1 + else + maxosc(j,ibox)= 0 + end if + enddo + endif + + ! Reset threshold + + include 'congvec.h' + + do j=1,npoints + threshold(j,ibox)= + !if max overlapped conv cloud + & maxocc(j,ibox) * ( + & boxpos(j,ibox) + & ) + + !else + & (1-maxocc(j,ibox)) * ( + !if max overlapped strat cloud + & (maxosc(j,ibox)) * ( + !threshold=boxpos + & threshold(j,ibox) + & ) + + !else + & (1-maxosc(j,ibox)) * ( + !threshold_min=random[thrmin,1] + & threshold_min(j,ibox)+ + & (1-threshold_min(j,ibox))*ran(j) + & ) + & ) + enddo + + ENDDO ! ibox + +! Fill frac_out with 1's where tca is greater than the threshold + + DO ibox=1,ncol + do j=1,npoints + if (tca(j,ilev).gt.threshold(j,ibox)) then + frac_out(j,ibox,ilev)=1 + else + frac_out(j,ibox,ilev)=0 + end if + enddo + ENDDO + +! Code to partition boxes into startiform and convective parts +! goes here + + DO ibox=1,ncol + do j=1,npoints + if (threshold(j,ibox).le.conv(j,ilev)) then + ! = 2 IF threshold le conv(j) + frac_out(j,ibox,ilev) = 2 + else + ! = the same IF NOT threshold le conv(j) + frac_out(j,ibox,ilev) = frac_out(j,ibox,ilev) + end if + enddo + ENDDO + +! Set last_frac to tca at this level, so as to be tca +! from last level next time round + + if (ncolprint.ne.0) then + + do j=1,npoints ,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(a)') 'last_frac:' + write (6,'(8f5.2)') (tca(j,ilev-1)) + + write (6,'(a)') 'conv:' + write (6,'(8f5.2)') (conv(j,ilev),ibox=1,ncolprint) + + write (6,'(a)') 'max_overlap_cc:' + write (6,'(8f5.2)') (maxocc(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'max_overlap_sc:' + write (6,'(8f5.2)') (maxosc(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'threshold_min_nsf2:' + write (6,'(8f5.2)') (threshold_min(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'threshold_nsf2:' + write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'frac_out_pp_rev:' + write (6,'(8f5.2)') + & ((frac_out(j,ibox,ilev2),ibox=1,ncolprint),ilev2=1,nlev) + enddo + endif + +200 CONTINUE !loop over nlev + + + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/write_histdayCOSP.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/write_histdayCOSP.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/write_histdayCOSP.h (revision 1280) @@ -0,0 +1,121 @@ +! Ecriture des fichiers de sorties COSP +! Sorties journalierres +! Abderrahmane Idelkadi Septembre 2009 + + IF (MOD(itap,NINT(freq_COSP/dtime)).EQ.0) THEN + + itau_wcosp = itau_phy + itap + +! Sorties LIDAR + if (cfg%Llidar_sim) then + if (cfg%Lcllcalipso) then + CALL histwrite_phy(nid_day_cosp,"cllcalipso",itau_wcosp,stlidar%cldlayer(:,1)) + endif + if (cfg%Lclhcalipso) then + CALL histwrite_phy(nid_day_cosp,"clhcalipso",itau_wcosp,stlidar%cldlayer(:,3)) + endif + if (cfg%Lclmcalipso) then + CALL histwrite_phy(nid_day_cosp,"clmcalipso",itau_wcosp,stlidar%cldlayer(:,2)) + endif + if (cfg%Lcltcalipso) then + CALL histwrite_phy(nid_day_cosp,"cltcalipso",itau_wcosp,stlidar%cldlayer(:,4)) + endif + if (cfg%Lclcalipso) then + CALL histwrite_phy(nid_day_cosp,"clcalipso",itau_wcosp,stlidar%lidarcld) + endif + if (cfg%Lcfad_lidarsr532) then + do ii=1,SR_BINS + CALL histwrite_phy(nid_day_cosp,"cfad_lidarsr532_"//chcol(ii),itau_wcosp,stlidar%cfad_sr(:,ii,:)) + enddo + endif + if (cfg%Lparasol_refl) then + CALL histwrite_phy(nid_day_cosp,"parasol_refl",itau_wcosp,stlidar%parasolrefl) + endif + if (cfg%Latb532) then + do ii=1,Ncolumns + CALL histwrite_phy(nid_day_cosp,"atb532_"//chcol(ii),itau_wcosp,sglidar%beta_tot(:,ii,:)) + enddo + endif + if (cfg%Lbeta_mol532) then + CALL histwrite_phy(nid_day_cosp,"beta_mol532",itau_wcosp,sglidar%beta_mol) + endif + endif ! Lidar + +! Sorties RADAR +!Attention A FAIRE +! if (cfg%Lradar_sim) then +! print*,'Ecriture sorties Radar' +! if (cfg%Lcfad_dbze94) then +! print*,'Ecriture de cfad_dbze94.nc ' +! A revoir l axe vertical Nlvgrid +! do ii=1,DBZE_BINS +! dbze_ax(ii) = CFAD_ZE_MIN + CFAD_ZE_WIDTH*(ii - 0.5) +! enddo +! call write_netcdf4d('cfad_dbze94.nc',use_vgrid,nlon,nlat,Nlevout,DBZE_BINS, & +! x,y,out_levs,dbze_ax,i,ndays,time,stradar%cfad_ze) +! endif +! if (cfg%Lclcalipso2) then +! call write_netcdf3d('clcalipso2.nc',use_vgrid,'clcalipso2', & +! nlon,nlat,Nlevout,x,y,out_levs,i,ndays,time,stradar%lidar_only_freq_cloud) +! endif +! if (cfg%Ldbze94) then +! do ii=1,Ncolumns +! xcol(ii)=float(i) +! enddo +! call write_netcdf4d('dbze94.nc',use_vgrid,nlon,nlat,Nlevout,Ncolumns, & +! x,y,out_levs,xcol,i,ndays,time,sgradar%Ze_tot) +! endif +! if (cfg%Lcltlidarradar) then +! call write_netcdf2d('cltlidarradar.nc','cltlidarradar', & +! nlon,nlat,x,y,i,ndays,time,stradar%radar_lidar_tcc) +! endif +! endif ! Radar + +! Sorties MISR +!Attention A FAIRE +! if (cfg%Lmisr_sim) then +! print*,'Ecriture sorties Misr' +! call write_netcdf4d('clMISR.nc',use_vgrid,nlon,nlat,MISR_N_CTH,7, & +! x,y,MISR_CTH,ISCCP_TAU,i,ndays,time,misr%fq_MISR) +! endif + +! Sorties ISCCP + if (cfg%Lisccp_sim) then + if (cfg%Lclisccp2) then + do ii=1,7 + CALL histwrite_phy(nid_day_cosp,"clisccp2_"//chcol(ii),itau_wcosp,isccp%fq_isccp(:,ii,:)) + enddo + endif + if (cfg%Lboxtauisccp) then + CALL histwrite_phy(nid_day_cosp,"boxtauisccp",itau_wcosp,isccp%boxtau) + endif + if (cfg%Lboxptopisccp) then + CALL histwrite_phy(nid_day_cosp,"boxptopisccp",itau_wcosp,isccp%boxptop) + endif + if (cfg%Ltclisccp) then + CALL histwrite_phy(nid_day_cosp,"tclisccp",itau_wcosp,isccp%totalcldarea) + endif + if (cfg%Lctpisccp) then + CALL histwrite_phy(nid_day_cosp,"ctpisccp",itau_wcosp,isccp%meanptop) + endif + if (cfg%Ltauisccp) then + CALL histwrite_phy(nid_day_cosp,"tauisccp",itau_wcosp,isccp%meantaucld) + endif + if (cfg%Lalbisccp) then + CALL histwrite_phy(nid_day_cosp,"albisccp",itau_wcosp,isccp%meanalbedocld) + endif + if (cfg%Lmeantbisccp) then + CALL histwrite_phy(nid_day_cosp,"meantbisccp",itau_wcosp,isccp%meantb) + endif + if (cfg%Lmeantbclrisccp) then + CALL histwrite_phy(nid_day_cosp,"meantbclrisccp",itau_wcosp,isccp%meantbclr) + endif + endif ! Isccp + +! if (ok_sync) then +!$OMP MASTER + call histsync(nid_day_cosp) +!$OMP END MASTER +! endif + + ENDIF ! if freq_COSP Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/write_histhfCOSP.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/write_histhfCOSP.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/write_histhfCOSP.h (revision 1280) @@ -0,0 +1,122 @@ +! Ecriture des fichiers de sorties COSP +! Sorties journalierres +! Abderrahmane Idelkadi Septembre 2009 + + IF (MOD(itap,NINT(freq_COSP/dtime)).EQ.0) THEN + + itau_wcosp = itau_phy + itap + +! Sorties LIDAR + if (cfg%Llidar_sim) then + if (cfg%Lcllcalipso) then + CALL histwrite_phy(nid_hf_cosp,"cllcalipso",itau_wcosp,stlidar%cldlayer(:,1)) + endif + if (cfg%Lclhcalipso) then + CALL histwrite_phy(nid_hf_cosp,"clhcalipso",itau_wcosp,stlidar%cldlayer(:,3)) + endif + if (cfg%Lclmcalipso) then + CALL histwrite_phy(nid_hf_cosp,"clmcalipso",itau_wcosp,stlidar%cldlayer(:,2)) + endif + if (cfg%Lcltcalipso) then + CALL histwrite_phy(nid_hf_cosp,"cltcalipso",itau_wcosp,stlidar%cldlayer(:,4)) + endif + if (cfg%Lclcalipso) then + CALL histwrite_phy(nid_hf_cosp,"clcalipso",itau_wcosp,stlidar%lidarcld) + endif + if (cfg%Lcfad_lidarsr532) then + do ii=1,SR_BINS + CALL histwrite_phy(nid_hf_cosp,"cfad_lidarsr532_"//chcol(ii),itau_wcosp,stlidar%cfad_sr(:,ii,:)) + enddo + endif + if (cfg%Lparasol_refl) then + CALL histwrite_phy(nid_hf_cosp,"parasol_refl",itau_wcosp,stlidar%parasolrefl) + endif + if (cfg%Latb532) then + do ii=1,Ncolumns + CALL histwrite_phy(nid_hf_cosp,"atb532_"//chcol(ii),itau_wcosp,sglidar%beta_tot(:,ii,:)) + enddo + endif + if (cfg%Lbeta_mol532) then + CALL histwrite_phy(nid_hf_cosp,"beta_mol532",itau_wcosp,sglidar%beta_mol) + endif + endif ! Lidar + +! Sorties RADAR +!Attention A FAIRE +! if (cfg%Lradar_sim) then +! print*,'Ecriture sorties Radar' +! if (cfg%Lcfad_dbze94) then +! print*,'Ecriture de cfad_dbze94.nc ' +! A revoir l axe vertical Nlvgrid +! do ii=1,DBZE_BINS +! dbze_ax(ii) = CFAD_ZE_MIN + CFAD_ZE_WIDTH*(ii - 0.5) +! enddo +! call write_netcdf4d('cfad_dbze94.nc',use_vgrid,nlon,nlat,Nlevout,DBZE_BINS, & +! x,y,out_levs,dbze_ax,i,ndays,time,stradar%cfad_ze) +! endif +! if (cfg%Lclcalipso2) then +! call write_netcdf3d('clcalipso2.nc',use_vgrid,'clcalipso2', & +! nlon,nlat,Nlevout,x,y,out_levs,i,ndays,time,stradar%lidar_only_freq_cloud) +! endif +! if (cfg%Ldbze94) then +! do ii=1,Ncolumns +! xcol(ii)=float(i) +! enddo +! call write_netcdf4d('dbze94.nc',use_vgrid,nlon,nlat,Nlevout,Ncolumns, & +! x,y,out_levs,xcol,i,ndays,time,sgradar%Ze_tot) +! endif +! if (cfg%Lcltlidarradar) then +! call write_netcdf2d('cltlidarradar.nc','cltlidarradar', & +! nlon,nlat,x,y,i,ndays,time,stradar%radar_lidar_tcc) +! endif +! endif ! Radar + +! Sorties MISR +!Attention A FAIRE +! if (cfg%Lmisr_sim) then +! print*,'Ecriture sorties Misr' +! call write_netcdf4d('clMISR.nc',use_vgrid,nlon,nlat,MISR_N_CTH,7, & +! x,y,MISR_CTH,ISCCP_TAU,i,ndays,time,misr%fq_MISR) +! endif + +! Sorties ISCCP + if (cfg%Lisccp_sim) then + if (cfg%Lclisccp2) then + do ii=1,7 + CALL histwrite_phy(nid_hf_cosp,"clisccp2_"//chcol(ii),itau_wcosp,isccp%fq_isccp(:,ii,:)) + enddo + endif + if (cfg%Lboxtauisccp) then + CALL histwrite_phy(nid_hf_cosp,"boxtauisccp",itau_wcosp,isccp%boxtau) + endif + if (cfg%Lboxptopisccp) then + CALL histwrite_phy(nid_hf_cosp,"boxptopisccp",itau_wcosp,isccp%boxptop) + endif + if (cfg%Ltclisccp) then + CALL histwrite_phy(nid_hf_cosp,"tclisccp",itau_wcosp,isccp%totalcldarea) + endif + if (cfg%Lctpisccp) then + CALL histwrite_phy(nid_hf_cosp,"ctpisccp",itau_wcosp,isccp%meanptop) + + endif + if (cfg%Ltauisccp) then + CALL histwrite_phy(nid_hf_cosp,"tauisccp",itau_wcosp,isccp%meantaucld) + endif + if (cfg%Lalbisccp) then + CALL histwrite_phy(nid_hf_cosp,"albisccp",itau_wcosp,isccp%meanalbedocld) + endif + if (cfg%Lmeantbisccp) then + CALL histwrite_phy(nid_hf_cosp,"meantbisccp",itau_wcosp,isccp%meantb) + endif + if (cfg%Lmeantbclrisccp) then + CALL histwrite_phy(nid_hf_cosp,"meantbclrisccp",itau_wcosp,isccp%meantbclr) + endif + endif ! Isccp + +! if (ok_sync) then +!$OMP MASTER + call histsync(nid_hf_cosp) +!$OMP END MASTER +! endif + + ENDIF ! if freq_COSP Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/write_histmthCOSP.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/write_histmthCOSP.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/write_histmthCOSP.h (revision 1280) @@ -0,0 +1,121 @@ +! Ecriture des fichiers de sorties COSP +! Sorties journalierres +! Abderrahmane Idelkadi Septembre 2009 + + IF (MOD(itap,NINT(freq_COSP/dtime)).EQ.0) THEN + + itau_wcosp = itau_phy + itap + +! Sorties LIDAR + if (cfg%Llidar_sim) then + if (cfg%Lcllcalipso) then + CALL histwrite_phy(nid_mth_cosp,"cllcalipso",itau_wcosp,stlidar%cldlayer(:,1)) + endif + if (cfg%Lclhcalipso) then + CALL histwrite_phy(nid_mth_cosp,"clhcalipso",itau_wcosp,stlidar%cldlayer(:,3)) + endif + if (cfg%Lclmcalipso) then + CALL histwrite_phy(nid_mth_cosp,"clmcalipso",itau_wcosp,stlidar%cldlayer(:,2)) + endif + if (cfg%Lcltcalipso) then + CALL histwrite_phy(nid_mth_cosp,"cltcalipso",itau_wcosp,stlidar%cldlayer(:,4)) + endif + if (cfg%Lclcalipso) then + CALL histwrite_phy(nid_mth_cosp,"clcalipso",itau_wcosp,stlidar%lidarcld) + endif + if (cfg%Lcfad_lidarsr532) then + do ii=1,SR_BINS + CALL histwrite_phy(nid_mth_cosp,"cfad_lidarsr532_"//chcol(ii),itau_wcosp,stlidar%cfad_sr(:,ii,:)) + enddo + endif + if (cfg%Lparasol_refl) then + CALL histwrite_phy(nid_mth_cosp,"parasol_refl",itau_wcosp,stlidar%parasolrefl) + endif + if (cfg%Latb532) then + do ii=1,Ncolumns + CALL histwrite_phy(nid_mth_cosp,"atb532_"//chcol(ii),itau_wcosp,sglidar%beta_tot(:,ii,:)) + enddo + endif + if (cfg%Lbeta_mol532) then + CALL histwrite_phy(nid_mth_cosp,"beta_mol532",itau_wcosp,sglidar%beta_mol) + endif + endif ! Lidar + +! Sorties RADAR +!Attention A FAIRE +! if (cfg%Lradar_sim) then +! print*,'Ecriture sorties Radar' +! if (cfg%Lcfad_dbze94) then +! print*,'Ecriture de cfad_dbze94.nc ' +! A revoir l axe vertical Nlvgrid +! do ii=1,DBZE_BINS +! dbze_ax(ii) = CFAD_ZE_MIN + CFAD_ZE_WIDTH*(ii - 0.5) +! enddo +! call write_netcdf4d('cfad_dbze94.nc',use_vgrid,nlon,nlat,Nlevout,DBZE_BINS, & +! x,y,out_levs,dbze_ax,i,ndays,time,stradar%cfad_ze) +! endif +! if (cfg%Lclcalipso2) then +! call write_netcdf3d('clcalipso2.nc',use_vgrid,'clcalipso2', & +! nlon,nlat,Nlevout,x,y,out_levs,i,ndays,time,stradar%lidar_only_freq_cloud) +! endif +! if (cfg%Ldbze94) then +! do ii=1,Ncolumns +! xcol(ii)=float(i) +! enddo +! call write_netcdf4d('dbze94.nc',use_vgrid,nlon,nlat,Nlevout,Ncolumns, & +! x,y,out_levs,xcol,i,ndays,time,sgradar%Ze_tot) +! endif +! if (cfg%Lcltlidarradar) then +! call write_netcdf2d('cltlidarradar.nc','cltlidarradar', & +! nlon,nlat,x,y,i,ndays,time,stradar%radar_lidar_tcc) +! endif +! endif ! Radar + +! Sorties MISR +!Attention A FAIRE +! if (cfg%Lmisr_sim) then +! print*,'Ecriture sorties Misr' +! call write_netcdf4d('clMISR.nc',use_vgrid,nlon,nlat,MISR_N_CTH,7, & +! x,y,MISR_CTH,ISCCP_TAU,i,ndays,time,misr%fq_MISR) +! endif + +! Sorties ISCCP + if (cfg%Lisccp_sim) then + if (cfg%Lclisccp2) then + do ii=1,7 + CALL histwrite_phy(nid_mth_cosp,"clisccp2_"//chcol(ii),itau_wcosp,isccp%fq_isccp(:,ii,:)) + enddo + endif + if (cfg%Lboxtauisccp) then + CALL histwrite_phy(nid_mth_cosp,"boxtauisccp",itau_wcosp,isccp%boxtau) + endif + if (cfg%Lboxptopisccp) then + CALL histwrite_phy(nid_mth_cosp,"boxptopisccp",itau_wcosp,isccp%boxptop) + endif + if (cfg%Ltclisccp) then + CALL histwrite_phy(nid_mth_cosp,"tclisccp",itau_wcosp,isccp%totalcldarea) + endif + if (cfg%Lctpisccp) then + CALL histwrite_phy(nid_mth_cosp,"ctpisccp",itau_wcosp,isccp%meanptop) + endif + if (cfg%Ltauisccp) then + CALL histwrite_phy(nid_mth_cosp,"tauisccp",itau_wcosp,isccp%meantaucld) + endif + if (cfg%Lalbisccp) then + CALL histwrite_phy(nid_mth_cosp,"albisccp",itau_wcosp,isccp%meanalbedocld) + endif + if (cfg%Lmeantbisccp) then + CALL histwrite_phy(nid_mth_cosp,"meantbisccp",itau_wcosp,isccp%meantb) + endif + if (cfg%Lmeantbclrisccp) then + CALL histwrite_phy(nid_mth_cosp,"meantbclrisccp",itau_wcosp,isccp%meantbclr) + endif + endif ! Isccp + +! if (ok_sync) then +!$OMP MASTER + call histsync(nid_mth_cosp) +!$OMP END MASTER +! endif + + ENDIF ! if freq_COSP Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/zeff.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/zeff.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/cosp/zeff.F90 (revision 1280) @@ -0,0 +1,161 @@ + subroutine zeff(freq,D,N,nsizes,k2,tt,ice,xr,z_eff,z_ray,kr,qe,qs,rho_e) + use math_lib + use optics_lib + implicit none + +! Purpose: +! Simulates radar return of a volume given DSD of spheres +! Part of QuickBeam v1.03 by John Haynes +! http://reef.atmos.colostate.edu/haynes/radarsim +! +! Inputs: +! [freq] radar frequency (GHz) +! [D] discrete drop sizes (um) +! [N] discrete concentrations (cm^-3 um^-1) +! [nsizes] number of discrete drop sizes +! [k2] |K|^2, -1=use frequency dependent default +! [tt] hydrometeor temperature (C) +! [ice] indicates volume consists of ice +! [xr] perform Rayleigh calculations? +! [qe] if using a mie table, these contain ext/sca ... +! [qs] ... efficiencies; otherwise set to -1 +! [rho_e] medium effective density (kg m^-3) (-1 = pure) +! +! Outputs: +! [z_eff] unattenuated effective reflectivity factor (mm^6/m^3) +! [z_ray] reflectivity factor, Rayleigh only (mm^6/m^3) +! [kr] attenuation coefficient (db km^-1) +! +! Created: +! 11/28/05 John Haynes (haynes@atmos.colostate.edu) + +! ----- INPUTS ----- + integer, intent(in) :: ice, xr + integer, intent(in) :: nsizes + real*8, intent(in) :: freq,D(nsizes),N(nsizes),tt,qe(nsizes), & + qs(nsizes), rho_e(nsizes) + real*8, intent(inout) :: k2 + +! ----- OUTPUTS ----- + real*8, intent(out) :: z_eff,z_ray,kr + +! ----- INTERNAL ----- + integer :: & + correct_for_rho ! correct for density flag + real*8, dimension(nsizes) :: & + D0, & ! D in (m) + N0, & ! N in m^-3 m^-1 + sizep, & ! size parameter + qext, & ! extinction efficiency + qbsca, & ! backscatter efficiency + rho_ice, & ! bulk density ice (kg m^-3) + f ! ice fraction + real*8 :: & + wl, & ! wavelength (m) + cr ! kr(dB/km) = cr * kr(1/km) + complex*16 :: & + m ! complex index of refraction of bulk form + complex*16, dimension(nsizes) :: & + m0 ! complex index of refraction + + integer*4 :: i,one + real*8 :: pi + real*8 :: eta_sum, eta_mie, const, z0_eff, z0_ray, k_sum, & + n_r, n_i, dqv(1), dqxt, dqsc, dbsc, dg, dph(1) + integer*4 :: err + complex*16 :: Xs1(1), Xs2(1) + + one=1 + pi = acos(-1.0) + rho_ice(:) = 917 + z0_ray = 0.0 + +! // conversions + D0 = d*1E-6 ! m + N0 = n*1E12 ! 1/(m^3 m) + wl = 2.99792458/(freq*10) ! m + +! // dielectric constant |k^2| defaults + if (k2 < 0) then + k2 = 0.933 + if (abs(94.-freq) < 3.) k2=0.75 + if (abs(35.-freq) < 3.) k2=0.88 + if (abs(13.8-freq) < 3.) k2=0.925 + endif + + if (qe(1) < -9) then + +! // get the refractive index of the bulk hydrometeors + if (ice == 0) then + call m_wat(freq,tt,n_r,n_i) + else + call m_ice(freq,tt,n_r,n_i) + endif + m = cmplx(n_r,-n_i) + m0(:) = m + + correct_for_rho = 0 + if ((ice == 1) .and. (minval(rho_e) >= 0)) correct_for_rho = 1 + +! :: correct refractive index for ice density if needed + if (correct_for_rho == 1) then + f = rho_e/rho_ice + m0 = ((2+m0**2+2*f*(m0**2-1))/(2+m0**2+f*(1-m0**2)))**(0.5) + endif + +! :: Mie calculations + sizep = (pi*D0)/wl + dqv(1) = 0. + do i=1,nsizes + call mieint(sizep(i), m0(i), one, dqv, qext(i), dqsc, qbsca(i), & + dg, xs1, xs2, dph, err) + end do + + else +! // Mie table used + + qext = qe + qbsca = qs + + endif + +! // eta_mie = 0.25*sum[qbsca*pi*D^2*N(D)*deltaD] +! <--------- eta_sum ---------> +! // z0_eff = (wl^4/!pi^5)*(1./k2)*eta_mie + eta_sum = 0. + if (size(D0) == 1) then + eta_sum = qbsca(1)*(n(1)*1E6)*D0(1)**2 + else + call avint(qbsca*N0*D0**2,D0,nsizes,D0(1),D0(size(D0,1)),eta_sum) + endif + + eta_mie = eta_sum*0.25*pi + const = (wl**4/pi**5)*(1./k2) + z0_eff = const*eta_mie + +! // kr = 0.25*cr*sum[qext*pi*D^2*N(D)*deltaD] +! <---------- k_sum ---------> + k_sum = 0. + if (size(D0) == 1) then + k_sum = qext(1)*(n(1)*1E6)*D0(1)**2 + else + call avint(qext*N0*D0**2,D0,nsizes,D0(1),D0(size(D0,1)),k_sum) + endif + cr = 10./log(10.) + kr = k_sum*0.25*pi*(1000.*cr) + +! // z_ray = sum[D^6*N(D)*deltaD] + if (xr == 1) then + z0_ray = 0. + if (size(D0) == 1) then + z0_ray = (n(1)*1E6)*D0(1)**6 + else + call avint(N0*D0**6,D0,nsizes,D0(1),D0(size(D0)),z0_ray) + endif + endif + +! // convert to mm^6/m^3 + z_eff = z0_eff*1E18 ! 10.*alog10(z0_eff*1E18) + z_ray = z0_ray*1E18 ! 10.*alog10(z0_ray*1E18) + + end subroutine zeff Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/PVtheta.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/PVtheta.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/PVtheta.F (revision 1280) @@ -0,0 +1,196 @@ + SUBROUTINE PVtheta(ilon,ilev,pucov,pvcov,pteta, + $ ztfi,zplay,zplev, + $ nbteta,theta,PVteta) + IMPLICIT none + +c======================================================================= +c +c Auteur: I. Musat +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c Calcul de la vorticite potentielle PVteta sur des iso-theta selon +c la methodologie du NCEP/NCAR : +c 1) on calcule la stabilite statique N**2=g/T*(dT/dz+g/cp) sur les +c niveaux du modele => N2 +c 2) on interpole les vents, la temperature et le N**2 sur des isentropes +c (en fait sur des iso-theta) lineairement en log(theta) => +c ucovteta, vcovteta, N2teta +c 3) on calcule la vorticite absolue sur des iso-theta => vorateta +c 4) on calcule la densite rho sur des iso-theta => rhoteta +c +c rhoteta = (T/theta)**(cp/R)*p0/(R*T) +c +c 5) on calcule la vorticite potentielle sur des iso-theta => PVteta +c +c PVteta = (vorateta * N2 * theta)/(g * rhoteta) ! en PVU +c +c NB: 1PVU=10**(-6) K*m**2/(s * kg) +c +c PVteta = vorateta * N2/(g**2 * rhoteta) ! en 1/(Pa*s) +c +c +c ******************************************************************* +c +c +c Variables d'entree : ilon,ilev,pucov,pvcov,pteta,ztfi,zplay,zplev,nbteta,theta +c -> sur la grille dynamique +c Variable de sortie : PVteta +c -> sur la grille physique +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +c +c variables Input +c + INTEGER ilon, ilev + REAL pvcov(iip1,jjm,ilev) + REAL pucov(iip1,jjp1,ilev) + REAL pteta(iip1,jjp1,ilev) + REAL ztfi(ilon,ilev) + REAL zplay(ilon,ilev), zplev(ilon,ilev+1) + INTEGER nbteta + REAL theta(nbteta) +c +c variable Output +c + REAL PVteta(ilon,nbteta) +c +c variables locales +c + INTEGER i, j, l, ig0 + REAL SSUM + REAL teta(ilon, ilev) + REAL ptetau(ip1jmp1, ilev), ptetav(ip1jm, ilev) + REAL ucovteta(ip1jmp1,ilev), vcovteta(ip1jm,ilev) + REAL N2(ilon,ilev-1), N2teta(ilon,nbteta) + REAL ztfiteta(ilon,nbteta) + REAL rhoteta(ilon,nbteta) + REAL vorateta(iip1,jjm,nbteta) + REAL voratetafi(ilon,nbteta), vorpol(iim) +c +#include "comgeom2.h" +#include "comconst.h" +#include "comvert.h" +c +c projection teta sur la grille physique +c + DO l=1,llm + teta(1,l) = pteta(1,1,l) + ig0 = 2 + DO j = 2, jjm + DO i = 1, iim + teta(ig0,l) = pteta(i,j,l) + ig0 = ig0 + 1 + ENDDO + ENDDO + teta(ig0,l) = pteta(1,jjp1,l) + ENDDO +c +c calcul pteta sur les grilles U et V +c + DO l=1, llm + DO j=1, jjp1 + DO i=1, iip1 + ig0=i+(j-1)*iip1 + ptetau(ig0,l)=pteta(i,j,l) + ENDDO !i + ENDDO !j + DO j=1, jjm + DO i=1, iip1 + ig0=i+(j-1)*iip1 + ptetav(ig0,l)=0.5*(pteta(i,j,l)+pteta(i,j+1,l)) + ENDDO !i + ENDDO !j + ENDDO !l +c +c projection pucov, pvcov sur une surface de theta constante +c + DO l=1, nbteta +cIM 1rout CALL tetaleveli1j1(ip1jmp1,llm,.true.,ptetau,theta(l), + CALL tetalevel(ip1jmp1,llm,.true.,ptetau,theta(l), + . pucov,ucovteta(:,l)) +cIM 1rout CALL tetaleveli1j(ip1jm,llm,.true.,ptetav,theta(l), + CALL tetalevel(ip1jm,llm,.true.,ptetav,theta(l), + . pvcov,vcovteta(:,l)) + ENDDO !l +c +c calcul vorticite absolue sur une iso-theta : vorateta +c + CALL tourabs(nbteta,vcovteta,ucovteta,vorateta) +c +c projection vorateta sur la grille physique => voratetafi +c + DO l=1,nbteta + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim + voratetafi(ig0+i+1,l) = vorateta( i ,j-1,l) * alpha4(i+1,j) + + $ vorateta(i+1,j-1,l) * alpha1(i+1,j) + + $ vorateta(i ,j ,l) * alpha3(i+1,j) + + $ vorateta(i+1,j ,l) * alpha2(i+1,j) + ENDDO + voratetafi(ig0 +1,l) = voratetafi(ig0 +1+ iim,l) + ENDDO + ENDDO +c + DO l=1,nbteta + DO i=1,iim + vorpol(i) = vorateta(i,1,l)*aire(i,1) + ENDDO + voratetafi(1,l)= SSUM(iim,vorpol,1)/apoln + ENDDO +c + DO l=1,nbteta + DO i=1,iim + vorpol(i) = vorateta(i,jjm,l)* aire(i,jjm +1) + ENDDO + voratetafi(ilon,l)= SSUM(iim,vorpol,1)/apols + ENDDO +c +c calcul N**2 sur la grille physique => N2 +c + DO l=1, llm-1 + DO i=1, ilon + N2(i,l) = (g**2 * zplay(i,l) * + $ (ztfi(i,l+1)-ztfi(i,l)) )/ + $ (R*ztfi(i,l)*ztfi(i,l)* + $ (zplev(i,l)-zplev(i,l+1)) )+ + $ (g**2)/(ztfi(i,l)*CPP) + ENDDO !i + ENDDO !l +c +c calcul N2 sur une iso-theta => N2teta +c + DO l=1, nbteta + CALL tetalevel(ilon,llm-1,.true.,teta,theta(l), + $ N2,N2teta(:,l)) + CALL tetalevel(ilon,llm,.true.,teta,theta(l), + $ ztfi,ztfiteta(:,l)) + ENDDO !l=1, nbteta +c +c calcul rho et PV sur une iso-theta : rhoteta, PVteta +c + DO l=1, nbteta + DO i=1, ilon + rhoteta(i,l)=(ztfiteta(i,l)/theta(l))**(CPP/R)* + $ (preff/(R*ztfiteta(i,l))) +c +c PVteta en PVU +c + PVteta(i,l)=(theta(l)*g*voratetafi(i,l)*N2teta(i,l))/ + $ (g**2*rhoteta(i,l)) +c +c PVteta en 1/(Pa*s) +c + PVteta(i,l)=(voratetafi(i,l)*N2teta(i,l))/ + $ (g**2*rhoteta(i,l)) + ENDDO !i + ENDDO !l +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/abort_gcm.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/abort_gcm.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/abort_gcm.F (revision 1280) @@ -0,0 +1,54 @@ +! +! $Id$ +! +c +c + SUBROUTINE abort_gcm(modname, message, ierr) + +#ifdef CPP_IOIPSL + USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin_dump + USE ioipsl_getincom +#endif +#include "iniprint.h" + +C +C Stops the simulation cleanly, closing files and printing various +C comments +C +C Input: modname = name of calling program +C message = stuff to print +C ierr = severity of situation ( = 0 normal ) + + character(len=*) modname + integer ierr + character(len=*) message + +! write(lunout,*) 'in abort_gcm' + write(6,*) 'in abort_gcm' +#ifdef CPP_IOIPSL + call histclo + call restclo +#endif + call getin_dump +c call histclo(2) +c call histclo(3) +c call histclo(4) +c call histclo(5) +c write(lunout,*) 'Stopping in ', modname +c write(lunout,*) 'Reason = ',message +c if (ierr .eq. 0) then +c write(lunout,*) 'Everything is cool' +c else +c write(lunout,*) 'Houston, we have a problem ', ierr +c endif + write(6,*) 'Stopping in ', modname + write(6,*) 'Reason = ',message + if (ierr .eq. 0) then + write(6,*) 'Everything is cool' + else + write(6,*) 'Houston, we have a problem ', ierr + endif + STOP + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/academic.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/academic.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/academic.h (revision 1280) @@ -0,0 +1,5 @@ +! +! $Header$ +! + real tetarappel(ip1jmp1,llm),taurappel + common/academic/tetarappel,taurappel Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/adaptdt.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/adaptdt.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/adaptdt.F (revision 1280) @@ -0,0 +1,59 @@ +! +! $Header$ +! + subroutine adaptdt(nadv,dtbon,n,pbaru, + c masse) + + IMPLICIT NONE + +#include "dimensions.h" +c#include "paramr2.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissip.h" +#include "comvert.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "control.h" +#include "ener.h" +#include "description.h" + +c---------------------------------------------------------- +c Arguments +c---------------------------------------------------------- + INTEGER n,nadv + REAL dtbon + REAL pbaru(iip1,jjp1,llm) + REAL masse(iip1,jjp1,llm) +c---------------------------------------------------------- +c Local +c---------------------------------------------------------- + INTEGER i,j,l + REAL CFLmax,aaa,bbb + + CFLmax=0. + do l=1,llm + do j=2,jjm + do i=1,iim + aaa=pbaru(i,j,l)*dtvr/masse(i,j,l) + CFLmax=max(CFLmax,aaa) + bbb=-pbaru(i,j,l)*dtvr/masse(i+1,j,l) + CFLmax=max(CFLmax,bbb) + enddo + enddo + enddo + n=int(CFLmax)+1 +c pour reproduire cas VL du code qui appele x,y,z,y,x +c if (nadv.eq.30) n=n/2 ! Pour Prather + dtbon=dtvr/n + + return + end + + + + + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/addfi.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/addfi.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/addfi.F (revision 1280) @@ -0,0 +1,167 @@ +! +! $Header$ +! + SUBROUTINE addfi(pdt, leapf, forward, + S pucov, pvcov, pteta, pq , pps , + S pdufi, pdvfi, pdhfi,pdqfi, pdpfi ) + + USE infotrac, ONLY : nqtot + IMPLICIT NONE +c +c======================================================================= +c +c Addition of the physical tendencies +c +c Interface : +c ----------- +c +c Input : +c ------- +c pdt time step of integration +c leapf logical +c forward logical +c pucov(ip1jmp1,llm) first component of the covariant velocity +c pvcov(ip1ip1jm,llm) second component of the covariant velocity +c pteta(ip1jmp1,llm) potential temperature +c pts(ip1jmp1,llm) surface temperature +c pdufi(ip1jmp1,llm) | +c pdvfi(ip1jm,llm) | respective +c pdhfi(ip1jmp1) | tendencies +c pdtsfi(ip1jmp1) | +c +c Output : +c -------- +c pucov +c pvcov +c ph +c pts +c +c +c======================================================================= +c +c----------------------------------------------------------------------- +c +c 0. Declarations : +c ------------------ +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "serre.h" +c +c Arguments : +c ----------- +c + REAL pdt +c + REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm) + REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nqtot),pps(ip1jmp1) +c + REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm) + REAL pdqfi(ip1jmp1,llm,nqtot),pdhfi(ip1jmp1,llm),pdpfi(ip1jmp1) +c + LOGICAL leapf,forward +c +c +c Local variables : +c ----------------- +c + REAL xpn(iim),xps(iim),tpn,tps + INTEGER j,k,iq,ij + REAL qtestw, qtestt + PARAMETER ( qtestw = 1.0e-15 ) + PARAMETER ( qtestt = 1.0e-40 ) + + REAL SSUM +c +c----------------------------------------------------------------------- + + DO k = 1,llm + DO j = 1,ip1jmp1 + pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt + ENDDO + ENDDO + + DO k = 1, llm + DO ij = 1, iim + xpn(ij) = aire( ij ) * pteta( ij ,k) + xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k) + ENDDO + tpn = SSUM(iim,xpn,1)/ apoln + tps = SSUM(iim,xps,1)/ apols + + DO ij = 1, iip1 + pteta( ij ,k) = tpn + pteta(ij+ip1jm,k) = tps + ENDDO + ENDDO +c + + DO k = 1,llm + DO j = iip2,ip1jm + pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt + ENDDO + ENDDO + + DO k = 1,llm + DO j = 1,ip1jm + pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt + ENDDO + ENDDO + +c + DO j = 1,ip1jmp1 + pps(j) = pps(j) + pdpfi(j) * pdt + ENDDO + + DO iq = 1, 2 + DO k = 1,llm + DO j = 1,ip1jmp1 + pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt + pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw ) + ENDDO + ENDDO + ENDDO + + DO iq = 3, nqtot + DO k = 1,llm + DO j = 1,ip1jmp1 + pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt + pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt ) + ENDDO + ENDDO + ENDDO + + + DO ij = 1, iim + xpn(ij) = aire( ij ) * pps( ij ) + xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm ) + ENDDO + tpn = SSUM(iim,xpn,1)/apoln + tps = SSUM(iim,xps,1)/apols + + DO ij = 1, iip1 + pps ( ij ) = tpn + pps ( ij+ip1jm ) = tps + ENDDO + + + DO iq = 1, nqtot + DO k = 1, llm + DO ij = 1, iim + xpn(ij) = aire( ij ) * pq( ij ,k,iq) + xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq) + ENDDO + tpn = SSUM(iim,xpn,1)/apoln + tps = SSUM(iim,xps,1)/apols + + DO ij = 1, iip1 + pq ( ij ,k,iq) = tpn + pq (ij+ip1jm,k,iq) = tps + ENDDO + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advect.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advect.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advect.F (revision 1280) @@ -0,0 +1,166 @@ +! +! $Header$ +! + SUBROUTINE advect(ucov,vcov,teta,w,massebx,masseby,du,dv,dteta) + + IMPLICIT NONE +c======================================================================= +c +c Auteurs: P. Le Van , Fr. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ************************************************************* +c .... calcul des termes d'advection vertic.pour u,v,teta,q ... +c ************************************************************* +c ces termes sont ajoutes a du,dv,dteta et dq . +c Modif F.Forget 03/94 : on retire q de advect +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "ener.h" + +c Arguments: +c ---------- + + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm) + REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm) + +c Local: +c ------ + + REAL uav(ip1jmp1,llm),vav(ip1jm,llm),wsur2(ip1jmp1) + REAL unsaire2(ip1jmp1), ge(ip1jmp1) + REAL deuxjour, ww, gt, uu, vv + + INTEGER ij,l + + REAL SSUM + +c----------------------------------------------------------------------- +c 2. Calculs preliminaires: +c ------------------------- + + IF (conser) THEN + deuxjour = 2. * daysec + + DO 1 ij = 1, ip1jmp1 + unsaire2(ij) = unsaire(ij) * unsaire(ij) + 1 CONTINUE + END IF + + +c------------------ -yy ---------------------------------------------- +c . Calcul de u + + DO l=1,llm + DO ij = iip2, ip1jmp1 + uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) ) + ENDDO + DO ij = iip2, ip1jm + uav(ij,l) = uav(ij,l) + uav(ij+iip1,l) + ENDDO + DO ij = 1, iip1 + uav(ij ,l) = 0. + uav(ip1jm+ij,l) = 0. + ENDDO + ENDDO + +c------------------ -xx ---------------------------------------------- +c . Calcul de v + + DO l=1,llm + DO ij = 2, ip1jm + vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) ) + ENDDO + DO ij = 1,ip1jm,iip1 + vav(ij,l) = vav(ij+iim,l) + ENDDO + DO ij = 1, ip1jm-1 + vav(ij,l) = vav(ij,l) + vav(ij+1,l) + ENDDO + DO ij = 1, ip1jm, iip1 + vav(ij+iim,l) = vav(ij,l) + ENDDO + ENDDO + +c----------------------------------------------------------------------- + +c + DO 20 l = 1, llmm1 + + +c ...... calcul de - w/2. au niveau l+1 ....... + + DO 5 ij = 1, ip1jmp1 + wsur2( ij ) = - 0.5 * w( ij,l+1 ) + 5 CONTINUE + + +c ..................... calcul pour du .................. + + DO 6 ij = iip2 ,ip1jm-1 + ww = wsur2 ( ij ) + wsur2( ij+1 ) + uu = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) ) + du(ij,l) = du(ij,l) - ww * ( uu - uav(ij, l ) )/massebx(ij, l ) + du(ij,l+1)= du(ij,l+1) + ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1) + 6 CONTINUE + +c ..... correction pour du(iip1,j,l) ........ +c ..... du(iip1,j,l)= du(1,j,l) ..... + +CDIR$ IVDEP + DO 7 ij = iip1 +iip1, ip1jm, iip1 + du( ij, l ) = du( ij -iim, l ) + du( ij,l+1 ) = du( ij -iim,l+1 ) + 7 CONTINUE + +c ................. calcul pour dv ..................... + + DO 8 ij = 1, ip1jm + ww = wsur2( ij+iip1 ) + wsur2( ij ) + vv = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) ) + dv(ij,l) = dv(ij, l ) - ww * (vv - vav(ij, l ) )/masseby(ij, l ) + dv(ij,l+1)= dv(ij,l+1) + ww * (vv - vav(ij,l+1) )/masseby(ij,l+1) + 8 CONTINUE + +c + +c ............................................................ +c ............... calcul pour dh ................... +c ............................................................ + +c ---z +c calcul de - d( teta * w ) qu'on ajoute a dh +c ............... + + DO 15 ij = 1, ip1jmp1 + ww = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) ) + dteta(ij, l ) = dteta(ij, l ) - ww + dteta(ij,l+1) = dteta(ij,l+1) + ww + 15 CONTINUE + + IF( conser) THEN + DO 17 ij = 1,ip1jmp1 + ge(ij) = wsur2(ij) * wsur2(ij) * unsaire2(ij) + 17 CONTINUE + gt = SSUM( ip1jmp1,ge,1 ) + gtot(l) = deuxjour * SQRT( gt/ip1jmp1 ) + END IF + + 20 CONTINUE + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advn.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advn.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advn.F (revision 1280) @@ -0,0 +1,983 @@ +! +! $Header$ +! + SUBROUTINE advn(q,masse,w,pbaru,pbarv,pdt,mode) +c +c Auteur : F. Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c pbaru,pbarv,w flux de masse en u ,v ,w +c pdt pas de temps +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +#include "iniprint.h" + +c +c Arguments: +c ---------- + integer mode + real masse(ip1jmp1,llm) + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL q(ip1jmp1,llm) + REAL w(ip1jmp1,llm),pdt +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii + integer ijlqmin,iqmin,jqmin,lqmin + integer ismin +c + real zm(ip1jmp1,llm),newmasse + real mu(ip1jmp1,llm) + real mv(ip1jm,llm) + real mw(ip1jmp1,llm+1) + real zq(ip1jmp1,llm),zz,qpn,qps + real zqg(ip1jmp1,llm),zqd(ip1jmp1,llm) + real zqs(ip1jmp1,llm),zqn(ip1jmp1,llm) + real zqh(ip1jmp1,llm),zqb(ip1jmp1,llm) + real temps0,temps1,temps2,temps3 + real ztemps1,ztemps2,ztemps3,ssum + logical testcpu + save testcpu + save temps1,temps2,temps3 + real zzpbar,zzw + +#ifdef CRAY + real second +#endif + + real qmin,qmax + data qmin,qmax/0.,1./ + data testcpu/.false./ + data temps1,temps2,temps3/0.,0.,0./ + + zzpbar = 0.5 * pdt + zzw = pdt + + DO l=1,llm + DO ij = iip2,ip1jm + mu(ij,l)=pbaru(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jm + mv(ij,l)=pbarv(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jmp1 + mw(ij,l)=w(ij,l) * zzw + ENDDO + ENDDO + + DO ij=1,ip1jmp1 + mw(ij,llm+1)=0. + ENDDO + + do l=1,llm + qpn=0. + qps=0. + do ij=1,iim + qpn=qpn+q(ij,l)*masse(ij,l) + qps=qps+q(ip1jm+ij,l)*masse(ip1jm+ij,l) + enddo + qpn=qpn/ssum(iim,masse(1,l),1) + qps=qps/ssum(iim,masse(ip1jm+1,l),1) + do ij=1,iip1 + q(ij,l)=qpn + q(ip1jm+ij,l)=qps + enddo + enddo + + do ij=1,ip1jmp1 + mw(ij,llm+1)=0. + enddo + do l=1,llm + do ij=1,ip1jmp1 + zq(ij,l)=q(ij,l) + zm(ij,l)=masse(ij,l) + enddo + enddo + +c call minmaxq(zq,qmin,qmax,'avant vlx ') + call advnqx(zq,zqg,zqd) + call advnx(zq,zqg,zqd,zm,mu,mode) + call advnqy(zq,zqs,zqn) + call advny(zq,zqs,zqn,zm,mv) + call advnqz(zq,zqh,zqb) + call advnz(zq,zqh,zqb,zm,mw) +c call vlz(zq,0.,zm,mw) + call advnqy(zq,zqs,zqn) + call advny(zq,zqs,zqn,zm,mv) + call advnqx(zq,zqg,zqd) + call advnx(zq,zqg,zqd,zm,mu,mode) +c call minmaxq(zq,qmin,qmax,'apres vlx ') + +#ifdef CRAY + if(testcpu) then + ztemps1=second(0.) + temps1=temps1+ztemps1-ztemps2 + print*,'VLSPLT X:',temps1,' Y:',temps2,' Z:',temps3 + endif +#endif + do l=1,llm + do ij=1,ip1jmp1 + q(ij,l)=zq(ij,l) + enddo + do ij=1,ip1jm+1,iip1 + q(ij+iim,l)=q(ij,l) + enddo + enddo + + RETURN + END + + SUBROUTINE advnqx(q,qg,qd) +c +c Auteurs: Calcul des valeurs de q aux point u. +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real q(ip1jmp1,llm),qg(ip1jmp1,llm),qd(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real dxqu(ip1jmp1),zqu(ip1jmp1) + real zqmax(ip1jmp1),zqmin(ip1jmp1) + logical extremum(ip1jmp1) + + integer mode + save mode + data mode/1/ + +c calcul des pentes en u: +c ----------------------- + if (mode.eq.0) then + do l=1,llm + do ij=1,ip1jm + qd(ij,l)=q(ij,l) + qg(ij,l)=q(ij,l) + enddo + enddo + else + do l = 1, llm + do ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + zqu(ij)=0.5*(q(ij+1,l)+q(ij,l)) + enddo + do ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) + zqu(ij)=zqu(ij-iim) + enddo + do ij=iip2,ip1jm-1 + zqu(ij)=zqu(ij)-dxqu(ij+1)/12. + enddo + do ij=iip1+iip1,ip1jm,iip1 + zqu(ij)=zqu(ij-iim) + enddo + do ij=iip2+1,ip1jm + zqu(ij)=zqu(ij)+dxqu(ij-1)/12. + enddo + do ij=iip1+iip1,ip1jm,iip1 + zqu(ij-iim)=zqu(ij) + enddo + +c calcul des valeurs max et min acceptees aux interfaces + + do ij=iip2,ip1jm-1 + zqmax(ij)=max(q(ij+1,l),q(ij,l)) + zqmin(ij)=min(q(ij+1,l),q(ij,l)) + enddo + do ij=iip1+iip1,ip1jm,iip1 + zqmax(ij)=zqmax(ij-iim) + zqmin(ij)=zqmin(ij-iim) + enddo + do ij=iip2+1,ip1jm + extremum(ij)=dxqu(ij)*dxqu(ij-1).le.0. + enddo + do ij=iip1+iip1,ip1jm,iip1 + extremum(ij-iim)=extremum(ij) + enddo + do ij=iip2,ip1jm + zqu(ij)=min(max(zqmin(ij),zqu(ij)),zqmax(ij)) + enddo + do ij=iip2+1,ip1jm + if(extremum(ij)) then + qg(ij,l)=q(ij,l) + qd(ij,l)=q(ij,l) + else + qd(ij,l)=zqu(ij) + qg(ij,l)=zqu(ij-1) + endif + enddo + do ij=iip1+iip1,ip1jm,iip1 + qd(ij-iim,l)=qd(ij,l) + qg(ij-iim,l)=qg(ij,l) + enddo + + goto 8888 + + do ij=iip2+1,ip1jm + if(extremum(ij).and..not.extremum(ij-1)) + s qd(ij-1,l)=q(ij,l) + enddo + + do ij=iip1+iip1,ip1jm,iip1 + qd(ij-iim,l)=qd(ij,l) + enddo + do ij=iip2,ip1jm-1 + if (extremum(ij).and..not.extremum(ij+1)) + s qg(ij+1,l)=q(ij,l) + enddo + + do ij=iip1+iip1,ip1jm,iip1 + qg(ij,l)=qg(ij-iim,l) + enddo +8888 continue + enddo + endif + RETURN + END + SUBROUTINE advnqy(q,qs,qn) +c +c Auteurs: Calcul des valeurs de q aux point v. +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real q(ip1jmp1,llm),qs(ip1jmp1,llm),qn(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real dyqv(ip1jm),zqv(ip1jm,llm) + real zqmax(ip1jm),zqmin(ip1jm) + logical extremum(ip1jmp1) + + integer mode + save mode + data mode/1/ + + if (mode.eq.0) then + do l=1,llm + do ij=1,ip1jmp1 + qn(ij,l)=q(ij,l) + qs(ij,l)=q(ij,l) + enddo + enddo + else + +c calcul des pentes en u: +c ----------------------- + do l = 1, llm + do ij=1,ip1jm + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + enddo + + do ij=iip2,ip1jm-iip1 + zqv(ij,l)=0.5*(q(ij+iip1,l)+q(ij,l)) + zqv(ij,l)=zqv(ij,l)+(dyqv(ij+iip1)-dyqv(ij-iip1))/12. + enddo + + do ij=iip2,ip1jm + extremum(ij)=dyqv(ij)*dyqv(ij-iip1).le.0. + enddo + +c Pas de pentes aux poles + do ij=1,iip1 + zqv(ij,l)=q(ij,l) + zqv(ip1jm-iip1+ij,l)=q(ip1jm+ij,l) + extremum(ij)=.true. + extremum(ip1jmp1-iip1+ij)=.true. + enddo + +c calcul des valeurs max et min acceptees aux interfaces + do ij=1,ip1jm + zqmax(ij)=max(q(ij+iip1,l),q(ij,l)) + zqmin(ij)=min(q(ij+iip1,l),q(ij,l)) + enddo + + do ij=1,ip1jm + zqv(ij,l)=min(max(zqmin(ij),zqv(ij,l)),zqmax(ij)) + enddo + + do ij=iip2,ip1jm + if(extremum(ij)) then + qs(ij,l)=q(ij,l) + qn(ij,l)=q(ij,l) +c if (.not.extremum(ij-iip1)) qs(ij-iip1,l)=q(ij,l) +c if (.not.extremum(ij+iip1)) qn(ij+iip1,l)=q(ij,l) + else + qs(ij,l)=zqv(ij,l) + qn(ij,l)=zqv(ij-iip1,l) + endif + enddo + + do ij=1,iip1 + qs(ij,l)=q(ij,l) + qn(ij,l)=q(ij,l) + qs(ip1jm+ij,l)=q(ip1jm+ij,l) + qn(ip1jm+ij,l)=q(ip1jm+ij,l) + enddo + + enddo + endif + RETURN + END + + SUBROUTINE advnqz(q,qh,qb) +c +c Auteurs: Calcul des valeurs de q aux point v. +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real q(ip1jmp1,llm),qh(ip1jmp1,llm),qb(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real dzqw(ip1jmp1,llm+1),zqw(ip1jmp1,llm+1) + real zqmax(ip1jmp1,llm),zqmin(ip1jmp1,llm) + logical extremum(ip1jmp1,llm) + + integer mode + save mode + + data mode/1/ + +c calcul des pentes en u: +c ----------------------- + + if (mode.eq.0) then + do l=1,llm + do ij=1,ip1jmp1 + qb(ij,l)=q(ij,l) + qh(ij,l)=q(ij,l) + enddo + enddo + else + do l = 2, llm + do ij=1,ip1jmp1 + dzqw(ij,l)=q(ij,l-1)-q(ij,l) + zqw(ij,l)=0.5*(q(ij,l-1)+q(ij,l)) + enddo + enddo + do ij=1,ip1jmp1 + dzqw(ij,1)=0. + dzqw(ij,llm+1)=0. + enddo + do l=2,llm + do ij=1,ip1jmp1 + zqw(ij,l)=zqw(ij,l)+(dzqw(ij,l+1)-dzqw(ij,l-1))/12. + enddo + enddo + do l=2,llm-1 + do ij=1,ip1jmp1 + extremum(ij,l)=dzqw(ij,l)*dzqw(ij,l+1).le.0. + enddo + enddo + +c Pas de pentes en bas et en haut + do ij=1,ip1jmp1 + zqw(ij,2)=q(ij,1) + zqw(ij,llm)=q(ij,llm) + extremum(ij,1)=.true. + extremum(ij,llm)=.true. + enddo + +c calcul des valeurs max et min acceptees aux interfaces + do l=2,llm + do ij=1,ip1jmp1 + zqmax(ij,l)=max(q(ij,l-1),q(ij,l)) + zqmin(ij,l)=min(q(ij,l-1),q(ij,l)) + enddo + enddo + + do l=2,llm + do ij=1,ip1jmp1 + zqw(ij,l)=min(max(zqmin(ij,l),zqw(ij,l)),zqmax(ij,l)) + enddo + enddo + + do l=2,llm-1 + do ij=1,ip1jmp1 + if(extremum(ij,l)) then + qh(ij,l)=q(ij,l) + qb(ij,l)=q(ij,l) + else + qh(ij,l)=zqw(ij,l+1) + qb(ij,l)=zqw(ij,l) + endif + enddo + enddo +c do l=2,llm-1 +c do ij=1,ip1jmp1 +c if(extremum(ij,l)) then +c if (.not.extremum(ij,l-1)) qh(ij,l-1)=q(ij,l) +c if (.not.extremum(ij,l+1)) qb(ij,l+1)=q(ij,l) +c endif +c enddo +c enddo + + do ij=1,ip1jmp1 + qb(ij,1)=q(ij,1) + qh(ij,1)=q(ij,1) + qb(ij,llm)=q(ij,llm) + qh(ij,llm)=q(ij,llm) + enddo + + endif + + RETURN + END + + SUBROUTINE advnx(q,qg,qd,masse,u_m,mode) +c +c Auteur : F. Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + integer mode + real masse(ip1jmp1,llm) + real u_m( ip1jmp1,llm ) + real q(ip1jmp1,llm),qd(ip1jmp1,llm),qg(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,j,ij,l,indu(ip1jmp1),niju,iju,ijq + integer n0,nl(llm) +c + real new_m,zu_m,zdq,zz + real zsigg(ip1jmp1,llm),zsigd(ip1jmp1,llm),zsig + real u_mq(ip1jmp1,llm) + + real zm,zq,zsigm,zsigp,zqm,zqp,zu + + logical ladvplus(ip1jmp1,llm) + + real prec + save prec + +#ifdef CRAY + data prec/1.e-24/ +#else + data prec/1.e-15/ +#endif + + do l=1,llm + do ij=iip2,ip1jm + zdq=qd(ij,l)-qg(ij,l) +c if((qd(ij,l)-q(ij,l))*(q(ij,l)-qg(ij,l)).lt.0.) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,qd(ij,l),q(ij,l),qg(ij,l) +c qd(ij,l)=q(ij,l) +c qg(ij,l)=q(ij,l) +c endif + if(abs(zdq).gt.prec) then + zsigd(ij,l)=(q(ij,l)-qg(ij,l))/zdq + zsigg(ij,l)=1.-zsigd(ij,l) +c if(.not.(zsigd(ij,l).ge.0..and.zsigd(ij,l).le.1. .and. +c s zsigg(ij,l).ge.0..or.zsigg(ij,l).le.1.) ) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,'sigg=',zsigg(ij,l),' sigd=',zsigd(ij,l) +c print*,'q d,c,g ',qd(ij,l),q(ij,l),qg(ij,l),zdq +c stop +c endif + else + zsigd(ij,l)=0.5 + zsigg(ij,l)=0.5 + qd(ij,l)=q(ij,l) + qg(ij,l)=q(ij,l) + endif + enddo + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do l=1,llm + do ij=iip2,ip1jm-1 + if (u_m(ij,l).ge.0.) then + zsigp=zsigd(ij,l) + zsigm=zsigg(ij,l) + zqp=qd(ij,l) + zqm=qg(ij,l) + zm=masse(ij,l) + zq=q(ij,l) + else + zsigm=zsigd(ij+1,l) + zsigp=zsigg(ij+1,l) + zqm=qd(ij+1,l) + zqp=qg(ij+1,l) + zm=masse(ij+1,l) + zq=q(ij+1,l) + endif + zu=abs(u_m(ij,l)) + ladvplus(ij,l)=zu.gt.zm + zsig=zu/zm + if(zsig.eq.0.) zsigp=0.1 + if (mode.eq.1) then + if (zsig.le.zsigp) then + u_mq(ij,l)=u_m(ij,l)*zqp + else if (mode.eq.1) then + u_mq(ij,l)= + s sign(zm,u_m(ij,l))*(zsigp*zqp+(zsig-zsigp)*zqm) + endif + else + if (zsig.le.zsigp) then + u_mq(ij,l)=u_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) + else + zz=0.5*(zsig-zsigp)/zsigm + u_mq(ij,l)=sign(zm,u_m(ij,l))*( 0.5*(zq+zqp)*zsigp + s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) + endif + endif +c if(zsig.lt.0.) then +c print*,'au point ij=',ij,' l=',l,' sig=',zsig +c stop +c endif + enddo + enddo + + do l=1,llm + do ij=iip1+iip1,ip1jm,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + ladvplus(ij,l)=ladvplus(ij-iim,l) + enddo + enddo + +c================================================================= +C SCHEMA SEMI-LAGRAGIEN EN X DANS LES REGIONS POLAIRES +c================================================================= +c tris des regions a traiter + n0=0 + do l=1,llm + nl(l)=0 + do ij=iip2,ip1jm + if(ladvplus(ij,l)) then + nl(l)=nl(l)+1 + u_mq(ij,l)=0. + endif + enddo + n0=n0+nl(l) + enddo + + if(n0.gt.1) then + IF (prt_level > 9) WRITE(lunout,*) + & 'Nombre de points pour lesquels on advect plus que le' + & ,'contenu de la maille : ',n0 + + do l=1,llm + if(nl(l).gt.0) then + iju=0 +c indicage des mailles concernees par le traitement special + do ij=iip2,ip1jm + if(ladvplus(ij,l).and.mod(ij,iip1).ne.0) then + iju=iju+1 + indu(iju)=ij + endif + enddo + niju=iju +c print*,'niju,nl',niju,nl(l) + +c traitement des mailles + do iju=1,niju + ij=indu(iju) + j=(ij-1)/iip1+1 + zu_m=u_m(ij,l) + u_mq(ij,l)=0. + if(zu_m.gt.0.) then + ijq=ij + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l) + zu_m=zu_m-masse(ijq,l) + i=mod(i-2+iim,iim)+1 + ijq=(j-1)*iip1+i + enddo +c MODIFS SPECIFIQUES DU SCHEMA +c ajout de la maille non completement advectee + zsig=zu_m/masse(ijq,l) + if(zsig.le.zsigd(ijq,l)) then + u_mq(ij,l)=u_mq(ij,l)+zu_m*(qd(ijq,l) + s -0.5*zsig/zsigd(ijq,l)*(qd(ijq,l)-q(ijq,l))) + else +c u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l) +c goto 8888 + zz=0.5*(zsig-zsigd(ijq,l))/zsigg(ijq,l) + if(.not.(zz.gt.0..and.zz.le.0.5)) then + WRITE(lunout,*)'probleme2 au point ij=',ij, + s ' l=',l + WRITE(lunout,*)'zz=',zz + stop + endif + u_mq(ij,l)=u_mq(ij,l)+masse(ijq,l)*( + s 0.5*(q(ijq,l)+qd(ijq,l))*zsigd(ijq,l) + s +(zsig-zsigd(ijq,l))*(q(ijq,l)+zz*(qg(ijq,l)-q(ijq,l))) ) + endif + else + ijq=ij+1 + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(-zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l) + zu_m=zu_m+masse(ijq,l) + i=mod(i,iim)+1 + ijq=(j-1)*iip1+i + enddo +c ajout de la maille non completement advectee +c 2eme MODIF SPECIFIQUE + zsig=-zu_m/masse(ij+1,l) + if(zsig.le.zsigg(ijq,l)) then + u_mq(ij,l)=u_mq(ij,l)+zu_m*(qg(ijq,l) + s -0.5*zsig/zsigg(ijq,l)*(qg(ijq,l)-q(ijq,l))) + else +c u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l) +c goto 9999 + zz=0.5*(zsig-zsigg(ijq,l))/zsigd(ijq,l) + if(.not.(zz.gt.0..and.zz.le.0.5)) then + WRITE(lunout,*)'probleme22 au point ij=',ij + s ,' l=',l + WRITE(lunout,*)'zz=',zz + stop + endif + u_mq(ij,l)=u_mq(ij,l)-masse(ijq,l)*( + s 0.5*(q(ijq,l)+qg(ijq,l))*zsigg(ijq,l) + s +(zsig-zsigg(ijq,l))* + s (q(ijq,l)+zz*(qd(ijq,l)-q(ijq,l))) ) + endif +c fin de la modif + endif + enddo + endif + enddo + endif ! n0.gt.0 + +c bouclage en latitude + do l=1,llm + do ij=iip1+iip1,ip1jm,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + enddo + enddo + +c================================================================= +c CALCUL DE LA CONVERGENCE DES FLUX +c================================================================= + + do l=1,llm + do ij=iip2+1,ip1jm + new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+ + & u_mq(ij-1,l)-u_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + enddo +c Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous) + do ij=iip1+iip1,ip1jm,iip1 + q(ij-iim,l)=q(ij,l) + masse(ij-iim,l)=masse(ij,l) + enddo + enddo + + RETURN + END + SUBROUTINE advny(q,qs,qn,masse,v_m) +c +c Auteur : F. Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real masse(ip1jmp1,llm) + real v_m( ip1jm,llm ) + real q(ip1jmp1,llm),qn(ip1jmp1,llm),qs(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real new_m,zdq,zz + real zsigs(ip1jmp1),zsign(ip1jmp1),zsig + real v_mq(ip1jm,llm) + real convpn,convps,convmpn,convmps,massen,masses + real zm,zq,zsigm,zsigp,zqm,zqp + real ssum + real prec + save prec + +#ifdef CRAY + data prec/1.e-24/ +#else + data prec/1.e-15/ +#endif + do l=1,llm + do ij=1,ip1jmp1 + zdq=qn(ij,l)-qs(ij,l) +c if((qn(ij,l)-q(ij,l))*(q(ij,l)-qs(ij,l)).lt.0.) then +c print*,'probleme au point ij=',ij,' l=',l,' advnqx' +c print*,qn(ij,l),q(ij,l),qs(ij,l) +c qn(ij,l)=q(ij,l) +c qs(ij,l)=q(ij,l) +c endif + if(abs(zdq).gt.prec) then + zsign(ij)=(q(ij,l)-qs(ij,l))/zdq + zsigs(ij)=1.-zsign(ij) +c if(.not.(zsign(ij).ge.0..and.zsign(ij).le.1. .and. +c s zsigs(ij).ge.0..or.zsigs(ij).le.1.) ) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,'sigs=',zsigs(ij),' sign=',zsign(ij) +c stop +c endif + else + zsign(ij)=0.5 + zsigs(ij)=0.5 + endif + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do ij=1,ip1jm + if (v_m(ij,l).ge.0.) then + zsigp=zsign(ij+iip1) + zsigm=zsigs(ij+iip1) + zqp=qn(ij+iip1,l) + zqm=qs(ij+iip1,l) + zm=masse(ij+iip1,l) + zq=q(ij+iip1,l) + else + zsigm=zsign(ij) + zsigp=zsigs(ij) + zqm=qn(ij,l) + zqp=qs(ij,l) + zm=masse(ij,l) + zq=q(ij,l) + endif + zsig=abs(v_m(ij,l))/zm + if(zsig.eq.0.) zsigp=0.1 + if (zsig.le.zsigp) then + v_mq(ij,l)=v_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) + else + zz=0.5*(zsig-zsigp)/zsigm + v_mq(ij,l)=sign(zm,v_m(ij,l))*( 0.5*(zq+zqp)*zsigp + s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) + endif + enddo + enddo + + do l=1,llm + do ij=iip2,ip1jm + new_m=masse(ij,l) + & +v_m(ij,l)-v_m(ij-iip1,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+v_mq(ij,l)-v_mq(ij-iip1,l)) + & /new_m + masse(ij,l)=new_m + enddo +c.-. ancienne version + convpn=SSUM(iim,v_mq(1,l),1) + convmpn=ssum(iim,v_m(1,l),1) + massen=ssum(iim,masse(1,l),1) + new_m=massen+convmpn + q(1,l)=(q(1,l)*massen+convpn)/new_m + do ij = 1,iip1 + q(ij,l)=q(1,l) + masse(ij,l)=new_m*aire(ij)/apoln + enddo + + convps=-SSUM(iim,v_mq(ip1jm-iim,l),1) + convmps=-ssum(iim,v_m(ip1jm-iim,l),1) + masses=ssum(iim,masse(ip1jm+1,l),1) + new_m=masses+convmps + q(ip1jm+1,l)=(q(ip1jm+1,l)*masses+convps)/new_m + do ij = ip1jm+1,ip1jmp1 + q(ij,l)=q(ip1jm+1,l) + masse(ij,l)=new_m*aire(ij)/apols + enddo + enddo + + RETURN + END + SUBROUTINE advnz(q,qh,qb,masse,w_m) +c +c Auteurs: F.Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c b designe le bas et h le haut +c il y a une correspondance entre le b en z et le d en x +c ******************************************************************** +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real masse(ip1jmp1,llm) + real w_m( ip1jmp1,llm+1) + real q(ip1jmp1,llm),qb(ip1jmp1,llm),qh(ip1jmp1,llm) + +c +c Local +c --------- +c + INTEGER ij,l +c + real new_m,zdq,zz + real zsigh(ip1jmp1,llm),zsigb(ip1jmp1,llm),zsig + real w_mq(ip1jmp1,llm+1) + real zm,zq,zsigm,zsigp,zqm,zqp + real prec + save prec + +#ifdef CRAY + data prec/1.e-24/ +#else + data prec/1.e-13/ +#endif + + do l=1,llm + do ij=1,ip1jmp1 + zdq=qb(ij,l)-qh(ij,l) +c if((qh(ij,l)-q(ij,l))*(q(ij,l)-qb(ij,l)).lt.0.) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,qh(ij,l),q(ij,l),qb(ij,l) +c qh(ij,l)=q(ij,l) +c qb(ij,l)=q(ij,l) +c endif + + if(abs(zdq).gt.prec) then + zsigb(ij,l)=(q(ij,l)-qh(ij,l))/zdq + zsigh(ij,l)=1.-zsigb(ij,l) + zsigb(ij,l)=min(max(zsigb(ij,l),0.),1.) + else + zsigb(ij,l)=0.5 + zsigh(ij,l)=0.5 + endif + enddo + enddo + +c print*,'ok1' +c calcul de la pente maximum dans la maille en valeur absolue + do l=2,llm + do ij=1,ip1jmp1 + if (w_m(ij,l).ge.0.) then + zsigp=zsigb(ij,l) + zsigm=zsigh(ij,l) + zqp=qb(ij,l) + zqm=qh(ij,l) + zm=masse(ij,l) + zq=q(ij,l) + else + zsigm=zsigb(ij,l-1) + zsigp=zsigh(ij,l-1) + zqm=qb(ij,l-1) + zqp=qh(ij,l-1) + zm=masse(ij,l-1) + zq=q(ij,l-1) + endif + zsig=abs(w_m(ij,l))/zm + if(zsig.eq.0.) zsigp=0.1 + if (zsig.le.zsigp) then + w_mq(ij,l)=w_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) + else + zz=0.5*(zsig-zsigp)/zsigm + w_mq(ij,l)=sign(zm,w_m(ij,l))*( 0.5*(zq+zqp)*zsigp + s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) + endif + enddo + enddo + + do ij=1,ip1jmp1 + w_mq(ij,llm+1)=0. + w_mq(ij,1)=0. + enddo + + do l=1,llm + do ij=1,ip1jmp1 + new_m=masse(ij,l)+w_m(ij,l+1)-w_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+w_mq(ij,l+1)-w_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + enddo + enddo +c print*,'ok3' + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advtrac.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advtrac.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advtrac.F (revision 1280) @@ -0,0 +1,404 @@ +! +! $Id$ +! +c +c + SUBROUTINE advtrac(pbaru,pbarv , + * p, masse,q,iapptrac,teta, + * flxw, + * pk) +c Auteur : F. Hourdin +c +c Modif. P. Le Van (20/12/97) +c F. Codron (10/99) +c D. Le Croller (07/2001) +c M.A Filiberti (04/2002) +c + USE infotrac + + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comdissip.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "control.h" +#include "ener.h" +#include "description.h" +#include "iniprint.h" + +c------------------------------------------------------------------- +c Arguments +c------------------------------------------------------------------- +c Ajout PPM +c-------------------------------------------------------- + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm) +c-------------------------------------------------------- + INTEGER iapptrac + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL q(ip1jmp1,llm,nqtot),masse(ip1jmp1,llm) + REAL p( ip1jmp1,llmp1 ),teta(ip1jmp1,llm) + REAL pk(ip1jmp1,llm) + REAL flxw(ip1jmp1,llm) + +c------------------------------------------------------------- +c Variables locales +c------------------------------------------------------------- + + REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm) + REAL massem(ip1jmp1,llm),zdp(ip1jmp1) + REAL pbarug(ip1jmp1,llm),pbarvg(ip1jm,llm),wg(ip1jmp1,llm) + REAL (kind=kind(1.d0)) :: t_initial, t_final, tps_cpu + INTEGER iadvtr + INTEGER ij,l,iq,iiq + REAL zdpmin, zdpmax + EXTERNAL minmax + SAVE iadvtr, massem, pbaruc, pbarvc + DATA iadvtr/0/ +c---------------------------------------------------------- +c Rajouts pour PPM +c---------------------------------------------------------- + INTEGER indice,n + REAL dtbon ! Pas de temps adaptatif pour que CFL<1 + REAL CFLmaxz,aaa,bbb ! CFL maximum + REAL psppm(iim,jjp1) ! pression au sol + REAL unatppm(iim,jjp1,llm),vnatppm(iim,jjp1,llm) + REAL qppm(iim*jjp1,llm,nqtot) + REAL fluxwppm(iim,jjp1,llm) + REAL apppm(llmp1), bpppm(llmp1) + LOGICAL dum,fill + DATA fill/.true./ + DATA dum/.true./ + + integer,save :: countcfl=0 + real cflx(ip1jmp1,llm) + real cfly(ip1jm,llm) + real cflz(ip1jmp1,llm) + real, save :: cflxmax(llm),cflymax(llm),cflzmax(llm) + + IF(iadvtr.EQ.0) THEN + CALL initial0(ijp1llm,pbaruc) + CALL initial0(ijmllm,pbarvc) + ENDIF + +c accumulation des flux de masse horizontaux + DO l=1,llm + DO ij = 1,ip1jmp1 + pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l) + ENDDO + DO ij = 1,ip1jm + pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l) + ENDDO + ENDDO + +c selection de la masse instantannee des mailles avant le transport. + IF(iadvtr.EQ.0) THEN + + CALL SCOPY(ip1jmp1*llm,masse,1,massem,1) +ccc CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 ) +c + ENDIF + + iadvtr = iadvtr+1 + iapptrac = iadvtr + + +c Test pour savoir si on advecte a ce pas de temps + IF ( iadvtr.EQ.iapp_tracvl ) THEN + +cc .. Modif P.Le Van ( 20/12/97 ) .... +cc + +c traitement des flux de masse avant advection. +c 1. calcul de w +c 2. groupement des mailles pres du pole. + + CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg ) + + ! ... Flux de masse diaganostiques traceurs + flxw = wg / FLOAT(iapp_tracvl) + +c test sur l'eventuelle creation de valeurs negatives de la masse + DO l=1,llm-1 + DO ij = iip2+1,ip1jm + zdp(ij) = pbarug(ij-1,l) - pbarug(ij,l) + s - pbarvg(ij-iip1,l) + pbarvg(ij,l) + s + wg(ij,l+1) - wg(ij,l) + ENDDO + CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 ) + DO ij = iip2,ip1jm + zdp(ij)= zdp(ij)*dtvr/ massem(ij,l) + ENDDO + + + CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax ) + + IF(MAX(ABS(zdpmin),ABS(zdpmax)).GT.0.5) THEN + PRINT*,'WARNING DP/P l=',l,' MIN:',zdpmin, + s ' MAX:', zdpmax + ENDIF + + ENDDO + + +c------------------------------------------------------------------- +! Calcul des criteres CFL en X, Y et Z +c------------------------------------------------------------------- + + if (countcfl == 0. ) then + cflxmax(:)=0. + cflymax(:)=0. + cflzmax(:)=0. + endif + + countcfl=countcfl+iapp_tracvl + cflx(:,:)=0. + cfly(:,:)=0. + cflz(:,:)=0. + do l=1,llm + do ij=iip2,ip1jm-1 + if (pbarug(ij,l)>=0.) then + cflx(ij,l)=pbarug(ij,l)*dtvr/masse(ij,l) + else + cflx(ij,l)=-pbarug(ij,l)*dtvr/masse(ij+1,l) + endif + enddo + enddo + do l=1,llm + do ij=iip2,ip1jm-1,iip1 + cflx(ij+iip1,l)=cflx(ij,l) + enddo + enddo + + do l=1,llm + do ij=1,ip1jm + if (pbarvg(ij,l)>=0.) then + cfly(ij,l)=pbarvg(ij,l)*dtvr/masse(ij,l) + else + cfly(ij,l)=-pbarvg(ij,l)*dtvr/masse(ij+iip1,l) + endif + enddo + enddo + + do l=2,llm + do ij=1,ip1jm + if (wg(ij,l)>=0.) then + cflz(ij,l)=wg(ij,l)*dtvr/masse(ij,l) + else + cflz(ij,l)=-wg(ij,l)*dtvr/masse(ij,l-1) + endif + enddo + enddo + + do l=1,llm + cflxmax(l)=max(cflxmax(l),maxval(cflx(:,l))) + cflymax(l)=max(cflymax(l),maxval(cfly(:,l))) + cflzmax(l)=max(cflzmax(l),maxval(cflz(:,l))) + enddo + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Par defaut, on sort le diagnostic des CFL tous les jours. +! Si on veut le sortir a chaque pas d'advection en cas de plantage +! if (countcfl==iapp_tracvl) then +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (countcfl==day_step) then + do l=1,llm + write(lunout,*) 'L, CFLmax ' + s ,l,maxval(cflx(:,l)),maxval(cfly(:,l)),maxval(cflz(:,l)) + enddo + countcfl=0 + endif + +c------------------------------------------------------------------- +c Advection proprement dite (Modification Le Croller (07/2001) +c------------------------------------------------------------------- + +c---------------------------------------------------- +c Calcul des moyennes basées sur la masse +c---------------------------------------------------- + call massbar(massem,massebx,masseby) + +c----------------------------------------------------------- +c Appel des sous programmes d'advection +c----------------------------------------------------------- + do iq=1,nqtot +c call clock(t_initial) + if(iadv(iq) == 0) cycle +c ---------------------------------------------------------------- +c Schema de Van Leer I MUSCL +c ---------------------------------------------------------------- + if(iadv(iq).eq.10) THEN + call vlsplt(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr) + + +c ---------------------------------------------------------------- +c Schema "pseudo amont" + test sur humidite specifique +C pour la vapeur d'eau. F. Codron +c ---------------------------------------------------------------- + else if(iadv(iq).eq.14) then +c + CALL vlspltqs( q(1,1,1), 2., massem, wg , + * pbarug,pbarvg,dtvr,p,pk,teta ) +c ---------------------------------------------------------------- +c Schema de Frederic Hourdin +c ---------------------------------------------------------------- + else if(iadv(iq).eq.12) then +c Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', + s dtvr,'n=',n + endif + do indice=1,n + call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1) + end do + else if(iadv(iq).eq.13) then +c Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', + s dtvr,'n=',n + endif + do indice=1,n + call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2) + end do +c ---------------------------------------------------------------- +c Schema de pente SLOPES +c ---------------------------------------------------------------- + else if (iadv(iq).eq.20) then + call pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0) + +c ---------------------------------------------------------------- +c Schema de Prather +c ---------------------------------------------------------------- + else if (iadv(iq).eq.30) then +c Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', + s dtvr,'n=',n + endif + call prather(q(1,1,iq),wg,massem,pbarug,pbarvg, + s n,dtbon) + +c ---------------------------------------------------------------- +c Schemas PPM Lin et Rood +c ---------------------------------------------------------------- + else if (iadv(iq).eq.11.OR.(iadv(iq).GE.16.AND. + s iadv(iq).LE.18)) then + +c Test sur le flux horizontal +c Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', + s dtvr,'n=',n + endif +c Test sur le flux vertical + CFLmaxz=0. + do l=2,llm + do ij=iip2,ip1jm + aaa=wg(ij,l)*dtvr/massem(ij,l) + CFLmaxz=max(CFLmaxz,aaa) + bbb=-wg(ij,l)*dtvr/massem(ij,l-1) + CFLmaxz=max(CFLmaxz,bbb) + enddo + enddo + if (CFLmaxz.GE.1) then + write(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz + endif + +c----------------------------------------------------------- +c Ss-prg interface LMDZ.4->PPM3d +c----------------------------------------------------------- + + call interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem, + s apppm,bpppm,massebx,masseby,pbarug,pbarvg, + s unatppm,vnatppm,psppm) + + do indice=1,n +c--------------------------------------------------------------------- +c VL (version PPM) horiz. et PPM vert. +c--------------------------------------------------------------------- + if (iadv(iq).eq.11) then +c Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), + s psppm,psppm, + s unatppm,vnatppm,fluxwppm,dtbon,2,2,2,1, + s iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, + s fill,dum,220.) + +c---------------------------------------------------------------------- +c Monotonic PPM +c---------------------------------------------------------------------- + else if (iadv(iq).eq.16) then +c Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), + s psppm,psppm, + s unatppm,vnatppm,fluxwppm,dtbon,3,3,3,1, + s iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, + s fill,dum,220.) +c--------------------------------------------------------------------- + +c--------------------------------------------------------------------- +c Semi Monotonic PPM +c--------------------------------------------------------------------- + else if (iadv(iq).eq.17) then +c Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), + s psppm,psppm, + s unatppm,vnatppm,fluxwppm,dtbon,4,4,4,1, + s iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, + s fill,dum,220.) +c--------------------------------------------------------------------- + +c--------------------------------------------------------------------- +c Positive Definite PPM +c--------------------------------------------------------------------- + else if (iadv(iq).eq.18) then +c Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), + s psppm,psppm, + s unatppm,vnatppm,fluxwppm,dtbon,5,5,5,1, + s iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, + s fill,dum,220.) +c--------------------------------------------------------------------- + endif + enddo +c----------------------------------------------------------------- +c Ss-prg interface PPM3d-LMDZ.4 +c----------------------------------------------------------------- + call interpost(q(1,1,iq),qppm(1,1,iq)) + endif +c---------------------------------------------------------------------- + +c----------------------------------------------------------------- +c On impose une seule valeur du traceur au pôle Sud j=jjm+1=jjp1 +c et Nord j=1 +c----------------------------------------------------------------- + +c call traceurpole(q(1,1,iq),massem) + +c calcul du temps cpu pour un schema donne + +c call clock(t_final) +cym tps_cpu=t_final-t_initial +cym cpuadv(iq)=cpuadv(iq)+tps_cpu + + end DO + + +c------------------------------------------------------------------ +c on reinitialise a zero les flux de masse cumules +c--------------------------------------------------- + iadvtr=0 + + ENDIF ! if iadvtr.EQ.iapp_tracvl + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advx.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advx.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advx.F (revision 1280) @@ -0,0 +1,499 @@ +! +! $Header$ +! + SUBROUTINE advx(limit,dtx,pbaru,sm,s0, + $ sx,sy,sz,lati,latf) + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C first-order moments (FOM) advection of tracer in X direction C +C C +C Source : Pascal Simon (Meteo,CNRM) C +C Adaptation : A.Armengaud (LGGE) juin 94 C +C C +C limit,dtx,pbaru,pbarv,sm,s0,sx,sy,sz C +C sont des arguments d'entree pour le s-pg... C +C C +C sm,s0,sx,sy,sz C +C sont les arguments de sortie pour le s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" + +C Arguments : +C ----------- +C dtx : frequence fictive d'appel du transport +C pbaru, pbarv : flux de masse en x et y en Pa.m2.s-1 + + INTEGER ntra + PARAMETER (ntra = 1) + +C ATTENTION partout ou on trouve ntra, insertion de boucle +C possible dans l'avenir. + + REAL dtx + REAL pbaru ( iip1,jjp1,llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm),S0(iip1,jjp1,llm,ntra) + REAL sx(iip1,jjp1,llm,ntra) + $ ,sy(iip1,jjp1,llm,ntra) + REAL sz(iip1,jjp1,llm,ntra) + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL UGRI(iip1,jjp1,llm) + +C Rem : VGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en x uniquement ) +C +C Ti are the moments for the current latitude and level +C + REAL TM(iim) + REAL T0(iim,ntra),TX(iim,ntra) + REAL TY(iim,ntra),TZ(iim,ntra) + REAL TEMPTM ! just a temporary variable +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C + REAL FM(iim) + REAL F0(iim,ntra),FX(iim,ntra) + REAL FY(iim,ntra),FZ(iim,ntra) +C +C work arrays +C + REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim) +C + REAL SMNEW(iim),UEXT(iim) +C + REAL sqi,sqf + + LOGICAL LIMIT + INTEGER NUM(jjp1),LONK,NUMK + INTEGER lon,lati,latf,niv + INTEGER i,i2,i3,j,jv,l,k,itrac + + lon = iim + niv = llm + +C *** Test de passage d'arguments ****** + + +C ------------------------------------- + DO 300 j = 1,jjp1 + NUM(j) = 1 + 300 CONTINUE + sqi = 0. + sqf = 0. + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim +cIM 240305 sqi = sqi + S0(i,j,l,9) + sqi = sqi + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVX - ENTREE ---------' + PRINT*,'sqi=',sqi + + +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C --------------------------------------------------------- +C Conversion des flux de masses en kg/s +C pbaru est en N/s d'ou : +C ugri est en kg/s + + DO 500 l = 1,llm + DO 500 j = 1,jjm+1 + DO 500 i = 1,iip1 +C ugri (i,j,llm+1-l) = pbaru (i,j,l) * ( dsig(l) / g ) + ugri (i,j,llm+1-l) = pbaru (i,j,l) + 500 CONTINUE + + +C --------------------------------------------------------- +C --------------------------------------------------------- +C --------------------------------------------------------- + +C start here +C +C boucle principale sur les niveaux et les latitudes +C + DO 1 L=1,NIV + DO 1 K=lati,latf +C +C initialisation +C +C program assumes periodic boundaries in X +C + DO 10 I=2,LON + SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX + 10 CONTINUE + SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX +C +C modifications for extended polar zones +C + NUMK=NUM(K) + LONK=LON/NUMK +C + IF(NUMK.GT.1) THEN +C + DO 111 I=1,LON + TM(I)=0. + 111 CONTINUE + DO 112 JV=1,NTRA + DO 1120 I=1,LON + T0(I,JV)=0. + TX(I,JV)=0. + TY(I,JV)=0. + TZ(I,JV)=0. + 1120 CONTINUE + 112 CONTINUE +C + DO 11 I2=1,NUMK +C + DO 113 I=1,LONK + I3=(I-1)*NUMK+I2 + TM(I)=TM(I)+SM(I3,K,L) + ALF(I)=SM(I3,K,L)/TM(I) + ALF1(I)=1.-ALF(I) + 113 CONTINUE +C + DO JV=1,NTRA + DO I=1,LONK + I3=(I-1)*NUMK+I2 + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I) + $ *S0(I3,K,L,JV) + T0(I,JV)=T0(I,JV)+S0(I3,K,L,JV) + TX(I,JV)=ALF(I) *sx(I3,K,L,JV)+ + $ ALF1(I)*TX(I,JV) +3.*TEMPTM + TY(I,JV)=TY(I,JV)+sy(I3,K,L,JV) + TZ(I,JV)=TZ(I,JV)+sz(I3,K,L,JV) + ENDDO + ENDDO +C + 11 CONTINUE +C + ELSE +C + DO 115 I=1,LON + TM(I)=SM(I,K,L) + 115 CONTINUE + DO 116 JV=1,NTRA + DO 1160 I=1,LON + T0(I,JV)=S0(I,K,L,JV) + TX(I,JV)=sx(I,K,L,JV) + TY(I,JV)=sy(I,K,L,JV) + TZ(I,JV)=sz(I,K,L,JV) + 1160 CONTINUE + 116 CONTINUE +C + ENDIF +C + DO 117 I=1,LONK + UEXT(I)=UGRI(I*NUMK,K,L) + 117 CONTINUE +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 13 +C + DO 12 JV=1,NTRA + DO 120 I=1,LONK + TX(I,JV)=SIGN(AMIN1(AMAX1(T0(I,JV),0.),ABS(TX(I,JV))),TX(I,JV)) + 120 CONTINUE + 12 CONTINUE +C + 13 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from IP to I if U(I).lt.0 +C + DO 140 I=1,LONK-1 + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(I+1) + TM(I+1)=TM(I+1)-FM(I) + ENDIF + 140 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(1) + TM(1)=TM(1)-FM(I) + ENDIF +C +C flux from I to IP if U(I).gt.0 +C + DO 141 I=1,LONK + IF(UEXT(I).GE.0.) THEN + FM(I)=UEXT(I)*DTX + ALF(I)=FM(I)/TM(I) + TM(I)=TM(I)-FM(I) + ENDIF + 141 CONTINUE +C + DO 142 I=1,LONK + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + 142 CONTINUE +C + DO 150 JV=1,NTRA + DO 1500 I=1,LONK-1 +C + IF(UEXT(I).LT.0.) THEN +C + F0(I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)*TX(I+1,JV) ) + FX(I,JV)=ALFQ(I)*TX(I+1,JV) + FY(I,JV)=ALF (I)*TY(I+1,JV) + FZ(I,JV)=ALF (I)*TZ(I+1,JV) +C + T0(I+1,JV)=T0(I+1,JV)-F0(I,JV) + TX(I+1,JV)=ALF1Q(I)*TX(I+1,JV) + TY(I+1,JV)=TY(I+1,JV)-FY(I,JV) + TZ(I+1,JV)=TZ(I+1,JV)-FZ(I,JV) +C + ENDIF +C + 1500 CONTINUE + 150 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN +C + DO 151 JV=1,NTRA +C + F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)*TX(1,JV) ) + FX (I,JV)=ALFQ(I)*TX(1,JV) + FY (I,JV)=ALF (I)*TY(1,JV) + FZ (I,JV)=ALF (I)*TZ(1,JV) +C + T0(1,JV)=T0(1,JV)-F0(I,JV) + TX(1,JV)=ALF1Q(I)*TX(1,JV) + TY(1,JV)=TY(1,JV)-FY(I,JV) + TZ(1,JV)=TZ(1,JV)-FZ(I,JV) +C + 151 CONTINUE +C + ENDIF +C + DO 152 JV=1,NTRA + DO 1520 I=1,LONK +C + IF(UEXT(I).GE.0.) THEN +C + F0(I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)*TX(I,JV) ) + FX(I,JV)=ALFQ(I)*TX(I,JV) + FY(I,JV)=ALF (I)*TY(I,JV) + FZ(I,JV)=ALF (I)*TZ(I,JV) +C + T0(I,JV)=T0(I,JV)-F0(I,JV) + TX(I,JV)=ALF1Q(I)*TX(I,JV) + TY(I,JV)=TY(I,JV)-FY(I,JV) + TZ(I,JV)=TZ(I,JV)-FZ(I,JV) +C + ENDIF +C + 1520 CONTINUE + 152 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 160 I=1,LONK + IF(UEXT(I).LT.0.) THEN + TM(I)=TM(I)+FM(I) + ALF(I)=FM(I)/TM(I) + ENDIF + 160 CONTINUE +C + DO 161 I=1,LONK-1 + IF(UEXT(I).GE.0.) THEN + TM(I+1)=TM(I+1)+FM(I) + ALF(I)=FM(I)/TM(I+1) + ENDIF + 161 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + TM(1)=TM(1)+FM(I) + ALF(I)=FM(I)/TM(1) + ENDIF +C + DO 162 I=1,LONK + ALF1(I)=1.-ALF(I) + 162 CONTINUE +C + DO 170 JV=1,NTRA + DO 1700 I=1,LONK +C + IF(UEXT(I).LT.0.) THEN +C + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV) + T0(I,JV)=T0(I,JV)+F0(I,JV) + TX(I,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM + TY(I,JV)=TY(I,JV)+FY(I,JV) + TZ(I,JV)=TZ(I,JV)+FZ(I,JV) +C + ENDIF +C + 1700 CONTINUE + 170 CONTINUE +C + DO 171 JV=1,NTRA + DO 1710 I=1,LONK-1 +C + IF(UEXT(I).GE.0.) THEN +C + TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV) + T0(I+1,JV)=T0(I+1,JV)+F0(I,JV) + TX(I+1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I+1,JV)+3.*TEMPTM + TY(I+1,JV)=TY(I+1,JV)+FY(I,JV) + TZ(I+1,JV)=TZ(I+1,JV)+FZ(I,JV) +C + ENDIF +C + 1710 CONTINUE + 171 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + DO 172 JV=1,NTRA + TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV) + T0(1,JV)=T0(1,JV)+F0(I,JV) + TX(1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM + TY(1,JV)=TY(1,JV)+FY(I,JV) + TZ(1,JV)=TZ(1,JV)+FZ(I,JV) + 172 CONTINUE + ENDIF +C +C retour aux mailles d'origine (passage des Tij aux Sij) +C + IF(NUMK.GT.1) THEN +C + DO 180 I2=1,NUMK +C + DO 180 I=1,LONK +C + I3=I2+(I-1)*NUMK + SM(I3,K,L)=SMNEW(I3) + ALF(I)=SMNEW(I3)/TM(I) + TM(I)=TM(I)-SMNEW(I3) +C + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) +C + 180 CONTINUE +C + DO JV=1,NTRA + DO I=1,LONK +C + I3=I2+(I-1)*NUMK + S0(I3,K,L,JV)=ALF (I) + $ * (T0(I,JV)-ALF1(I)*TX(I,JV)) + sx(I3,K,L,JV)=ALFQ(I)*TX(I,JV) + sy(I3,K,L,JV)=ALF (I)*TY(I,JV) + sz(I3,K,L,JV)=ALF (I)*TZ(I,JV) +C +C reajusts moments remaining in the box +C + T0(I,JV)=T0(I,JV)-S0(I3,K,L,JV) + TX(I,JV)=ALF1Q(I)*TX(I,JV) + TY(I,JV)=TY(I,JV)-sy(I3,K,L,JV) + TZ(I,JV)=TZ(I,JV)-sz(I3,K,L,JV) + ENDDO + ENDDO +C +C + ELSE +C + DO 190 I=1,LON + SM(I,K,L)=TM(I) + 190 CONTINUE + DO 191 JV=1,NTRA + DO 1910 I=1,LON + S0(I,K,L,JV)=T0(I,JV) + sx(I,K,L,JV)=TX(I,JV) + sy(I,K,L,JV)=TY(I,JV) + sz(I,K,L,JV)=TZ(I,JV) + 1910 CONTINUE + 191 CONTINUE +C + ENDIF +C + 1 CONTINUE +C +C ----------- AA Test en fin de ADVX ------ Controle des S* +c OK +c DO 9998 l = 1, llm +c DO 9998 j = 1, jjp1 +c DO 9998 i = 1, iip1 +c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN +c PRINT*, '-------------------' +c PRINT*, 'En fin de ADVX' +c PRINT*,'SM(',i,j,l,')=',SM(i,j,l) +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra) +c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra) +c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra) +c WRITE (*,*) 'On arrete !! - pbl en fin de ADVX1' +cc STOP +c ENDIF +c 9998 CONTINUE +c +C ---------- bouclage cyclique + DO itrac=1,ntra + DO l = 1,llm + DO j = lati,latf + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,itrac) = S0(1,j,l,itrac) + sx(iip1,j,l,itrac) = sx(1,j,l,itrac) + sy(iip1,j,l,itrac) = sy(1,j,l,itrac) + sz(iip1,j,l,itrac) = sz(1,j,l,itrac) + END DO + END DO + ENDDO + +c ----------- qqtite totale de traceur dans tte l'atmosphere + DO l = 1, llm + DO j = 1, jjp1 + DO i = 1, iim +cIM 240405 sqf = sqf + S0(i,j,l,9) + sqf = sqf + S0(i,j,l,ntra) + END DO + END DO + END DO +c + PRINT*,'------ DIAG DANS ADVX - SORTIE -----' + PRINT*,'sqf=',sqf +c------------- + + RETURN + END +C_________________________________________________________________ +C_________________________________________________________________ Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advxp.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advxp.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advxp.F (revision 1280) @@ -0,0 +1,650 @@ +! +! $Header$ +! + SUBROUTINE ADVXP(LIMIT,DTX,PBARU,SM,S0,SSX,SY,SZ + . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra) + IMPLICIT NONE +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C second-order moments (SOM) advection of tracer in X direction C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" + + INTEGER ntra +c PARAMETER (ntra = 1) +C +C definition de la grille du modele +C + REAL dtx + REAL pbaru ( iip1,jjp1,llm ) +C +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C Sij 2nd order moment in i and j directions +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL SSX(iip1,jjp1,llm,ntra) + + ,SY(iip1,jjp1,llm,ntra) + + ,SZ(iip1,jjp1,llm,ntra) + REAL SSXX(iip1,jjp1,llm,ntra) + + ,SSXY(iip1,jjp1,llm,ntra) + + ,SSXZ(iip1,jjp1,llm,ntra) + + ,SYY(iip1,jjp1,llm,ntra) + + ,SYZ(iip1,jjp1,llm,ntra) + + ,SZZ(iip1,jjp1,llm,ntra) + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL UGRI(iip1,jjp1,llm) + +C Rem : VGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en x uniquement ) +C +C +C Tij are the moments for the current latitude and level +C + REAL TM (iim) + REAL T0 (iim,NTRA),TX (iim,NTRA) + REAL TY (iim,NTRA),TZ (iim,NTRA) + REAL TXX(iim,NTRA),TXY(iim,NTRA) + REAL TXZ(iim,NTRA),TYY(iim,NTRA) + REAL TYZ(iim,NTRA),TZZ(iim,NTRA) +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C + REAL FM (iim) + REAL F0 (iim,NTRA),FX (iim,NTRA) + REAL FY (iim,NTRA),FZ (iim,NTRA) + REAL FXX(iim,NTRA),FXY(iim,NTRA) + REAL FXZ(iim,NTRA),FYY(iim,NTRA) + REAL FYZ(iim,NTRA),FZZ(iim,NTRA) +C +C work arrays +C + REAL ALF (iim),ALF1(iim),ALFQ(iim),ALF1Q(iim) + REAL ALF2(iim),ALF3(iim),ALF4(iim) +C + REAL SMNEW(iim),UEXT(iim) + REAL sqi,sqf + REAL TEMPTM + REAL SLPMAX + REAL S1MAX,S1NEW,S2NEW + + LOGICAL LIMIT + INTEGER NUM(jjp1),LONK,NUMK + INTEGER lon,lati,latf,niv + INTEGER i,i2,i3,j,jv,l,k,iter + + lon = iim + lati=2 + latf = jjm + niv = llm + +C *** Test de passage d'arguments ****** + +c DO 399 l = 1, llm +c DO 399 j = 1, jjp1 +c DO 399 i = 1, iip1 +c IF (S0(i,j,l,ntra) .lt. 0. ) THEN +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra) +c print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra) +c print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra) +c PRINT*, 'AIE !! debut ADVXP - pbl arg. passage dans ADVXP' +cc STOP +c ENDIF +c 399 CONTINUE + +C *** Test : diagnostique de la qtite totale de traceur +C dans l'atmosphere avant l'advection +c + sqi =0. + sqf =0. +c + DO l = 1, llm + DO j = 1, jjp1 + DO i = 1, iim + sqi = sqi + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'------ DIAG DANS ADVX2 - ENTREE -----' + PRINT*,'sqi=',sqi +c test +c ------------------------------------- + DO 300 j =1,jjp1 + NUM(j) =1 + 300 CONTINUE +c DO l=1,llm +c NUM(2,l)=6 +c NUM(3,l)=6 +c NUM(jjm-1,l)=6 +c NUM(jjm,l)=6 +c ENDDO +c DO j=2,6 +c NUM(j)=12 +c ENDDO +c DO j=jjm-5,jjm-1 +c NUM(j)=12 +c ENDDO + +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C --------------------------------------------------------- +C Conversion des flux de masses en kg/s +C pbaru est en N/s d'ou : +C ugri est en kg/s + + DO 500 l = 1,llm + DO 500 j = 1,jjp1 + DO 500 i = 1,iip1 + ugri (i,j,llm+1-l) =pbaru (i,j,l) + 500 CONTINUE + +C --------------------------------------------------------- +C start here +C +C boucle principale sur les niveaux et les latitudes +C + DO 1 L=1,NIV + DO 1 K=lati,latf + +C +C initialisation +C +C program assumes periodic boundaries in X +C + DO 10 I=2,LON + SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX + 10 CONTINUE + SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX +C +C modifications for extended polar zones +C + NUMK=NUM(K) + LONK=LON/NUMK +C + IF(NUMK.GT.1) THEN +C + DO 111 I=1,LON + TM(I)=0. + 111 CONTINUE + DO 112 JV=1,NTRA + DO 1120 I=1,LON + T0 (I,JV)=0. + TX (I,JV)=0. + TY (I,JV)=0. + TZ (I,JV)=0. + TXX(I,JV)=0. + TXY(I,JV)=0. + TXZ(I,JV)=0. + TYY(I,JV)=0. + TYZ(I,JV)=0. + TZZ(I,JV)=0. + 1120 CONTINUE + 112 CONTINUE +C + DO 11 I2=1,NUMK +C + DO 113 I=1,LONK + I3=(I-1)*NUMK+I2 + TM(I)=TM(I)+SM(I3,K,L) + ALF(I)=SM(I3,K,L)/TM(I) + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALF1(I) + 113 CONTINUE +C + DO 114 JV=1,NTRA + DO 1140 I=1,LONK + I3=(I-1)*NUMK+I2 + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*S0(I3,K,L,JV) + T0 (I,JV)=T0(I,JV)+S0(I3,K,L,JV) + TXX(I,JV)=ALFQ(I)*SSXX(I3,K,L,JV)+ALF1Q(I)*TXX(I,JV) + + +5.*( ALF3(I)*(SSX(I3,K,L,JV)-TX(I,JV))+ALF2(I)*TEMPTM ) + TX (I,JV)=ALF(I)*SSX(I3,K,L,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM + TXY(I,JV)=ALF (I)*SSXY(I3,K,L,JV)+ALF1(I)*TXY(I,JV) + + +3.*(ALF1(I)*SY (I3,K,L,JV)-ALF (I)*TY (I,JV)) + TXZ(I,JV)=ALF (I)*SSXZ(I3,K,L,JV)+ALF1(I)*TXZ(I,JV) + + +3.*(ALF1(I)*SZ (I3,K,L,JV)-ALF (I)*TZ (I,JV)) + TY (I,JV)=TY (I,JV)+SY (I3,K,L,JV) + TZ (I,JV)=TZ (I,JV)+SZ (I3,K,L,JV) + TYY(I,JV)=TYY(I,JV)+SYY(I3,K,L,JV) + TYZ(I,JV)=TYZ(I,JV)+SYZ(I3,K,L,JV) + TZZ(I,JV)=TZZ(I,JV)+SZZ(I3,K,L,JV) + 1140 CONTINUE + 114 CONTINUE +C + 11 CONTINUE +C + ELSE +C + DO 115 I=1,LON + TM(I)=SM(I,K,L) + 115 CONTINUE + DO 116 JV=1,NTRA + DO 1160 I=1,LON + T0 (I,JV)=S0 (I,K,L,JV) + TX (I,JV)=SSX (I,K,L,JV) + TY (I,JV)=SY (I,K,L,JV) + TZ (I,JV)=SZ (I,K,L,JV) + TXX(I,JV)=SSXX(I,K,L,JV) + TXY(I,JV)=SSXY(I,K,L,JV) + TXZ(I,JV)=SSXZ(I,K,L,JV) + TYY(I,JV)=SYY(I,K,L,JV) + TYZ(I,JV)=SYZ(I,K,L,JV) + TZZ(I,JV)=SZZ(I,K,L,JV) + 1160 CONTINUE + 116 CONTINUE +C + ENDIF +C + DO 117 I=1,LONK + UEXT(I)=UGRI(I*NUMK,K,L) + 117 CONTINUE +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 13 +C + DO 12 JV=1,NTRA + DO 120 I=1,LONK + IF(T0(I,JV).GT.0.) THEN + SLPMAX=T0(I,JV) + S1MAX=1.5*SLPMAX + S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,TX(I,JV))) + S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , + + AMAX1(ABS(S1NEW)-SLPMAX,TXX(I,JV)) ) + TX (I,JV)=S1NEW + TXX(I,JV)=S2NEW + TXY(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXY(I,JV))) + TXZ(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXZ(I,JV))) + ELSE + TX (I,JV)=0. + TXX(I,JV)=0. + TXY(I,JV)=0. + TXZ(I,JV)=0. + ENDIF + 120 CONTINUE + 12 CONTINUE +C + 13 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from IP to I if U(I).lt.0 +C + DO 140 I=1,LONK-1 + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(I+1) + TM(I+1)=TM(I+1)-FM(I) + ENDIF + 140 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(1) + TM(1)=TM(1)-FM(I) + ENDIF +C +C flux from I to IP if U(I).gt.0 +C + DO 141 I=1,LONK + IF(UEXT(I).GE.0.) THEN + FM(I)=UEXT(I)*DTX + ALF(I)=FM(I)/TM(I) + TM(I)=TM(I)-FM(I) + ENDIF + 141 CONTINUE +C + DO 142 I=1,LONK + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALFQ(I) + ALF4(I)=ALF1(I)*ALF1Q(I) + 142 CONTINUE +C + DO 150 JV=1,NTRA + DO 1500 I=1,LONK-1 +C + IF(UEXT(I).LT.0.) THEN +C + F0 (I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)* + + ( TX(I+1,JV)-ALF2(I)*TXX(I+1,JV) ) ) + FX (I,JV)=ALFQ(I)*(TX(I+1,JV)-3.*ALF1(I)*TXX(I+1,JV)) + FXX(I,JV)=ALF3(I)*TXX(I+1,JV) + FY (I,JV)=ALF (I)*(TY(I+1,JV)-ALF1(I)*TXY(I+1,JV)) + FZ (I,JV)=ALF (I)*(TZ(I+1,JV)-ALF1(I)*TXZ(I+1,JV)) + FXY(I,JV)=ALFQ(I)*TXY(I+1,JV) + FXZ(I,JV)=ALFQ(I)*TXZ(I+1,JV) + FYY(I,JV)=ALF (I)*TYY(I+1,JV) + FYZ(I,JV)=ALF (I)*TYZ(I+1,JV) + FZZ(I,JV)=ALF (I)*TZZ(I+1,JV) +C + T0 (I+1,JV)=T0(I+1,JV)-F0(I,JV) + TX (I+1,JV)=ALF1Q(I)*(TX(I+1,JV)+3.*ALF(I)*TXX(I+1,JV)) + TXX(I+1,JV)=ALF4(I)*TXX(I+1,JV) + TY (I+1,JV)=TY (I+1,JV)-FY (I,JV) + TZ (I+1,JV)=TZ (I+1,JV)-FZ (I,JV) + TYY(I+1,JV)=TYY(I+1,JV)-FYY(I,JV) + TYZ(I+1,JV)=TYZ(I+1,JV)-FYZ(I,JV) + TZZ(I+1,JV)=TZZ(I+1,JV)-FZZ(I,JV) + TXY(I+1,JV)=ALF1Q(I)*TXY(I+1,JV) + TXZ(I+1,JV)=ALF1Q(I)*TXZ(I+1,JV) +C + ENDIF +C + 1500 CONTINUE + 150 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN +C + DO 151 JV=1,NTRA +C + F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)* + + ( TX(1,JV)-ALF2(I)*TXX(1,JV) ) ) + FX (I,JV)=ALFQ(I)*(TX(1,JV)-3.*ALF1(I)*TXX(1,JV)) + FXX(I,JV)=ALF3(I)*TXX(1,JV) + FY (I,JV)=ALF (I)*(TY(1,JV)-ALF1(I)*TXY(1,JV)) + FZ (I,JV)=ALF (I)*(TZ(1,JV)-ALF1(I)*TXZ(1,JV)) + FXY(I,JV)=ALFQ(I)*TXY(1,JV) + FXZ(I,JV)=ALFQ(I)*TXZ(1,JV) + FYY(I,JV)=ALF (I)*TYY(1,JV) + FYZ(I,JV)=ALF (I)*TYZ(1,JV) + FZZ(I,JV)=ALF (I)*TZZ(1,JV) +C + T0 (1,JV)=T0(1,JV)-F0(I,JV) + TX (1,JV)=ALF1Q(I)*(TX(1,JV)+3.*ALF(I)*TXX(1,JV)) + TXX(1,JV)=ALF4(I)*TXX(1,JV) + TY (1,JV)=TY (1,JV)-FY (I,JV) + TZ (1,JV)=TZ (1,JV)-FZ (I,JV) + TYY(1,JV)=TYY(1,JV)-FYY(I,JV) + TYZ(1,JV)=TYZ(1,JV)-FYZ(I,JV) + TZZ(1,JV)=TZZ(1,JV)-FZZ(I,JV) + TXY(1,JV)=ALF1Q(I)*TXY(1,JV) + TXZ(1,JV)=ALF1Q(I)*TXZ(1,JV) +C + 151 CONTINUE +C + ENDIF +C + DO 152 JV=1,NTRA + DO 1520 I=1,LONK +C + IF(UEXT(I).GE.0.) THEN +C + F0 (I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)* + + ( TX(I,JV)+ALF2(I)*TXX(I,JV) ) ) + FX (I,JV)=ALFQ(I)*(TX(I,JV)+3.*ALF1(I)*TXX(I,JV)) + FXX(I,JV)=ALF3(I)*TXX(I,JV) + FY (I,JV)=ALF (I)*(TY(I,JV)+ALF1(I)*TXY(I,JV)) + FZ (I,JV)=ALF (I)*(TZ(I,JV)+ALF1(I)*TXZ(I,JV)) + FXY(I,JV)=ALFQ(I)*TXY(I,JV) + FXZ(I,JV)=ALFQ(I)*TXZ(I,JV) + FYY(I,JV)=ALF (I)*TYY(I,JV) + FYZ(I,JV)=ALF (I)*TYZ(I,JV) + FZZ(I,JV)=ALF (I)*TZZ(I,JV) +C + T0 (I,JV)=T0(I,JV)-F0(I,JV) + TX (I,JV)=ALF1Q(I)*(TX(I,JV)-3.*ALF(I)*TXX(I,JV)) + TXX(I,JV)=ALF4(I)*TXX(I,JV) + TY (I,JV)=TY (I,JV)-FY (I,JV) + TZ (I,JV)=TZ (I,JV)-FZ (I,JV) + TYY(I,JV)=TYY(I,JV)-FYY(I,JV) + TYZ(I,JV)=TYZ(I,JV)-FYZ(I,JV) + TZZ(I,JV)=TZZ(I,JV)-FZZ(I,JV) + TXY(I,JV)=ALF1Q(I)*TXY(I,JV) + TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV) +C + ENDIF +C + 1520 CONTINUE + 152 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 160 I=1,LONK + IF(UEXT(I).LT.0.) THEN + TM(I)=TM(I)+FM(I) + ALF(I)=FM(I)/TM(I) + ENDIF + 160 CONTINUE +C + DO 161 I=1,LONK-1 + IF(UEXT(I).GE.0.) THEN + TM(I+1)=TM(I+1)+FM(I) + ALF(I)=FM(I)/TM(I+1) + ENDIF + 161 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + TM(1)=TM(1)+FM(I) + ALF(I)=FM(I)/TM(1) + ENDIF +C + DO 162 I=1,LONK + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALF1(I) + 162 CONTINUE +C + DO 170 JV=1,NTRA + DO 1700 I=1,LONK +C + IF(UEXT(I).LT.0.) THEN +C + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV) + T0 (I,JV)=T0(I,JV)+F0(I,JV) + TXX(I,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I,JV) + + +5.*( ALF3(I)*(FX(I,JV)-TX(I,JV))+ALF2(I)*TEMPTM ) + TX (I,JV)=ALF (I)*FX (I,JV)+ALF1(I)*TX (I,JV)+3.*TEMPTM + TXY(I,JV)=ALF (I)*FXY(I,JV)+ALF1(I)*TXY(I,JV) + + +3.*(ALF1(I)*FY (I,JV)-ALF (I)*TY (I,JV)) + TXZ(I,JV)=ALF (I)*FXZ(I,JV)+ALF1(I)*TXZ(I,JV) + + +3.*(ALF1(I)*FZ (I,JV)-ALF (I)*TZ (I,JV)) + TY (I,JV)=TY (I,JV)+FY (I,JV) + TZ (I,JV)=TZ (I,JV)+FZ (I,JV) + TYY(I,JV)=TYY(I,JV)+FYY(I,JV) + TYZ(I,JV)=TYZ(I,JV)+FYZ(I,JV) + TZZ(I,JV)=TZZ(I,JV)+FZZ(I,JV) +C + ENDIF +C + 1700 CONTINUE + 170 CONTINUE +C + DO 171 JV=1,NTRA + DO 1710 I=1,LONK-1 +C + IF(UEXT(I).GE.0.) THEN +C + TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV) + T0 (I+1,JV)=T0(I+1,JV)+F0(I,JV) + TXX(I+1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I+1,JV) + + +5.*( ALF3(I)*(TX(I+1,JV)-FX(I,JV))-ALF2(I)*TEMPTM ) + TX (I+1,JV)=ALF(I)*FX (I ,JV)+ALF1(I)*TX (I+1,JV)+3.*TEMPTM + TXY(I+1,JV)=ALF(I)*FXY(I ,JV)+ALF1(I)*TXY(I+1,JV) + + +3.*(ALF(I)*TY (I+1,JV)-ALF1(I)*FY (I ,JV)) + TXZ(I+1,JV)=ALF(I)*FXZ(I ,JV)+ALF1(I)*TXZ(I+1,JV) + + +3.*(ALF(I)*TZ (I+1,JV)-ALF1(I)*FZ (I ,JV)) + TY (I+1,JV)=TY (I+1,JV)+FY (I,JV) + TZ (I+1,JV)=TZ (I+1,JV)+FZ (I,JV) + TYY(I+1,JV)=TYY(I+1,JV)+FYY(I,JV) + TYZ(I+1,JV)=TYZ(I+1,JV)+FYZ(I,JV) + TZZ(I+1,JV)=TZZ(I+1,JV)+FZZ(I,JV) +C + ENDIF +C + 1710 CONTINUE + 171 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + DO 172 JV=1,NTRA + TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV) + T0 (1,JV)=T0(1,JV)+F0(I,JV) + TXX(1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(1,JV) + + +5.*( ALF3(I)*(TX(1,JV)-FX(I,JV))-ALF2(I)*TEMPTM ) + TX (1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM + TXY(1,JV)=ALF(I)*FXY(I,JV)+ALF1(I)*TXY(1,JV) + + +3.*(ALF(I)*TY (1,JV)-ALF1(I)*FY (I,JV)) + TXZ(1,JV)=ALF(I)*FXZ(I,JV)+ALF1(I)*TXZ(1,JV) + + +3.*(ALF(I)*TZ (1,JV)-ALF1(I)*FZ (I,JV)) + TY (1,JV)=TY (1,JV)+FY (I,JV) + TZ (1,JV)=TZ (1,JV)+FZ (I,JV) + TYY(1,JV)=TYY(1,JV)+FYY(I,JV) + TYZ(1,JV)=TYZ(1,JV)+FYZ(I,JV) + TZZ(1,JV)=TZZ(1,JV)+FZZ(I,JV) + 172 CONTINUE + ENDIF +C +C retour aux mailles d'origine (passage des Tij aux Sij) +C + IF(NUMK.GT.1) THEN +C + DO 18 I2=1,NUMK +C + DO 180 I=1,LONK +C + I3=I2+(I-1)*NUMK + SM(I3,K,L)=SMNEW(I3) + ALF(I)=SMNEW(I3)/TM(I) + TM(I)=TM(I)-SMNEW(I3) +C + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALFQ(I) + ALF4(I)=ALF1(I)*ALF1Q(I) +C + 180 CONTINUE +C + DO 181 JV=1,NTRA + DO 181 I=1,LONK +C + I3=I2+(I-1)*NUMK + S0 (I3,K,L,JV)=ALF (I)* ( T0(I,JV)-ALF1(I)* + + ( TX(I,JV)-ALF2(I)*TXX(I,JV) ) ) + SSX (I3,K,L,JV)=ALFQ(I)*(TX(I,JV)-3.*ALF1(I)*TXX(I,JV)) + SSXX(I3,K,L,JV)=ALF3(I)*TXX(I,JV) + SY (I3,K,L,JV)=ALF (I)*(TY(I,JV)-ALF1(I)*TXY(I,JV)) + SZ (I3,K,L,JV)=ALF (I)*(TZ(I,JV)-ALF1(I)*TXZ(I,JV)) + SSXY(I3,K,L,JV)=ALFQ(I)*TXY(I,JV) + SSXZ(I3,K,L,JV)=ALFQ(I)*TXZ(I,JV) + SYY(I3,K,L,JV)=ALF (I)*TYY(I,JV) + SYZ(I3,K,L,JV)=ALF (I)*TYZ(I,JV) + SZZ(I3,K,L,JV)=ALF (I)*TZZ(I,JV) +C +C reajusts moments remaining in the box +C + T0 (I,JV)=T0(I,JV)-S0(I3,K,L,JV) + TX (I,JV)=ALF1Q(I)*(TX(I,JV)+3.*ALF(I)*TXX(I,JV)) + TXX(I,JV)=ALF4 (I)*TXX(I,JV) + TY (I,JV)=TY (I,JV)-SY (I3,K,L,JV) + TZ (I,JV)=TZ (I,JV)-SZ (I3,K,L,JV) + TYY(I,JV)=TYY(I,JV)-SYY(I3,K,L,JV) + TYZ(I,JV)=TYZ(I,JV)-SYZ(I3,K,L,JV) + TZZ(I,JV)=TZZ(I,JV)-SZZ(I3,K,L,JV) + TXY(I,JV)=ALF1Q(I)*TXY(I,JV) + TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV) +C + 181 CONTINUE +C + 18 CONTINUE +C + ELSE +C + DO 190 I=1,LON + SM(I,K,L)=TM(I) + 190 CONTINUE + DO 191 JV=1,NTRA + DO 1910 I=1,LON + S0 (I,K,L,JV)=T0 (I,JV) + SSX (I,K,L,JV)=TX (I,JV) + SY (I,K,L,JV)=TY (I,JV) + SZ (I,K,L,JV)=TZ (I,JV) + SSXX(I,K,L,JV)=TXX(I,JV) + SSXY(I,K,L,JV)=TXY(I,JV) + SSXZ(I,K,L,JV)=TXZ(I,JV) + SYY(I,K,L,JV)=TYY(I,JV) + SYZ(I,K,L,JV)=TYZ(I,JV) + SZZ(I,K,L,JV)=TZZ(I,JV) + 1910 CONTINUE + 191 CONTINUE +C + ENDIF +C + 1 CONTINUE +C +C ----------- AA Test en fin de ADVX ------ Controle des S* + +c DO 9999 l = 1, llm +c DO 9999 j = 1, jjp1 +c DO 9999 i = 1, iip1 +c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN +c PRINT*, '-------------------' +c PRINT*, 'En fin de ADVXP' +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra) +c print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra) +c print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra) +c WRITE (*,*) 'On arrete !! - pbl en fin de ADVXP' +c STOP +c ENDIF +c 9999 CONTINUE +c ---------- bouclage cyclique + + DO l = 1,llm + DO j = 1,jjp1 + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,ntra) = S0(1,j,l,ntra) + SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra) + SY(iip1,j,l,ntra) = SY(1,j,l,ntra) + SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra) + END DO + END DO + +C ----------- qqtite totale de traceur dans tte l'atmosphere + DO l = 1, llm + DO j = 1, jjp1 + DO i = 1, iim + sqf = sqf + S0(i,j,l,ntra) + END DO + END DO + END DO + + PRINT*,'------ DIAG DANS ADVX2 - SORTIE -----' + PRINT*,'sqf=',sqf +c------------------------------------------------------------- + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advy.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advy.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advy.F (revision 1280) @@ -0,0 +1,422 @@ +! +! $Header$ +! + SUBROUTINE advy(limit,dty,pbarv,sm,s0,sx,sy,sz) + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C first-order moments (SOM) advection of tracer in Y direction C +C C +C Source : Pascal Simon ( Meteo, CNRM ) C +C Adaptation : A.A. (LGGE) C +C Derniere Modif : 15/12/94 LAST +C C +C sont les arguments d'entree pour le s-pg C +C C +C argument de sortie du s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Rem : Probleme aux poles il faut reecrire ce cas specifique +C Attention au sens de l'indexation +C +C parametres principaux du modele +C +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +C Arguments : +C ---------- +C dty : frequence fictive d'appel du transport +C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 + + INTEGER lon,lat,niv + INTEGER i,j,jv,k,kp,l + INTEGER ntra + PARAMETER (ntra = 1) + + REAL dty + REAL pbarv ( iip1,jjm, llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL sx(iip1,jjp1,llm,ntra) + + ,sy(iip1,jjp1,llm,ntra) + + ,sz(iip1,jjp1,llm,ntra) + + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL VGRI(iip1,0:jjp1,llm) + +C Rem : UGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en y uniquement ) +C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C + REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1) + REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra) + REAL FZ(iim,jjm,ntra) + REAL S00(ntra) + REAL SM0 ! Just temporal variable +C +C work arrays +C + REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1) + REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1) + REAL TEMPTM ! Just temporal variable +c +C Special pour poles +c + REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn + REAL sns0(ntra),snsz(ntra),snsm + REAL s1v(llm),slatv(llm) + REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra) + REAL cx1(llm,ntra), cxLAT(llm,ntra) + REAL cy1(llm,ntra), cyLAT(llm,ntra) + REAL z1(iim), zcos(iim), zsin(iim) + real smpn,smps,s0pn,s0ps + REAL SSUM + EXTERNAL SSUM +C + REAL sqi,sqf + LOGICAL LIMIT + + lon = iim ! rem : Il est possible qu'un pbl. arrive ici + lat = jjp1 ! a cause des dim. differentes entre les + niv=llm + +C +C the moments Fi are used as temporary storage for +C portions of the grid boxes in transit at the current level +C +C work arrays +C + + DO l = 1,llm + DO j = 1,jjm + DO i = 1,iip1 + vgri (i,j,llm+1-l)=-1.*pbarv(i,j,l) + enddo + enddo + do i=1,iip1 + vgri(i,0,l) = 0. + vgri(i,jjp1,l) = 0. + enddo + enddo + + DO 1 L=1,NIV +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 11 +C + DO 10 JV=1,NTRA + DO 10 K=1,LAT + DO 100 I=1,LON + sy(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.), + + ABS(sy(I,K,L,JV))),sy(I,K,L,JV)) + 100 CONTINUE + 10 CONTINUE +C + 11 CONTINUE +C +C le flux a travers le pole Nord est traite separement +C + SM0=0. + DO 20 JV=1,NTRA + S00(JV)=0. + 20 CONTINUE +C + DO 21 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN + FM(I,0)=-VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM(I,1,L) + SM(I,1,L)=SM(I,1,L)-FM(I,0) + SM0=SM0+FM(I,0) + ENDIF +C + ALFQ(I,0)=ALF(I,0)*ALF(I,0) + ALF1(I,0)=1.-ALF(I,0) + ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) +C + 21 CONTINUE +C + DO 22 JV=1,NTRA + DO 220 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN +C + F0(I,0,JV)=ALF(I,0)* + + ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) ) +C + S00(JV)=S00(JV)+F0(I,0,JV) + S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV) + sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV) + sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV) + sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV) +C + ENDIF +C + 220 CONTINUE + 22 CONTINUE +C + DO 23 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + FM(I,0)=VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM0 + ENDIF + 23 CONTINUE +C + DO 24 JV=1,NTRA + DO 240 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + F0(I,0,JV)=ALF(I,0)*S00(JV) + ENDIF + 240 CONTINUE + 24 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 25 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN + SM(I,1,L)=SM(I,1,L)+FM(I,0) + ALF(I,0)=FM(I,0)/SM(I,1,L) + ENDIF +C + ALF1(I,0)=1.-ALF(I,0) +C + 25 CONTINUE +C + DO 26 JV=1,NTRA + DO 260 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN +C + TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV) + S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV) + sy(I,1,L,JV)=ALF1(I,0)*sy(I,1,L,JV)+3.*TEMPTM +C + ENDIF +C + 260 CONTINUE + 26 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0 +C + DO 30 K=1,LAT-1 + KP=K+1 + DO 300 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,KP,L) + SM(I,KP,L)=SM(I,KP,L)-FM(I,K) + ELSE + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) +C + 300 CONTINUE + 30 CONTINUE +C + DO 31 JV=1,NTRA + DO 31 K=1,LAT-1 + KP=K+1 + DO 310 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + F0(I,K,JV)=ALF (I,K)* + + ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) ) + FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV) + FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV) + FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV) +C + S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV) + sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV) + sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV) + sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV) +C + ELSE +C + F0(I,K,JV)=ALF (I,K)* + + ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) ) + FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV) + FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV) + FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV) +C + S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV) + sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV) + sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV) + sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV) +C + ENDIF +C + 310 CONTINUE + 31 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 32 K=1,LAT-1 + KP=K+1 + DO 320 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ELSE + SM(I,KP,L)=SM(I,KP,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,KP,L) + ENDIF +C + ALF1(I,K)=1.-ALF(I,K) +C + 320 CONTINUE + 32 CONTINUE +C + DO 33 JV=1,NTRA + DO 33 K=1,LAT-1 + KP=K+1 + DO 330 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + sy(I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,K,L,JV) + + +3.*TEMPTM + sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,K,JV) + sz(I,K,L,JV)=sz(I,K,L,JV)+FZ(I,K,JV) +C + ELSE +C + TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV) + S0(I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV) + sy(I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,KP,L,JV) + + +3.*TEMPTM + sx(I,KP,L,JV)=sx(I,KP,L,JV)+FX(I,K,JV) + sz(I,KP,L,JV)=sz(I,KP,L,JV)+FZ(I,K,JV) +C + ENDIF +C + 330 CONTINUE + 33 CONTINUE +C +C traitement special pour le pole Sud (idem pole Nord) +C + K=LAT +C + SM0=0. + DO 40 JV=1,NTRA + S00(JV)=0. + 40 CONTINUE +C + DO 41 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + SM0=SM0+FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) +C + 41 CONTINUE +C + DO 42 JV=1,NTRA + DO 420 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + F0 (I,K,JV)=ALF(I,K)* + + ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) ) + S00(JV)=S00(JV)+F0(I,K,JV) +C + S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) + sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV) + sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV) + sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV) + ENDIF +C + 420 CONTINUE + 42 CONTINUE +C + DO 43 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM0 + ENDIF + 43 CONTINUE +C + DO 44 JV=1,NTRA + DO 440 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + F0(I,K,JV)=ALF(I,K)*S00(JV) + ENDIF + 440 CONTINUE + 44 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 45 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ENDIF +C + ALF1(I,K)=1.-ALF(I,K) +C + 45 CONTINUE +C + DO 46 JV=1,NTRA + DO 460 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + sy(I,K,L,JV)=ALF1(I,K)*sy(I,K,L,JV)+3.*TEMPTM +C + ENDIF +C + 460 CONTINUE + 46 CONTINUE +C + 1 CONTINUE +C + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advyp.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advyp.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advyp.F (revision 1280) @@ -0,0 +1,653 @@ +! +! $Header$ +! + SUBROUTINE ADVYP(LIMIT,DTY,PBARV,SM,S0,SSX,SY,SZ + . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra ) + IMPLICIT NONE +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C second-order moments (SOM) advection of tracer in Y direction C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Source : Pascal Simon ( Meteo, CNRM ) C +C Adaptation : A.A. (LGGE) C +C Derniere Modif : 19/10/95 LAST +C C +C sont les arguments d'entree pour le s-pg C +C C +C argument de sortie du s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Rem : Probleme aux poles il faut reecrire ce cas specifique +C Attention au sens de l'indexation +C +C parametres principaux du modele +C +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" + +C Arguments : +C ---------- +C dty : frequence fictive d'appel du transport +C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 + + INTEGER lon,lat,niv + INTEGER i,j,jv,k,kp,l + INTEGER ntra +C PARAMETER (ntra = 1) + + REAL dty + REAL pbarv ( iip1,jjm, llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL SSX(iip1,jjp1,llm,ntra) + + ,SY(iip1,jjp1,llm,ntra) + + ,SZ(iip1,jjp1,llm,ntra) + + ,SSXX(iip1,jjp1,llm,ntra) + + ,SSXY(iip1,jjp1,llm,ntra) + + ,SSXZ(iip1,jjp1,llm,ntra) + + ,SYY(iip1,jjp1,llm,ntra) + + ,SYZ(iip1,jjp1,llm,ntra) + + ,SZZ(iip1,jjp1,llm,ntra) +C +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL VGRI(iip1,0:jjp1,llm) + +C Rem : UGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en y uniquement ) +C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C +C the moments Fij are used as temporary storage for +C portions of the grid boxes in transit at the current level +C +C work arrays +C +C + REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1) + REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra) + REAL FZ(iim,jjm,ntra) + REAL FXX(iim,jjm,ntra),FXY(iim,jjm,ntra) + REAL FXZ(iim,jjm,ntra),FYY(iim,jjm,ntra) + REAL FYZ(iim,jjm,ntra),FZZ(iim,jjm,ntra) + REAL S00(ntra) + REAL SM0 ! Just temporal variable +C +C work arrays +C + REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1) + REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1) + REAL ALF2(iim,0:jjp1),ALF3(iim,0:jjp1) + REAL ALF4(iim,0:jjp1) + REAL TEMPTM ! Just temporal variable + REAL SLPMAX,S1MAX,S1NEW,S2NEW +c +C Special pour poles +c + REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn + REAL sns0(ntra),snsz(ntra),snsm + REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra) + REAL cx1(llm,ntra), cxLAT(llm,ntra) + REAL cy1(llm,ntra), cyLAT(llm,ntra) + REAL z1(iim), zcos(iim), zsin(iim) + REAL SSUM + EXTERNAL SSUM +C + REAL sqi,sqf + LOGICAL LIMIT + + lon = iim ! rem : Il est possible qu'un pbl. arrive ici + lat = jjp1 ! a cause des dim. differentes entre les + niv = llm ! tab. S et VGRI + +c----------------------------------------------------------------- +C initialisations + + sbms = 0. + sfms = 0. + sfzs = 0. + sbmn = 0. + sfmn = 0. + sfzn = 0. + +c----------------------------------------------------------------- +C *** Test : diag de la qtite totale de traceur dans +C l'atmosphere avant l'advection en Y +c + sqi = 0. + sqf = 0. + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqi = sqi + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'---------- DIAG DANS ADVY - ENTREE --------' + PRINT*,'sqi=',sqi + +c----------------------------------------------------------------- +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C Conversion des flux de masses en kg +C-AA 20/10/94 le signe -1 est necessaire car indexation opposee + + DO 500 l = 1,llm + DO 500 j = 1,jjm + DO 500 i = 1,iip1 + vgri (i,j,llm+1-l)=-1.*pbarv (i,j,l) + 500 CONTINUE + +CAA Initialisation de flux fictifs aux bords sup. des boites pol. + + DO l = 1,llm + DO i = 1,iip1 + vgri(i,0,l) = 0. + vgri(i,jjp1,l) = 0. + ENDDO + ENDDO +c +c----------------- START HERE ----------------------- +C boucle sur les niveaux +C + DO 1 L=1,NIV +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 11 +C + DO 10 JV=1,NTRA + DO 10 K=1,LAT + DO 100 I=1,LON + IF(S0(I,K,L,JV).GT.0.) THEN + SLPMAX=AMAX1(S0(I,K,L,JV),0.) + S1MAX=1.5*SLPMAX + S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,SY(I,K,L,JV))) + S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , + + AMAX1(ABS(S1NEW)-SLPMAX,SYY(I,K,L,JV)) ) + SY (I,K,L,JV)=S1NEW + SYY(I,K,L,JV)=S2NEW + SSXY(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXY(I,K,L,JV))) + SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV))) + ELSE + SY (I,K,L,JV)=0. + SYY(I,K,L,JV)=0. + SSXY(I,K,L,JV)=0. + SYZ(I,K,L,JV)=0. + ENDIF + 100 CONTINUE + 10 CONTINUE +C + 11 CONTINUE +C +C le flux a travers le pole Nord est traite separement +C + SM0=0. + DO 20 JV=1,NTRA + S00(JV)=0. + 20 CONTINUE +C + DO 21 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN + FM(I,0)=-VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM(I,1,L) + SM(I,1,L)=SM(I,1,L)-FM(I,0) + SM0=SM0+FM(I,0) + ENDIF +C + ALFQ(I,0)=ALF(I,0)*ALF(I,0) + ALF1(I,0)=1.-ALF(I,0) + ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) + ALF2(I,0)=ALF1(I,0)-ALF(I,0) + ALF3(I,0)=ALF(I,0)*ALFQ(I,0) + ALF4(I,0)=ALF1(I,0)*ALF1Q(I,0) +C + 21 CONTINUE +c print*,'ADVYP 21' +C + DO 22 JV=1,NTRA + DO 220 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN +C + F0(I,0,JV)=ALF(I,0)* ( S0(I,1,L,JV)-ALF1(I,0)* + + ( SY(I,1,L,JV)-ALF2(I,0)*SYY(I,1,L,JV) ) ) +C + S00(JV)=S00(JV)+F0(I,0,JV) + S0 (I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV) + SY (I,1,L,JV)=ALF1Q(I,0)* + + (SY(I,1,L,JV)+3.*ALF(I,0)*SYY(I,1,L,JV)) + SYY(I,1,L,JV)=ALF4 (I,0)*SYY(I,1,L,JV) + SSX (I,1,L,JV)=ALF1 (I,0)* + + (SSX(I,1,L,JV)+ALF(I,0)*SSXY(I,1,L,JV) ) + SZ (I,1,L,JV)=ALF1 (I,0)* + + (SZ(I,1,L,JV)+ALF(I,0)*SSXZ(I,1,L,JV) ) + SSXX(I,1,L,JV)=ALF1 (I,0)*SSXX(I,1,L,JV) + SSXZ(I,1,L,JV)=ALF1 (I,0)*SSXZ(I,1,L,JV) + SZZ(I,1,L,JV)=ALF1 (I,0)*SZZ(I,1,L,JV) + SSXY(I,1,L,JV)=ALF1Q(I,0)*SSXY(I,1,L,JV) + SYZ(I,1,L,JV)=ALF1Q(I,0)*SYZ(I,1,L,JV) +C + ENDIF +C + 220 CONTINUE + 22 CONTINUE +C + DO 23 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + FM(I,0)=VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM0 + ENDIF + 23 CONTINUE +C + DO 24 JV=1,NTRA + DO 240 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + F0(I,0,JV)=ALF(I,0)*S00(JV) + ENDIF + 240 CONTINUE + 24 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C +c print*,'av ADVYP 25' + DO 25 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN + SM(I,1,L)=SM(I,1,L)+FM(I,0) + ALF(I,0)=FM(I,0)/SM(I,1,L) + ENDIF +C + ALFQ(I,0)=ALF(I,0)*ALF(I,0) + ALF1(I,0)=1.-ALF(I,0) + ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) + ALF2(I,0)=ALF1(I,0)-ALF(I,0) + ALF3(I,0)=ALF1(I,0)*ALF(I,0) +C + 25 CONTINUE +c print*,'av ADVYP 25' +C + DO 26 JV=1,NTRA + DO 260 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN +C + TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV) + S0 (I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV) + SYY(I,1,L,JV)=ALF1Q(I,0)*SYY(I,1,L,JV) + + +5.*( ALF3 (I,0)*SY (I,1,L,JV)-ALF2(I,0)*TEMPTM ) + SY (I,1,L,JV)=ALF1 (I,0)*SY (I,1,L,JV)+3.*TEMPTM + SSXY(I,1,L,JV)=ALF1 (I,0)*SSXY(I,1,L,JV)+3.*ALF(I,0)*SSX(I,1,L,JV) + SYZ(I,1,L,JV)=ALF1 (I,0)*SYZ(I,1,L,JV)+3.*ALF(I,0)*SZ(I,1,L,JV) +C + ENDIF +C + 260 CONTINUE + 26 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0 +C +c print*,'av ADVYP 30' + DO 30 K=1,LAT-1 + KP=K+1 + DO 300 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,KP,L) + SM(I,KP,L)=SM(I,KP,L)-FM(I,K) + ELSE + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF(I,K)*ALFQ(I,K) + ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K) +C + 300 CONTINUE + 30 CONTINUE +c print*,'ap ADVYP 30' +C + DO 31 JV=1,NTRA + DO 31 K=1,LAT-1 + KP=K+1 + DO 310 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + F0 (I,K,JV)=ALF (I,K)* ( S0(I,KP,L,JV)-ALF1(I,K)* + + ( SY(I,KP,L,JV)-ALF2(I,K)*SYY(I,KP,L,JV) ) ) + FY (I,K,JV)=ALFQ(I,K)* + + (SY(I,KP,L,JV)-3.*ALF1(I,K)*SYY(I,KP,L,JV)) + FYY(I,K,JV)=ALF3(I,K)*SYY(I,KP,L,JV) + FX (I,K,JV)=ALF (I,K)* + + (SSX(I,KP,L,JV)-ALF1(I,K)*SSXY(I,KP,L,JV)) + FZ (I,K,JV)=ALF (I,K)* + + (SZ(I,KP,L,JV)-ALF1(I,K)*SYZ(I,KP,L,JV)) + FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,KP,L,JV) + FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,KP,L,JV) + FXX(I,K,JV)=ALF (I,K)*SSXX(I,KP,L,JV) + FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,KP,L,JV) + FZZ(I,K,JV)=ALF (I,K)*SZZ(I,KP,L,JV) +C + S0 (I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV) + SY (I,KP,L,JV)=ALF1Q(I,K)* + + (SY(I,KP,L,JV)+3.*ALF(I,K)*SYY(I,KP,L,JV)) + SYY(I,KP,L,JV)=ALF4(I,K)*SYY(I,KP,L,JV) + SSX (I,KP,L,JV)=SSX (I,KP,L,JV)-FX (I,K,JV) + SZ (I,KP,L,JV)=SZ (I,KP,L,JV)-FZ (I,K,JV) + SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)-FXX(I,K,JV) + SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)-FXZ(I,K,JV) + SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)-FZZ(I,K,JV) + SSXY(I,KP,L,JV)=ALF1Q(I,K)*SSXY(I,KP,L,JV) + SYZ(I,KP,L,JV)=ALF1Q(I,K)*SYZ(I,KP,L,JV) +C + ELSE +C + F0 (I,K,JV)=ALF (I,K)* ( S0(I,K,L,JV)+ALF1(I,K)* + + ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) ) + FY (I,K,JV)=ALFQ(I,K)* + + (SY(I,K,L,JV)+3.*ALF1(I,K)*SYY(I,K,L,JV)) + FYY(I,K,JV)=ALF3(I,K)*SYY(I,K,L,JV) + FX (I,K,JV)=ALF (I,K)*(SSX(I,K,L,JV)+ALF1(I,K)*SSXY(I,K,L,JV)) + FZ (I,K,JV)=ALF (I,K)*(SZ(I,K,L,JV)+ALF1(I,K)*SYZ(I,K,L,JV)) + FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,K,L,JV) + FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,K,L,JV) + FXX(I,K,JV)=ALF (I,K)*SSXX(I,K,L,JV) + FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,K,L,JV) + FZZ(I,K,JV)=ALF (I,K)*SZZ(I,K,L,JV) +C + S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) + SY (I,K,L,JV)=ALF1Q(I,K)* + + (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV)) + SYY(I,K,L,JV)=ALF4(I,K)*SYY(I,K,L,JV) + SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,K,JV) + SZ (I,K,L,JV)=SZ (I,K,L,JV)-FZ (I,K,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,K,JV) + SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)-FXZ(I,K,JV) + SZZ(I,K,L,JV)=SZZ(I,K,L,JV)-FZZ(I,K,JV) + SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV) +C + ENDIF +C + 310 CONTINUE + 31 CONTINUE +c print*,'ap ADVYP 31' +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 32 K=1,LAT-1 + KP=K+1 + DO 320 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ELSE + SM(I,KP,L)=SM(I,KP,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,KP,L) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF1(I,K)*ALF(I,K) +C + 320 CONTINUE + 32 CONTINUE +c print*,'ap ADVYP 32' +C + DO 33 JV=1,NTRA + DO 33 K=1,LAT-1 + KP=K+1 + DO 330 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + SYY(I,K,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,K,L,JV) + + +5.*( ALF3(I,K)*(FY(I,K,JV)-SY(I,K,L,JV))+ALF2(I,K)*TEMPTM ) + SY (I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,K,L,JV) + + +3.*TEMPTM + SSXY(I,K,L,JV)=ALF (I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,K,L,JV) + + +3.*(ALF1(I,K)*FX (I,K,JV)-ALF (I,K)*SSX (I,K,L,JV)) + SYZ(I,K,L,JV)=ALF (I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,K,L,JV) + + +3.*(ALF1(I,K)*FZ (I,K,JV)-ALF (I,K)*SZ (I,K,L,JV)) + SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,K,JV) + SZ (I,K,L,JV)=SZ (I,K,L,JV)+FZ (I,K,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,K,JV) + SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)+FXZ(I,K,JV) + SZZ(I,K,L,JV)=SZZ(I,K,L,JV)+FZZ(I,K,JV) +C + ELSE +C + TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV) + S0 (I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV) + SYY(I,KP,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,KP,L,JV) + + +5.*( ALF3(I,K)*(SY(I,KP,L,JV)-FY(I,K,JV))-ALF2(I,K)*TEMPTM ) + SY (I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,KP,L,JV) + + +3.*TEMPTM + SSXY(I,KP,L,JV)=ALF(I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,KP,L,JV) + + +3.*(ALF(I,K)*SSX(I,KP,L,JV)-ALF1(I,K)*FX(I,K,JV)) + SYZ(I,KP,L,JV)=ALF(I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,KP,L,JV) + + +3.*(ALF(I,K)*SZ(I,KP,L,JV)-ALF1(I,K)*FZ(I,K,JV)) + SSX (I,KP,L,JV)=SSX (I,KP,L,JV)+FX (I,K,JV) + SZ (I,KP,L,JV)=SZ (I,KP,L,JV)+FZ (I,K,JV) + SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)+FXX(I,K,JV) + SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)+FXZ(I,K,JV) + SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)+FZZ(I,K,JV) +C + ENDIF +C + 330 CONTINUE + 33 CONTINUE +c print*,'ap ADVYP 33' +C +C traitement special pour le pole Sud (idem pole Nord) +C + K=LAT +C + SM0=0. + DO 40 JV=1,NTRA + S00(JV)=0. + 40 CONTINUE +C + DO 41 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + SM0=SM0+FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF(I,K)*ALFQ(I,K) + ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K) +C + 41 CONTINUE +c print*,'ap ADVYP 41' +C + DO 42 JV=1,NTRA + DO 420 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + F0 (I,K,JV)=ALF(I,K)* ( S0(I,K,L,JV)+ALF1(I,K)* + + ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) ) + S00(JV)=S00(JV)+F0(I,K,JV) +C + S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) + SY (I,K,L,JV)=ALF1Q(I,K)* + + (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV)) + SYY(I,K,L,JV)=ALF4 (I,K)*SYY(I,K,L,JV) + SSX (I,K,L,JV)=ALF1(I,K)*(SSX(I,K,L,JV)-ALF(I,K)*SSXY(I,K,L,JV)) + SZ (I,K,L,JV)=ALF1(I,K)*(SZ(I,K,L,JV)-ALF(I,K)*SYZ(I,K,L,JV)) + SSXX(I,K,L,JV)=ALF1 (I,K)*SSXX(I,K,L,JV) + SSXZ(I,K,L,JV)=ALF1 (I,K)*SSXZ(I,K,L,JV) + SZZ(I,K,L,JV)=ALF1 (I,K)*SZZ(I,K,L,JV) + SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV) + ENDIF +C + 420 CONTINUE + 42 CONTINUE +c print*,'ap ADVYP 42' +C + DO 43 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM0 + ENDIF + 43 CONTINUE +c print*,'ap ADVYP 43' +C + DO 44 JV=1,NTRA + DO 440 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + F0(I,K,JV)=ALF(I,K)*S00(JV) + ENDIF + 440 CONTINUE + 44 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 45 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF1(I,K)*ALF(I,K) +C + 45 CONTINUE +c print*,'ap ADVYP 45' +C + DO 46 JV=1,NTRA + DO 460 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + SYY(I,K,L,JV)=ALF1Q(I,K)*SYY(I,K,L,JV) + + +5.*(-ALF3 (I,K)*SY (I,K,L,JV)+ALF2(I,K)*TEMPTM ) + SY (I,K,L,JV)=ALF1(I,K)*SY (I,K,L,JV)+3.*TEMPTM + SSXY(I,K,L,JV)=ALF1(I,K)*SSXY(I,K,L,JV)-3.*ALF(I,K)*SSX(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1(I,K)*SYZ(I,K,L,JV)-3.*ALF(I,K)*SZ(I,K,L,JV) +C + ENDIF +C + 460 CONTINUE + 46 CONTINUE +c print*,'ap ADVYP 46' +C + 1 CONTINUE + +c-------------------------------------------------- +C bouclage cyclique horizontal . + + DO l = 1,llm + DO jv = 1,ntra + DO j = 1,jjp1 + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,jv) = S0(1,j,l,jv) + SSX(iip1,j,l,jv) = SSX(1,j,l,jv) + SY(iip1,j,l,jv) = SY(1,j,l,jv) + SZ(iip1,j,l,jv) = SZ(1,j,l,jv) + END DO + END DO + END DO + +c ------------------------------------------------------------------- +C *** Test negativite: + +c DO jv = 1,ntra +c DO l = 1,llm +c DO j = 1,jjp1 +c DO i = 1,iip1 +c IF (s0( i,j,l,jv ).lt.0.) THEN +c PRINT*, '------ S0 < 0 en FIN ADVYP ---' +c PRINT*, 'S0(',i,j,l,jv,')=', S0(i,j,l,jv) +cc STOP +c ENDIF +c ENDDO +c ENDDO +c ENDDO +c ENDDO + + +c ------------------------------------------------------------------- +C *** Test : diag de la qtite totale de traceur dans +C l'atmosphere avant l'advection en Y + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqf = sqf + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'---------- DIAG DANS ADVY - SORTIE --------' + PRINT*,'sqf=',sqf +c print*,'ap ADVYP fin' + +c----------------------------------------------------------------- +C + RETURN + END + + + + + + + + + + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advz.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advz.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advz.F (revision 1280) @@ -0,0 +1,322 @@ +! +! $Header$ +! + SUBROUTINE advz(limit,dtz,w,sm,s0,sx,sy,sz) + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C first-order moments (FOM) advection of tracer in Z direction C +C C +C Source : Pascal Simon (Meteo,CNRM) C +C Adaptation : A.Armengaud (LGGE) juin 94 C +C C +C C +C sont des arguments d'entree pour le s-pg... C +C C +C dq est l'argument de sortie pour le s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" + +C #include "traceur.h" + +C Arguments : +C ----------- +C dtz : frequence fictive d'appel du transport +C w : flux de masse en z en Pa.m2.s-1 + + INTEGER ntra + PARAMETER (ntra = 1) + + REAL dtz + REAL w ( iip1,jjp1,llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL sx(iip1,jjp1,llm,ntra) + + ,sy(iip1,jjp1,llm,ntra) + + ,sz(iip1,jjp1,llm,ntra) + + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL WGRI(iip1,jjp1,0:llm) + +C +C the moments F are used as temporary storage for +C portions of grid boxes in transit at the current latitude +C + REAL FM(iim,llm) + REAL F0(iim,llm,ntra),FX(iim,llm,ntra) + REAL FY(iim,llm,ntra),FZ(iim,llm,ntra) +C +C work arrays +C + REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim) + REAL TEMPTM ! Just temporal variable + REAL sqi,sqf +C + LOGICAL LIMIT + INTEGER lon,lat,niv + INTEGER i,j,jv,k,l,lp + + lon = iim + lat = jjp1 + niv = llm + +C *** Test de passage d'arguments ****** + +c DO 399 l = 1, llm +c DO 399 j = 1, jjp1 +c DO 399 i = 1, iip1 +c IF (S0(i,j,l,ntra) .lt. 0. ) THEN +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra) +c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra) +c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra) +c PRINT*, 'AIE !! debut ADVZ - pbl arg. passage dans ADVZ' +c STOP +c ENDIF + 399 CONTINUE + +C----------------------------------------------------------------- +C *** Test : diag de la qqtite totale de traceur +C dans l'atmosphere avant l'advection en z + sqi = 0. + sqf = 0. + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim +cIM 240305 sqi = sqi + S0(i,j,l,9) + sqi = sqi + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVZ - ENTREE ---------' + PRINT*,'sqi=',sqi + +C----------------------------------------------------------------- +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C Conversion du flux de masse en kg.s-1 + + DO 500 l = 1,llm + DO 500 j = 1,jjp1 + DO 500 i = 1,iip1 +c wgri (i,j,llm+1-l) = w (i,j,l) / g + wgri (i,j,llm+1-l) = w (i,j,l) +c wgri (i,j,0) = 0. ! a detruire ult. +c wgri (i,j,l) = 0.1 ! w (i,j,l) +c wgri (i,j,llm) = 0. ! a detruire ult. + 500 CONTINUE + DO j = 1,jjp1 + DO i = 1,iip1 + wgri(i,j,0)=0. + enddo + enddo + +C----------------------------------------------------------------- + +C start here +C boucle sur les latitudes +C + DO 1 K=1,LAT +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 101 +C + DO 10 JV=1,NTRA + DO 10 L=1,NIV + DO 100 I=1,LON + sz(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.), + + ABS(sz(I,K,L,JV))),sz(I,K,L,JV)) + 100 CONTINUE + 10 CONTINUE +C + 101 CONTINUE +C +C boucle sur les niveaux intercouches de 1 a NIV-1 +C (flux nul au sommet L=0 et a la base L=NIV) +C +C calculate flux and moments between adjacent boxes +C (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0) +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C + DO 11 L=1,NIV-1 + LP=L+1 +C + DO 110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + FM(I,L)=-WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,LP) + SM(I,K,LP)=SM(I,K,LP)-FM(I,L) + ELSE + FM(I,L)=WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,L) + ENDIF +C + ALFQ (I)=ALF(I)*ALF(I) + ALF1 (I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) +C + 110 CONTINUE +C + DO 111 JV=1,NTRA + DO 1110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + F0(I,L,JV)=ALF (I)*( S0(I,K,LP,JV)-ALF1(I)*sz(I,K,LP,JV) ) + FZ(I,L,JV)=ALFQ(I)*sz(I,K,LP,JV) + FX(I,L,JV)=ALF (I)*sx(I,K,LP,JV) + FY(I,L,JV)=ALF (I)*sy(I,K,LP,JV) +C + S0(I,K,LP,JV)=S0(I,K,LP,JV)-F0(I,L,JV) + sz(I,K,LP,JV)=ALF1Q(I)*sz(I,K,LP,JV) + sx(I,K,LP,JV)=sx(I,K,LP,JV)-FX(I,L,JV) + sy(I,K,LP,JV)=sy(I,K,LP,JV)-FY(I,L,JV) +C + ELSE +C + F0(I,L,JV)=ALF (I)*(S0(I,K,L,JV)+ALF1(I)*sz(I,K,L,JV) ) + FZ(I,L,JV)=ALFQ(I)*sz(I,K,L,JV) + FX(I,L,JV)=ALF (I)*sx(I,K,L,JV) + FY(I,L,JV)=ALF (I)*sy(I,K,L,JV) +C + S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,L,JV) + sz(I,K,L,JV)=ALF1Q(I)*sz(I,K,L,JV) + sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,L,JV) + sy(I,K,L,JV)=sy(I,K,L,JV)-FY(I,L,JV) +C + ENDIF +C + 1110 CONTINUE + 111 CONTINUE +C + 11 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 12 L=1,NIV-1 + LP=L+1 +C + DO 120 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,L) + ELSE + SM(I,K,LP)=SM(I,K,LP)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,LP) + ENDIF +C + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) +C + 120 CONTINUE +C + DO 121 JV=1,NTRA + DO 1210 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV) + S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV) + sz(I,K,L,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,L,JV)+3.*TEMPTM + sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,L,JV) + sy(I,K,L,JV)=sy(I,K,L,JV)+FY(I,L,JV) +C + ELSE +C + TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV) + S0(I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV) + sz(I,K,LP,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,LP,JV) + + +3.*TEMPTM + sx(I,K,LP,JV)=sx(I,K,LP,JV)+FX(I,L,JV) + sy(I,K,LP,JV)=sy(I,K,LP,JV)+FY(I,L,JV) +C + ENDIF +C + 1210 CONTINUE + 121 CONTINUE +C + 12 CONTINUE +C +C fin de la boucle principale sur les latitudes +C + 1 CONTINUE +C +C------------------------------------------------------------- +C +C ----------- AA Test en fin de ADVX ------ Controle des S* + +c DO 9999 l = 1, llm +c DO 9999 j = 1, jjp1 +c DO 9999 i = 1, iip1 +c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN +c PRINT*, '-------------------' +c PRINT*, 'En fin de ADVZ' +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra) +c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra) +c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra) +c WRITE (*,*) 'On arrete !! - pbl en fin de ADVZ1' +c STOP +c ENDIF + 9999 CONTINUE + +C *** ------------------- bouclage cyclique en X ------------ + +c DO l = 1,llm +c DO j = 1,jjp1 +c SM(iip1,j,l) = SM(1,j,l) +c S0(iip1,j,l,ntra) = S0(1,j,l,ntra) +C sx(iip1,j,l,ntra) = sx(1,j,l,ntra) +c sy(iip1,j,l,ntra) = sy(1,j,l,ntra) +c sz(iip1,j,l,ntra) = sz(1,j,l,ntra) +c ENDDO +c ENDDO + +C------------------------------------------------------------- +C *** Test : diag de la qqtite totale de traceur +C dans l'atmosphere avant l'advection en z + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim +cIM 240305 sqf = sqf + S0(i,j,l,9) + sqf = sqf + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------' + PRINT*,'sqf=', sqf + +C------------------------------------------------------------- + RETURN + END +C_______________________________________________________________ +C_______________________________________________________________ Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advzp.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advzp.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/advzp.F (revision 1280) @@ -0,0 +1,378 @@ +! +! $Header$ +! + SUBROUTINE ADVZP(LIMIT,DTZ,W,SM,S0,SSX,SY,SZ + . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra ) + + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C second-order moments (SOM) advection of tracer in Z direction C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Source : Pascal Simon ( Meteo, CNRM ) C +C Adaptation : A.A. (LGGE) C +C Derniere Modif : 19/11/95 LAST C +C C +C sont les arguments d'entree pour le s-pg C +C C +C argument de sortie du s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Rem : Probleme aux poles il faut reecrire ce cas specifique +C Attention au sens de l'indexation +C + +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +C +C Arguments : +C ---------- +C dty : frequence fictive d'appel du transport +C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 +c + INTEGER lon,lat,niv + INTEGER i,j,jv,k,kp,l,lp + INTEGER ntra +c PARAMETER (ntra = 1) +c + REAL dtz + REAL w ( iip1,jjp1,llm ) +c +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL SSX(iip1,jjp1,llm,ntra) + + ,SY(iip1,jjp1,llm,ntra) + + ,SZ(iip1,jjp1,llm,ntra) + + ,SSXX(iip1,jjp1,llm,ntra) + + ,SSXY(iip1,jjp1,llm,ntra) + + ,SSXZ(iip1,jjp1,llm,ntra) + + ,SYY(iip1,jjp1,llm,ntra) + + ,SYZ(iip1,jjp1,llm,ntra) + + ,SZZ(iip1,jjp1,llm,ntra) +C +C Local : +C ------- +C +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : +C + REAL WGRI(iip1,jjp1,0:llm) + +C Rem : UGRI et VGRI ne sont pas utilises dans +C cette subroutine ( advection en z uniquement ) +C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv +C attention a celui de WGRI +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C +C the moments Fij are used as temporary storage for +C portions of the grid boxes in transit at the current level +C +C work arrays +C +C + REAL F0(iim,llm,ntra),FM(iim,llm) + REAL FX(iim,llm,ntra),FY(iim,llm,ntra) + REAL FZ(iim,llm,ntra) + REAL FXX(iim,llm,ntra),FXY(iim,llm,ntra) + REAL FXZ(iim,llm,ntra),FYY(iim,llm,ntra) + REAL FYZ(iim,llm,ntra),FZZ(iim,llm,ntra) + REAL S00(ntra) + REAL SM0 ! Just temporal variable +C +C work arrays +C + REAL ALF(iim),ALF1(iim) + REAL ALFQ(iim),ALF1Q(iim) + REAL ALF2(iim),ALF3(iim) + REAL ALF4(iim) + REAL TEMPTM ! Just temporal variable + REAL SLPMAX,S1MAX,S1NEW,S2NEW +c + REAL sqi,sqf + LOGICAL LIMIT + + lon = iim ! rem : Il est possible qu'un pbl. arrive ici + lat = jjp1 ! a cause des dim. differentes entre les + niv = llm ! tab. S et VGRI + +c----------------------------------------------------------------- +C *** Test : diag de la qtite totale de traceur dans +C l'atmosphere avant l'advection en Y +c + sqi = 0. + sqf = 0. +c + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqi = sqi + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'---------- DIAG DANS ADVZP - ENTREE --------' + PRINT*,'sqi=',sqi + +c----------------------------------------------------------------- +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C Conversion des flux de masses en kg + + DO 500 l = 1,llm + DO 500 j = 1,jjp1 + DO 500 i = 1,iip1 + wgri (i,j,llm+1-l) = w (i,j,l) + 500 CONTINUE + do j=1,jjp1 + do i=1,iip1 + wgri(i,j,0)=0. + enddo + enddo +c +cAA rem : Je ne suis pas sur du signe +cAA Je ne suis pas sur pour le 0:llm +c +c----------------------------------------------------------------- +C---------------------- START HERE ------------------------------- +C +C boucle sur les latitudes +C + DO 1 K=1,LAT +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 101 +C + DO 10 JV=1,NTRA + DO 10 L=1,NIV + DO 100 I=1,LON + IF(S0(I,K,L,JV).GT.0.) THEN + SLPMAX=S0(I,K,L,JV) + S1MAX =1.5*SLPMAX + S1NEW =AMIN1(S1MAX,AMAX1(-S1MAX,SZ(I,K,L,JV))) + S2NEW =AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , + + AMAX1(ABS(S1NEW)-SLPMAX,SZZ(I,K,L,JV)) ) + SZ (I,K,L,JV)=S1NEW + SZZ(I,K,L,JV)=S2NEW + SSXZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXZ(I,K,L,JV))) + SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV))) + ELSE + SZ (I,K,L,JV)=0. + SZZ(I,K,L,JV)=0. + SSXZ(I,K,L,JV)=0. + SYZ(I,K,L,JV)=0. + ENDIF + 100 CONTINUE + 10 CONTINUE +C + 101 CONTINUE +C +C boucle sur les niveaux intercouches de 1 a NIV-1 +C (flux nul au sommet L=0 et a la base L=NIV) +C +C calculate flux and moments between adjacent boxes +C (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0) +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C + DO 11 L=1,NIV-1 + LP=L+1 +C + DO 110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + FM(I,L)=-WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,LP) + SM(I,K,LP)=SM(I,K,LP)-FM(I,L) + ELSE + FM(I,L)=WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,L) + ENDIF +C + ALFQ (I)=ALF(I)*ALF(I) + ALF1 (I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2 (I)=ALF1(I)-ALF(I) + ALF3 (I)=ALF(I)*ALFQ(I) + ALF4 (I)=ALF1(I)*ALF1Q(I) +C + 110 CONTINUE +C + DO 111 JV=1,NTRA + DO 1110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + F0 (I,L,JV)=ALF (I)* ( S0(I,K,LP,JV)-ALF1(I)* + + ( SZ(I,K,LP,JV)-ALF2(I)*SZZ(I,K,LP,JV) ) ) + FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,LP,JV)-3.*ALF1(I)*SZZ(I,K,LP,JV)) + FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,LP,JV) + FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,LP,JV) + FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,LP,JV) + FX (I,L,JV)=ALF (I)*(SSX(I,K,LP,JV)-ALF1(I)*SSXZ(I,K,LP,JV)) + FY (I,L,JV)=ALF (I)*(SY(I,K,LP,JV)-ALF1(I)*SYZ(I,K,LP,JV)) + FXX(I,L,JV)=ALF (I)*SSXX(I,K,LP,JV) + FXY(I,L,JV)=ALF (I)*SSXY(I,K,LP,JV) + FYY(I,L,JV)=ALF (I)*SYY(I,K,LP,JV) +C + S0 (I,K,LP,JV)=S0 (I,K,LP,JV)-F0 (I,L,JV) + SZ (I,K,LP,JV)=ALF1Q(I) + + *(SZ(I,K,LP,JV)+3.*ALF(I)*SZZ(I,K,LP,JV)) + SZZ(I,K,LP,JV)=ALF4 (I)*SZZ(I,K,LP,JV) + SSXZ(I,K,LP,JV)=ALF1Q(I)*SSXZ(I,K,LP,JV) + SYZ(I,K,LP,JV)=ALF1Q(I)*SYZ(I,K,LP,JV) + SSX (I,K,LP,JV)=SSX (I,K,LP,JV)-FX (I,L,JV) + SY (I,K,LP,JV)=SY (I,K,LP,JV)-FY (I,L,JV) + SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)-FXX(I,L,JV) + SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)-FXY(I,L,JV) + SYY(I,K,LP,JV)=SYY(I,K,LP,JV)-FYY(I,L,JV) +C + ELSE +C + F0 (I,L,JV)=ALF (I)*(S0(I,K,L,JV) + + +ALF1(I) * (SZ(I,K,L,JV)+ALF2(I)*SZZ(I,K,L,JV)) ) + FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,L,JV)+3.*ALF1(I)*SZZ(I,K,L,JV)) + FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,L,JV) + FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,L,JV) + FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,L,JV) + FX (I,L,JV)=ALF (I)*(SSX(I,K,L,JV)+ALF1(I)*SSXZ(I,K,L,JV)) + FY (I,L,JV)=ALF (I)*(SY(I,K,L,JV)+ALF1(I)*SYZ(I,K,L,JV)) + FXX(I,L,JV)=ALF (I)*SSXX(I,K,L,JV) + FXY(I,L,JV)=ALF (I)*SSXY(I,K,L,JV) + FYY(I,L,JV)=ALF (I)*SYY(I,K,L,JV) +C + S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0(I,L,JV) + SZ (I,K,L,JV)=ALF1Q(I)*(SZ(I,K,L,JV)-3.*ALF(I)*SZZ(I,K,L,JV)) + SZZ(I,K,L,JV)=ALF4 (I)*SZZ(I,K,L,JV) + SSXZ(I,K,L,JV)=ALF1Q(I)*SSXZ(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1Q(I)*SYZ(I,K,L,JV) + SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,L,JV) + SY (I,K,L,JV)=SY (I,K,L,JV)-FY (I,L,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,L,JV) + SSXY(I,K,L,JV)=SSXY(I,K,L,JV)-FXY(I,L,JV) + SYY(I,K,L,JV)=SYY(I,K,L,JV)-FYY(I,L,JV) +C + ENDIF +C + 1110 CONTINUE + 111 CONTINUE +C + 11 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 12 L=1,NIV-1 + LP=L+1 +C + DO 120 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,L) + ELSE + SM(I,K,LP)=SM(I,K,LP)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,LP) + ENDIF +C + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF(I)*ALF1(I) + ALF3(I)=ALF1(I)-ALF(I) +C + 120 CONTINUE +C + DO 121 JV=1,NTRA + DO 1210 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV) + S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV) + SZZ(I,K,L,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,L,JV) + + +5.*( ALF2(I)*(FZ(I,L,JV)-SZ(I,K,L,JV))+ALF3(I)*TEMPTM ) + SZ (I,K,L,JV)=ALF (I)*FZ (I,L,JV)+ALF1 (I)*SZ (I,K,L,JV) + + +3.*TEMPTM + SSXZ(I,K,L,JV)=ALF (I)*FXZ(I,L,JV)+ALF1 (I)*SSXZ(I,K,L,JV) + + +3.*(ALF1(I)*FX (I,L,JV)-ALF (I)*SSX (I,K,L,JV)) + SYZ(I,K,L,JV)=ALF (I)*FYZ(I,L,JV)+ALF1 (I)*SYZ(I,K,L,JV) + + +3.*(ALF1(I)*FY (I,L,JV)-ALF (I)*SY (I,K,L,JV)) + SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,L,JV) + SY (I,K,L,JV)=SY (I,K,L,JV)+FY (I,L,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,L,JV) + SSXY(I,K,L,JV)=SSXY(I,K,L,JV)+FXY(I,L,JV) + SYY(I,K,L,JV)=SYY(I,K,L,JV)+FYY(I,L,JV) +C + ELSE +C + TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV) + S0 (I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV) + SZZ(I,K,LP,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,LP,JV) + + +5.*( ALF2(I)*(SZ(I,K,LP,JV)-FZ(I,L,JV))-ALF3(I)*TEMPTM ) + SZ (I,K,LP,JV)=ALF (I)*FZ(I,L,JV)+ALF1(I)*SZ(I,K,LP,JV) + + +3.*TEMPTM + SSXZ(I,K,LP,JV)=ALF(I)*FXZ(I,L,JV)+ALF1(I)*SSXZ(I,K,LP,JV) + + +3.*(ALF(I)*SSX(I,K,LP,JV)-ALF1(I)*FX(I,L,JV)) + SYZ(I,K,LP,JV)=ALF(I)*FYZ(I,L,JV)+ALF1(I)*SYZ(I,K,LP,JV) + + +3.*(ALF(I)*SY(I,K,LP,JV)-ALF1(I)*FY(I,L,JV)) + SSX (I,K,LP,JV)=SSX (I,K,LP,JV)+FX (I,L,JV) + SY (I,K,LP,JV)=SY (I,K,LP,JV)+FY (I,L,JV) + SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)+FXX(I,L,JV) + SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)+FXY(I,L,JV) + SYY(I,K,LP,JV)=SYY(I,K,LP,JV)+FYY(I,L,JV) +C + ENDIF +C + 1210 CONTINUE + 121 CONTINUE +C + 12 CONTINUE +C +C fin de la boucle principale sur les latitudes +C + 1 CONTINUE +C + DO l = 1,llm + DO j = 1,jjp1 + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,ntra) = S0(1,j,l,ntra) + SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra) + SY(iip1,j,l,ntra) = SY(1,j,l,ntra) + SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra) + ENDDO + ENDDO +c C------------------------------------------------------------- +C *** Test : diag de la qqtite totale de tarceur +C dans l'atmosphere avant l'advection en z + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqf = sqf + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------' + PRINT*,'sqf=', sqf + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/bernoui.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/bernoui.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/bernoui.F (revision 1280) @@ -0,0 +1,58 @@ +! +! $Header$ +! + SUBROUTINE bernoui (ngrid,nlay,pphi,pecin,pbern) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c calcul de la fonction de Bernouilli aux niveaux s ..... +c phi et ecin sont des arguments d'entree pour le s-pg ....... +c bern est un argument de sortie pour le s-pg ...... +c +c fonction de Bernouilli = bern = filtre de( geopotentiel + +c energ.cinet.) +c +c======================================================================= +c +c----------------------------------------------------------------------- +c Decalrations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +c +c Arguments: +c ---------- +c + INTEGER nlay,ngrid + REAL pphi(ngrid*nlay),pecin(ngrid*nlay),pbern(ngrid*nlay) +c +c Local: +c ------ +c + INTEGER ijl +c +c----------------------------------------------------------------------- +c calcul de Bernouilli: +c --------------------- +c + DO 4 ijl = 1,ngrid*nlay + pbern( ijl ) = pphi( ijl ) + pecin( ijl ) + 4 CONTINUE +c +c----------------------------------------------------------------------- +c filtre: +c ------- +c + CALL filtreg( pbern, jjp1, llm, 2,1, .true., 1 ) +c +c----------------------------------------------------------------------- + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/bilan_dyn.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/bilan_dyn.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/bilan_dyn.F (revision 1280) @@ -0,0 +1,586 @@ +! +! $Id$ +! + SUBROUTINE bilan_dyn (ntrac,dt_app,dt_cum, + s ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac) + +c AFAIRE +c Prevoir en champ nq+1 le diagnostique de l'energie +c en faisant Qzon=Cv T + L * ... +c vQ..A=Cp T + L * ... + +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" +#include "temps.h" +#include "iniprint.h" + +c==================================================================== +c +c Sous-programme consacre à des diagnostics dynamiques de base +c +c +c De facon generale, les moyennes des scalaires Q sont ponderees par +c la masse. +c +c Les flux de masse sont eux simplement moyennes. +c +c==================================================================== + +c Arguments : +c =========== + + integer ntrac + real dt_app,dt_cum + real ps(iip1,jjp1) + real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm) + real flux_u(iip1,jjp1,llm) + real flux_v(iip1,jjm,llm) + real teta(iip1,jjp1,llm) + real phi(iip1,jjp1,llm) + real ucov(iip1,jjp1,llm) + real vcov(iip1,jjm,llm) + real trac(iip1,jjp1,llm,ntrac) + +c Local : +c ======= + + integer icum,ncum + logical first + real zz,zqy,zfactv(jjm,llm) + + integer nQ + parameter (nQ=7) + + +cym character*6 nom(nQ) +cym character*6 unites(nQ) + character*6,save :: nom(nQ) + character*6,save :: unites(nQ) + + character*10 file + integer ifile + parameter (ifile=4) + + integer itemp,igeop,iecin,iang,iu,iovap,iun + integer i_sortie + + save first,icum,ncum + save itemp,igeop,iecin,iang,iu,iovap,iun + save i_sortie + + real time + integer itau + save time,itau + data time,itau/0.,0/ + + data first/.true./ + data itemp,igeop,iecin,iang,iu,iovap,iun/1,2,3,4,5,6,7/ + data i_sortie/1/ + + real ww + +c variables dynamiques intermédiaires + REAL vcont(iip1,jjm,llm),ucont(iip1,jjp1,llm) + REAL ang(iip1,jjp1,llm),unat(iip1,jjp1,llm) + REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm) + REAL vorpot(iip1,jjm,llm) + REAL w(iip1,jjp1,llm),ecin(iip1,jjp1,llm),convm(iip1,jjp1,llm) + REAL bern(iip1,jjp1,llm) + +c champ contenant les scalaires advectés. + real Q(iip1,jjp1,llm,nQ) + +c champs cumulés + real ps_cum(iip1,jjp1) + real masse_cum(iip1,jjp1,llm) + real flux_u_cum(iip1,jjp1,llm) + real flux_v_cum(iip1,jjm,llm) + real Q_cum(iip1,jjp1,llm,nQ) + real flux_uQ_cum(iip1,jjp1,llm,nQ) + real flux_vQ_cum(iip1,jjm,llm,nQ) + real flux_wQ_cum(iip1,jjp1,llm,nQ) + real dQ(iip1,jjp1,llm,nQ) + + save ps_cum,masse_cum,flux_u_cum,flux_v_cum + save Q_cum,flux_uQ_cum,flux_vQ_cum + +c champs de tansport en moyenne zonale + integer ntr,itr + parameter (ntr=5) + +cym character*10 znom(ntr,nQ) +cym character*20 znoml(ntr,nQ) +cym character*10 zunites(ntr,nQ) + character*10,save :: znom(ntr,nQ) + character*20,save :: znoml(ntr,nQ) + character*10,save :: zunites(ntr,nQ) + + integer iave,itot,immc,itrs,istn + data iave,itot,immc,itrs,istn/1,2,3,4,5/ + character*3 ctrs(ntr) + data ctrs/' ','TOT','MMC','TRS','STN'/ + + real zvQ(jjm,llm,ntr,nQ),zvQtmp(jjm,llm) + real zavQ(jjm,ntr,nQ),psiQ(jjm,llm+1,nQ) + real zmasse(jjm,llm),zamasse(jjm) + + real zv(jjm,llm),psi(jjm,llm+1) + + integer i,j,l,iQ + + +c Initialisation du fichier contenant les moyennes zonales. +c --------------------------------------------------------- + + character*10 infile + + integer fileid + integer thoriid, zvertiid + save fileid + + integer ndex3d(jjm*llm) + +C Variables locales +C + integer tau0 + real zjulian + character*3 str + character*10 ctrac + integer ii,jj + integer zan, dayref +C + real rlong(jjm),rlatg(jjm) + + + +c===================================================================== +c Initialisation +c===================================================================== + + time=time+dt_app + itau=itau+1 +cIM + ndex3d=0 + + if (first) then + + + icum=0 +c initialisation des fichiers + first=.false. +c ncum est la frequence de stokage en pas de temps + ncum=dt_cum/dt_app + if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then + WRITE(lunout,*) + . 'Pb : le pas de cumule doit etre multiple du pas' + WRITE(lunout,*)'dt_app=',dt_app + WRITE(lunout,*)'dt_cum=',dt_cum + stop + endif + + if (i_sortie.eq.1) then + file='dynzon' + call inigrads(ifile,1 + s ,0.,180./pi,0.,0.,jjm,rlatv,-90.,90.,180./pi + s ,llm,presnivs,1. + s ,dt_cum,file,'dyn_zon ') + endif + + nom(itemp)='T' + nom(igeop)='gz' + nom(iecin)='K' + nom(iang)='ang' + nom(iu)='u' + nom(iovap)='ovap' + nom(iun)='un' + + unites(itemp)='K' + unites(igeop)='m2/s2' + unites(iecin)='m2/s2' + unites(iang)='ang' + unites(iu)='m/s' + unites(iovap)='kg/kg' + unites(iun)='un' + + +c Initialisation du fichier contenant les moyennes zonales. +c --------------------------------------------------------- + + infile='dynzon' + + zan = annee_ref + dayref = day_ref + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + rlong=0. + rlatg=rlatv*180./pi + + call histbeg(infile, 1, rlong, jjm, rlatg, + . 1, 1, 1, jjm, + . tau0, zjulian, dt_cum, thoriid, fileid) + +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'presnivs', 'Niveaux sigma','mb', + . llm, presnivs, zvertiid) +C +C Appels a histdef pour la definition des variables a sauvegarder + do iQ=1,nQ + do itr=1,ntr + if(itr.eq.1) then + znom(itr,iQ)=nom(iQ) + znoml(itr,iQ)=nom(iQ) + zunites(itr,iQ)=unites(iQ) + else + znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ) + znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr) + zunites(itr,iQ)='m/s * '//unites(iQ) + endif + enddo + enddo + +c Declarations des champs avec dimension verticale +c print*,'1HISTDEF' + do iQ=1,nQ + do itr=1,ntr + IF (prt_level > 5) + . WRITE(lunout,*)'var ',itr,iQ + . ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ) + call histdef(fileid,znom(itr,iQ),znoml(itr,iQ), + . zunites(itr,iQ),1,jjm,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + enddo +c Declarations pour les fonctions de courant +c print*,'2HISTDEF' + call histdef(fileid,'psi'//nom(iQ) + . ,'stream fn. '//znoml(itot,iQ), + . zunites(itot,iQ),1,jjm,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + enddo + + +c Declarations pour les champs de transport d'air +c print*,'3HISTDEF' + call histdef(fileid, 'masse', 'masse', + . 'kg', 1, jjm, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', dt_cum, dt_cum) + call histdef(fileid, 'v', 'v', + . 'm/s', 1, jjm, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', dt_cum, dt_cum) +c Declarations pour les fonctions de courant +c print*,'4HISTDEF' + call histdef(fileid,'psi','stream fn. MMC ','mega t/s', + . 1,jjm,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + + +c Declaration des champs 1D de transport en latitude +c print*,'5HISTDEF' + do iQ=1,nQ + do itr=2,ntr + call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ), + . zunites(itr,iQ),1,jjm,thoriid,1,1,1,-99, + . 32,'ave(X)',dt_cum,dt_cum) + enddo + enddo + + +c print*,'8HISTDEF' + CALL histend(fileid) + + + endif + + +c===================================================================== +c Calcul des champs dynamiques +c ---------------------------- + +c énergie cinétique + ucont(:,:,:)=0 + CALL covcont(llm,ucov,vcov,ucont,vcont) + CALL enercin(vcov,ucov,vcont,ucont,ecin) + +c moment cinétique + do l=1,llm + ang(:,:,l)=ucov(:,:,l)+constang(:,:) + unat(:,:,l)=ucont(:,:,l)*cu(:,:) + enddo + + Q(:,:,:,itemp)=teta(:,:,:)*pk(:,:,:)/cpp + Q(:,:,:,igeop)=phi(:,:,:) + Q(:,:,:,iecin)=ecin(:,:,:) + Q(:,:,:,iang)=ang(:,:,:) + Q(:,:,:,iu)=unat(:,:,:) + Q(:,:,:,iovap)=trac(:,:,:,1) + Q(:,:,:,iun)=1. + + +c===================================================================== +c Cumul +c===================================================================== +c + if(icum.EQ.0) then + ps_cum=0. + masse_cum=0. + flux_u_cum=0. + flux_v_cum=0. + Q_cum=0. + flux_vQ_cum=0. + flux_uQ_cum=0. + endif + + IF (prt_level > 5) + . WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1 + icum=icum+1 + +c accumulation des flux de masse horizontaux + ps_cum=ps_cum+ps + masse_cum=masse_cum+masse + flux_u_cum=flux_u_cum+flux_u + flux_v_cum=flux_v_cum+flux_v + do iQ=1,nQ + Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)+Q(:,:,:,iQ)*masse(:,:,:) + enddo + +c===================================================================== +c FLUX ET TENDANCES +c===================================================================== + +c Flux longitudinal +c ----------------- + do iQ=1,nQ + do l=1,llm + do j=1,jjp1 + do i=1,iim + flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ) + s +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ)) + enddo + flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ) + enddo + enddo + enddo + +c flux méridien +c ------------- + do iQ=1,nQ + do l=1,llm + do j=1,jjm + do i=1,iip1 + flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ) + s +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ)) + enddo + enddo + enddo + enddo + + +c tendances +c --------- + +c convergence horizontale + call convflu(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ) + +c calcul de la vitesse verticale + call convmas(flux_u_cum,flux_v_cum,convm) + CALL vitvert(convm,w) + + do iQ=1,nQ + do l=1,llm-1 + do j=1,jjp1 + do i=1,iip1 + ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ)) + dQ(i,j,l ,iQ)=dQ(i,j,l ,iQ)-ww + dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww + enddo + enddo + enddo + enddo + IF (prt_level > 5) + . WRITE(lunout,*)'Apres les calculs fait a chaque pas' +c===================================================================== +c PAS DE TEMPS D'ECRITURE +c===================================================================== + if (icum.eq.ncum) then +c===================================================================== + + IF (prt_level > 5) + . WRITE(lunout,*)'Pas d ecriture' + +c Normalisation + do iQ=1,nQ + Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)/masse_cum(:,:,:) + enddo + zz=1./float(ncum) + ps_cum=ps_cum*zz + masse_cum=masse_cum*zz + flux_u_cum=flux_u_cum*zz + flux_v_cum=flux_v_cum*zz + flux_uQ_cum=flux_uQ_cum*zz + flux_vQ_cum=flux_vQ_cum*zz + dQ=dQ*zz + + +c A retravailler eventuellement +c division de dQ par la masse pour revenir aux bonnes grandeurs + do iQ=1,nQ + dQ(:,:,:,iQ)=dQ(:,:,:,iQ)/masse_cum(:,:,:) + enddo + +c===================================================================== +c Transport méridien +c===================================================================== + +c cumul zonal des masses des mailles +c ---------------------------------- + zv=0. + zmasse=0. + call massbar(masse_cum,massebx,masseby) + do l=1,llm + do j=1,jjm + do i=1,iim + zmasse(j,l)=zmasse(j,l)+masseby(i,j,l) + zv(j,l)=zv(j,l)+flux_v_cum(i,j,l) + enddo + zfactv(j,l)=cv(1,j)/zmasse(j,l) + enddo + enddo + +c print*,'3OK' +c -------------------------------------------------------------- +c calcul de la moyenne zonale du transport : +c ------------------------------------------ +c +c -- +c TOT : la circulation totale [ vq ] +c +c - - +c MMC : mean meridional circulation [ v ] [ q ] +c +c ---- -- - - +c TRS : transitoires [ v'q'] = [ vq ] - [ v q ] +c +c - * - * - - - - +c STT : stationaires [ v q ] = [ v q ] - [ v ] [ q ] +c +c - - +c on utilise aussi l'intermediaire TMP : [ v q ] +c +c la variable zfactv transforme un transport meridien cumule +c en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte +c +c -------------------------------------------------------------- + + +c ---------------------------------------- +c Transport dans le plan latitude-altitude +c ---------------------------------------- + + zvQ=0. + psiQ=0. + do iQ=1,nQ + zvQtmp=0. + do l=1,llm + do j=1,jjm +c print*,'j,l,iQ=',j,l,iQ +c Calcul des moyennes zonales du transort total et de zvQtmp + do i=1,iim + zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ) + s +flux_vQ_cum(i,j,l,iQ) + zqy= 0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+ + s Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l)) + zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy + s /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l))) + zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy + enddo +c print*,'aOK' +c Decomposition + zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l) + zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l) + zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l) + zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l) + zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l) + zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ) + enddo + enddo +c fonction de courant meridienne pour la quantite Q + do l=llm,1,-1 + do j=1,jjm + psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ) + enddo + enddo + enddo + +c fonction de courant pour la circulation meridienne moyenne + psi=0. + do l=llm,1,-1 + do j=1,jjm + psi(j,l)=psi(j,l+1)+zv(j,l) + zv(j,l)=zv(j,l)*zfactv(j,l) + enddo + enddo + +c print*,'4OK' +c sorties proprement dites + if (i_sortie.eq.1) then + do iQ=1,nQ + do itr=1,ntr + call histwrite(fileid,znom(itr,iQ),itau,zvQ(:,:,itr,iQ) + s ,jjm*llm,ndex3d) + enddo + call histwrite(fileid,'psi'//nom(iQ),itau,psiQ(:,1:llm,iQ) + s ,jjm*llm,ndex3d) + enddo + + call histwrite(fileid,'masse',itau,zmasse + s ,jjm*llm,ndex3d) + call histwrite(fileid,'v',itau,zv + s ,jjm*llm,ndex3d) + psi=psi*1.e-9 + call histwrite(fileid,'psi',itau,psi(:,1:llm),jjm*llm,ndex3d) + + endif + + +c ----------------- +c Moyenne verticale +c ----------------- + + zamasse=0. + do l=1,llm + zamasse(:)=zamasse(:)+zmasse(:,l) + enddo + zavQ=0. + do iQ=1,nQ + do itr=2,ntr + do l=1,llm + zavQ(:,itr,iQ)=zavQ(:,itr,iQ)+zvQ(:,l,itr,iQ)*zmasse(:,l) + enddo + zavQ(:,itr,iQ)=zavQ(:,itr,iQ)/zamasse(:) + call histwrite(fileid,'a'//znom(itr,iQ),itau,zavQ(:,itr,iQ) + s ,jjm*llm,ndex3d) + enddo + enddo + +c on doit pouvoir tracer systematiquement la fonction de courant. + +c===================================================================== +c///////////////////////////////////////////////////////////////////// + icum=0 !/////////////////////////////////////// + endif ! icum.eq.ncum !/////////////////////////////////////// +c///////////////////////////////////////////////////////////////////// +c===================================================================== + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/caladvtrac.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/caladvtrac.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/caladvtrac.F (revision 1280) @@ -0,0 +1,121 @@ +! +! $Header$ +! +c +c + SUBROUTINE caladvtrac(q,pbaru,pbarv , + * p ,masse, dq , teta, + * flxw, pk) +c + USE infotrac + IMPLICIT NONE +c +c Auteurs: F.Hourdin , P.Le Van, F.Forget, F.Codron +c +c F.Codron (10/99) : ajout humidite specifique pour eau vapeur +c======================================================================= +c +c Shema de Van Leer +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "control.h" + +c Arguments: +c ---------- + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm),masse(ip1jmp1,llm) + REAL p( ip1jmp1,llmp1),q( ip1jmp1,llm,nqtot),dq( ip1jmp1,llm,2 ) + REAL teta( ip1jmp1,llm),pk( ip1jmp1,llm) + REAL :: flxw(ip1jmp1,llm) + +c .................................................................. +c +c .. dq n'est utilise et dimensionne que pour l'eau vapeur et liqu. +c +c .................................................................. +c +c Local: +c ------ + + EXTERNAL advtrac,minmaxq, qminimum + INTEGER ij,l, iq, iapptrac + REAL finmasse(ip1jmp1,llm), dtvrtrac + +cc +c +C initialisation + dq = 0. + + CALL SCOPY( 2 * ijp1llm, q, 1, dq, 1 ) + +c test des valeurs minmax +cc CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur (a) ') +cc CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide(a) ') + +c advection + + CALL advtrac( pbaru,pbarv, + * p, masse,q,iapptrac, teta, + . flxw, pk) +c + + IF( iapptrac.EQ.iapp_tracvl ) THEN +c +cc CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur ') +cc CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide ') + +cc .... Calcul de deltap qu'on stocke dans finmasse ... +c + DO l = 1, llm + DO ij = 1, ip1jmp1 + finmasse(ij,l) = p(ij,l) - p(ij,l+1) + ENDDO + ENDDO + + if (planet_type.eq."earth") then +! Earth-specific treatment of first 2 tracers (water) + CALL qminimum( q, 2, finmasse ) + endif + + CALL SCOPY ( ip1jmp1*llm, masse, 1, finmasse, 1 ) + CALL filtreg ( finmasse , jjp1, llm, -2, 2, .TRUE., 1 ) +c +c ***** Calcul de dq pour l'eau , pour le passer a la physique ****** +c ******************************************************************** +c + dtvrtrac = iapp_tracvl * dtvr +c + DO iq = 1 , 2 + DO l = 1 , llm + DO ij = 1,ip1jmp1 + dq(ij,l,iq) = ( q(ij,l,iq) - dq(ij,l,iq) ) * finmasse(ij,l) + * / dtvrtrac + ENDDO + ENDDO + ENDDO +c + ELSE + DO iq = 1 , 2 + DO l = 1, llm + DO ij = 1,ip1jmp1 + dq(ij,l,iq) = 0. + ENDDO + ENDDO + ENDDO + + + ENDIF + +c + +c ... On appelle qminimum uniquement pour l'eau vapeur et liquide .. + + + RETURN + END + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/caldyn.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/caldyn.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/caldyn.F (revision 1280) @@ -0,0 +1,122 @@ +! +! $Header$ +! +c +c + SUBROUTINE caldyn + $ (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , + $ phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time ) + + IMPLICIT NONE + +c======================================================================= +c +c Auteur : P. Le Van +c +c Objet: +c ------ +c +c Calcul des tendances dynamiques. +c +c Modif 04/93 F.Forget +c======================================================================= + +c----------------------------------------------------------------------- +c 0. Declarations: +c ---------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + LOGICAL conser + + INTEGER itau + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL pk(iip1,jjp1,llm),pkf(ip1jmp1,llm) + REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL dv(ip1jm,llm),du(ip1jmp1,llm) + REAL dteta(ip1jmp1,llm),dp(ip1jmp1) + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL time + +c Local: +c ------ + + REAL ang(ip1jmp1,llm),p(ip1jmp1,llmp1) + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm) + REAL vorpot(ip1jm,llm) + REAL w(ip1jmp1,llm),ecin(ip1jmp1,llm),convm(ip1jmp1,llm) + REAL bern(ip1jmp1,llm) + REAL massebxy(ip1jm,llm) + + + INTEGER ij,l + +c----------------------------------------------------------------------- +c Calcul des tendances dynamiques: +c -------------------------------- + + CALL covcont ( llm , ucov , vcov , ucont, vcont ) + CALL pression ( ip1jmp1, ap , bp , ps , p ) + CALL psextbar ( ps , psexbarxy ) + CALL massdair ( p , masse ) + CALL massbar ( masse, massebx , masseby ) + call massbarxy( masse, massebxy ) + CALL flumass ( massebx, masseby , vcont, ucont ,pbaru, pbarv ) + CALL dteta1 ( teta , pbaru , pbarv, dteta ) + CALL convmas ( pbaru, pbarv , convm ) + + DO ij =1, ip1jmp1 + dp( ij ) = convm( ij,1 ) / airesurg( ij ) + ENDDO + + CALL vitvert ( convm , w ) + CALL tourpot ( vcov , ucov , massebxy , vorpot ) + CALL dudv1 ( vorpot , pbaru , pbarv , du , dv ) + CALL enercin ( vcov , ucov , vcont , ucont , ecin ) + CALL bernoui ( ip1jmp1, llm , phi , ecin , bern ) + CALL dudv2 ( teta , pkf , bern , du , dv ) + + + DO l=1,llm + DO ij=1,ip1jmp1 + ang(ij,l) = ucov(ij,l) + constang(ij) + ENDDO + ENDDO + + + CALL advect( ang, vcov, teta, w, massebx, masseby, du, dv,dteta ) + +C WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi +C probablement. Observe sur le code compile avec pgf90 3.0-1 + + DO l = 1, llm + DO ij = 1, ip1jm, iip1 + IF( dv(ij,l).NE.dv(ij+iim,l) ) THEN +c PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov', +c , ' dans caldyn' +c PRINT *,' l, ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l) + dv(ij+iim,l) = dv(ij,l) + endif + enddo + enddo +c----------------------------------------------------------------------- +c Sorties eventuelles des variables de controle: +c ---------------------------------------------- + + IF( conser ) THEN + CALL sortvarc + $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov ) + + ENDIF + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/caldyn0.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/caldyn0.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/caldyn0.F (revision 1280) @@ -0,0 +1,89 @@ +! +! $Header$ +! + SUBROUTINE caldyn0 + $ (itau,ucov,vcov,teta,ps,masse,pk,phis , + $ phi,w,pbaru,pbarv,time ) + + IMPLICIT NONE + +c======================================================================= +c +c Auteur : P. Le Van +c +c Objet: +c ------ +c +c Calcul des tendances dynamiques. +c +c Modif 04/93 F.Forget +c======================================================================= + +c----------------------------------------------------------------------- +c 0. Declarations: +c ---------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER itau + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL pk(iip1,jjp1,llm) + REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL time + +c Local: +c ------ + + REAL ang(ip1jmp1,llm),p(ip1jmp1,llmp1) + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm) + REAL vorpot(ip1jm,llm) + REAL w(ip1jmp1,llm),ecin(ip1jmp1,llm),convm(ip1jmp1,llm) + REAL bern(ip1jmp1,llm) + REAL massebxy(ip1jm,llm), dp(ip1jmp1) + + + INTEGER ij,l + +c----------------------------------------------------------------------- +c Calcul des tendances dynamiques: +c -------------------------------- + + CALL covcont ( llm , ucov , vcov , ucont, vcont ) + CALL pression ( ip1jmp1, ap , bp , ps , p ) + CALL psextbar ( ps , psexbarxy ) + CALL massdair ( p , masse ) + CALL massbar ( masse, massebx , masseby ) + CALL massbarxy( masse, massebxy ) + CALL flumass ( massebx, masseby , vcont, ucont ,pbaru, pbarv ) + CALL convmas ( pbaru, pbarv , convm ) + + DO ij =1, ip1jmp1 + dp( ij ) = convm( ij,1 ) / airesurg( ij ) + ENDDO + + CALL vitvert ( convm , w ) + CALL tourpot ( vcov , ucov , massebxy , vorpot ) + CALL enercin ( vcov , ucov , vcont , ucont , ecin ) + CALL bernoui ( ip1jmp1, llm , phi , ecin , bern ) + + DO l=1,llm + DO ij=1,ip1jmp1 + ang(ij,l) = ucov(ij,l) + constang(ij) + ENDDO + ENDDO + + CALL sortvarc0 + $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov ) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/calfis.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/calfis.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/calfis.F (revision 1280) @@ -0,0 +1,616 @@ +! +! $Id$ +! +C +C + SUBROUTINE calfis(lafin, + $ jD_cur, jH_cur, + $ pucov, + $ pvcov, + $ pteta, + $ pq, + $ pmasse, + $ pps, + $ pp, + $ ppk, + $ pphis, + $ pphi, + $ pducov, + $ pdvcov, + $ pdteta, + $ pdq, + $ flxw, + $ clesphy0, + $ pdufi, + $ pdvfi, + $ pdhfi, + $ pdqfi, + $ pdpsfi) +c +c Auteur : P. Le Van, F. Hourdin +c ......... + USE infotrac + + IMPLICIT NONE +c======================================================================= +c +c 1. rearrangement des tableaux et transformation +c variables dynamiques > variables physiques +c 2. calcul des termes physiques +c 3. retransformation des tendances physiques en tendances dynamiques +c +c remarques: +c ---------- +c +c - les vents sont donnes dans la physique par leurs composantes +c naturelles. +c - la variable thermodynamique de la physique est une variable +c intensive : T +c pour la dynamique on prend T * ( preff / p(l) ) **kappa +c - les deux seules variables dependant de la geometrie necessaires +c pour la physique sont la latitude pour le rayonnement et +c l'aire de la maille quand on veut integrer une grandeur +c horizontalement. +c - les points de la physique sont les points scalaires de la +c la dynamique; numerotation: +c 1 pour le pole nord +c (jjm-1)*iim pour l'interieur du domaine +c ngridmx pour le pole sud +c ---> ngridmx=2+(jjm-1)*iim +c +c Input : +c ------- +c pucov covariant zonal velocity +c pvcov covariant meridional velocity +c pteta potential temperature +c pps surface pressure +c pmasse masse d'air dans chaque maille +c pts surface temperature (K) +c callrad clef d'appel au rayonnement +c +c Output : +c -------- +c pdufi tendency for the natural zonal velocity (ms-1) +c pdvfi tendency for the natural meridional velocity +c pdhfi tendency for the potential temperature +c pdtsfi tendency for the surface temperature +c +c pdtrad radiative tendencies \ both input +c pfluxrad radiative fluxes / and output +c +c======================================================================= +c +c----------------------------------------------------------------------- +c +c 0. Declarations : +c ------------------ + +#include "dimensions.h" +#include "paramet.h" +#include "temps.h" + + INTEGER ngridmx + PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm ) + +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" +#include "control.h" + +c Arguments : +c ----------- + LOGICAL lafin + + + REAL pvcov(iip1,jjm,llm) + REAL pucov(iip1,jjp1,llm) + REAL pteta(iip1,jjp1,llm) + REAL pmasse(iip1,jjp1,llm) + REAL pq(iip1,jjp1,llm,nqtot) + REAL pphis(iip1,jjp1) + REAL pphi(iip1,jjp1,llm) +c + REAL pdvcov(iip1,jjm,llm) + REAL pducov(iip1,jjp1,llm) + REAL pdteta(iip1,jjp1,llm) + REAL pdq(iip1,jjp1,llm,nqtot) +c + REAL pps(iip1,jjp1) + REAL pp(iip1,jjp1,llmp1) + REAL ppk(iip1,jjp1,llm) +c + REAL pdvfi(iip1,jjm,llm) + REAL pdufi(iip1,jjp1,llm) + REAL pdhfi(iip1,jjp1,llm) + REAL pdqfi(iip1,jjp1,llm,nqtot) + REAL pdpsfi(iip1,jjp1) + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + + +c Local variables : +c ----------------- + + INTEGER i,j,l,ig0,ig,iq,iiq + REAL zpsrf(ngridmx) + REAL zplev(ngridmx,llm+1),zplay(ngridmx,llm) + REAL zphi(ngridmx,llm),zphis(ngridmx) +c + REAL zufi(ngridmx,llm), zvfi(ngridmx,llm) + REAL ztfi(ngridmx,llm),zqfi(ngridmx,llm,nqtot) +c + REAL pcvgu(ngridmx,llm), pcvgv(ngridmx,llm) + REAL pcvgt(ngridmx,llm), pcvgq(ngridmx,llm,2) +c + REAL zdufi(ngridmx,llm),zdvfi(ngridmx,llm) + REAL zdtfi(ngridmx,llm),zdqfi(ngridmx,llm,nqtot) + REAL zdpsrf(ngridmx) +c + REAL zsin(iim),zcos(iim),z1(iim) + REAL zsinbis(iim),zcosbis(iim),z1bis(iim) + REAL unskap, pksurcp +c +cIM diagnostique PVteta, Amip2 + INTEGER ntetaSTD + PARAMETER(ntetaSTD=3) + REAL rtetaSTD(ntetaSTD) + DATA rtetaSTD/350., 380., 405./ + REAL PVteta(ngridmx,ntetaSTD) +c + REAL flxw(iip1,jjp1,llm) ! Flux de masse verticale sur la grille dynamique + REAL flxwfi(ngridmx,llm) ! Flux de masse verticale sur la grille physiq +c + + REAL SSUM + + LOGICAL firstcal, debut + DATA firstcal/.true./ + SAVE firstcal,debut +! REAL rdayvrai + REAL, intent(in):: jD_cur, jH_cur +c +c----------------------------------------------------------------------- +c +c 1. Initialisations : +c -------------------- +c +c + IF ( firstcal ) THEN + debut = .TRUE. + IF (ngridmx.NE.2+(jjm-1)*iim) THEN + PRINT*,'STOP dans calfis' + PRINT*,'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim' + PRINT*,' ngridmx jjm iim ' + PRINT*,ngridmx,jjm,iim + STOP + ENDIF + ELSE + debut = .FALSE. + ENDIF ! of IF (firstcal) + +c +c +c----------------------------------------------------------------------- +c 40. transformation des variables dynamiques en variables physiques: +c --------------------------------------------------------------- + +c 41. pressions au sol (en Pascals) +c ---------------------------------- + + + zpsrf(1) = pps(1,1) + + ig0 = 2 + DO j = 2,jjm + CALL SCOPY( iim,pps(1,j),1,zpsrf(ig0), 1 ) + ig0 = ig0+iim + ENDDO + + zpsrf(ngridmx) = pps(1,jjp1) + + +c 42. pression intercouches : +c +c ----------------------------------------------------------------- +c .... zplev definis aux (llm +1) interfaces des couches .... +c .... zplay definis aux ( llm ) milieux des couches .... +c ----------------------------------------------------------------- + +c ... Exner = cp * ( p(l) / preff ) ** kappa .... +c + unskap = 1./ kappa +c + DO l = 1, llmp1 + zplev( 1,l ) = pp(1,1,l) + ig0 = 2 + DO j = 2, jjm + DO i =1, iim + zplev( ig0,l ) = pp(i,j,l) + ig0 = ig0 +1 + ENDDO + ENDDO + zplev( ngridmx,l ) = pp(1,jjp1,l) + ENDDO +c +c + +c 43. temperature naturelle (en K) et pressions milieux couches . +c --------------------------------------------------------------- + + DO l=1,llm + + pksurcp = ppk(1,1,l) / cpp + zplay(1,l) = preff * pksurcp ** unskap + ztfi(1,l) = pteta(1,1,l) * pksurcp + pcvgt(1,l) = pdteta(1,1,l) * pksurcp / pmasse(1,1,l) + ig0 = 2 + + DO j = 2, jjm + DO i = 1, iim + pksurcp = ppk(i,j,l) / cpp + zplay(ig0,l) = preff * pksurcp ** unskap + ztfi(ig0,l) = pteta(i,j,l) * pksurcp + pcvgt(ig0,l) = pdteta(i,j,l) * pksurcp / pmasse(i,j,l) + ig0 = ig0 + 1 + ENDDO + ENDDO + + pksurcp = ppk(1,jjp1,l) / cpp + zplay(ig0,l) = preff * pksurcp ** unskap + ztfi (ig0,l) = pteta(1,jjp1,l) * pksurcp + pcvgt(ig0,l) = pdteta(1,jjp1,l) * pksurcp/ pmasse(1,jjp1,l) + + ENDDO + +c 43.bis traceurs +c --------------- +c + DO iq=1,nqtot + iiq=niadv(iq) + DO l=1,llm + zqfi(1,l,iq) = pq(1,1,l,iiq) + ig0 = 2 + DO j=2,jjm + DO i = 1, iim + zqfi(ig0,l,iq) = pq(i,j,l,iiq) + ig0 = ig0 + 1 + ENDDO + ENDDO + zqfi(ig0,l,iq) = pq(1,jjp1,l,iiq) + ENDDO + ENDDO + +c convergence dynamique pour les traceurs "EAU" +! Earth-specific treatment of first 2 tracers (water) + if (planet_type=="earth") then + DO iq=1,2 + DO l=1,llm + pcvgq(1,l,iq)= pdq(1,1,l,iq) / pmasse(1,1,l) + ig0 = 2 + DO j=2,jjm + DO i = 1, iim + pcvgq(ig0,l,iq) = pdq(i,j,l,iq) / pmasse(i,j,l) + ig0 = ig0 + 1 + ENDDO + ENDDO + pcvgq(ig0,l,iq)= pdq(1,jjp1,l,iq) / pmasse(1,jjp1,l) + ENDDO + ENDDO + endif ! of if (planet_type=="earth") + + +c Geopotentiel calcule par rapport a la surface locale: +c ----------------------------------------------------- + + CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,pphi,zphi) + CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,pphis,zphis) + DO l=1,llm + DO ig=1,ngridmx + zphi(ig,l)=zphi(ig,l)-zphis(ig) + ENDDO + ENDDO + +c .... Calcul de la vitesse verticale ( en Pa*m*s ou Kg/s ) .... +c JG : ancien calcule de omega utilise dans physiq.F. Maintenant le flux +c de masse est calclue dans advtrac.F +c DO l=1,llm +c pvervel(1,l)=pw(1,1,l) * g /apoln +c ig0=2 +c DO j=2,jjm +c DO i = 1, iim +c pvervel(ig0,l) = pw(i,j,l) * g * unsaire(i,j) +c ig0 = ig0 + 1 +c ENDDO +c ENDDO +c pvervel(ig0,l)=pw(1,jjp1,l) * g /apols +c ENDDO + +c +c 45. champ u: +c ------------ + + DO 50 l=1,llm + + DO 25 j=2,jjm + ig0 = 1+(j-2)*iim + zufi(ig0+1,l)= 0.5 * + $ ( pucov(iim,j,l)/cu(iim,j) + pucov(1,j,l)/cu(1,j) ) + pcvgu(ig0+1,l)= 0.5 * + $ ( pducov(iim,j,l)/cu(iim,j) + pducov(1,j,l)/cu(1,j) ) + DO 10 i=2,iim + zufi(ig0+i,l)= 0.5 * + $ ( pucov(i-1,j,l)/cu(i-1,j) + pucov(i,j,l)/cu(i,j) ) + pcvgu(ig0+i,l)= 0.5 * + $ ( pducov(i-1,j,l)/cu(i-1,j) + pducov(i,j,l)/cu(i,j) ) +10 CONTINUE +25 CONTINUE + +50 CONTINUE + + +c 46.champ v: +c ----------- + + DO l=1,llm + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim + zvfi(ig0+i,l)= 0.5 * + $ ( pvcov(i,j-1,l)/cv(i,j-1) + pvcov(i,j,l)/cv(i,j) ) + pcvgv(ig0+i,l)= 0.5 * + $ ( pdvcov(i,j-1,l)/cv(i,j-1) + pdvcov(i,j,l)/cv(i,j) ) + ENDDO + ENDDO + ENDDO + + +c 47. champs de vents aux pole nord +c ------------------------------ +c U = 1 / pi * integrale [ v * cos(long) * d long ] +c V = 1 / pi * integrale [ v * sin(long) * d long ] + + DO l=1,llm + + z1(1) =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1) + z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,1,l)/cv(1,1) + DO i=2,iim + z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1) + z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,1,l)/cv(i,1) + ENDDO + + DO i=1,iim + zcos(i) = COS(rlonv(i))*z1(i) + zcosbis(i)= COS(rlonv(i))*z1bis(i) + zsin(i) = SIN(rlonv(i))*z1(i) + zsinbis(i)= SIN(rlonv(i))*z1bis(i) + ENDDO + + zufi(1,l) = SSUM(iim,zcos,1)/pi + pcvgu(1,l) = SSUM(iim,zcosbis,1)/pi + zvfi(1,l) = SSUM(iim,zsin,1)/pi + pcvgv(1,l) = SSUM(iim,zsinbis,1)/pi + + ENDDO + + +c 48. champs de vents aux pole sud: +c --------------------------------- +c U = 1 / pi * integrale [ v * cos(long) * d long ] +c V = 1 / pi * integrale [ v * sin(long) * d long ] + + DO l=1,llm + + z1(1) =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm) + z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,jjm,l)/cv(1,jjm) + DO i=2,iim + z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm) + z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,jjm,l)/cv(i,jjm) + ENDDO + + DO i=1,iim + zcos(i) = COS(rlonv(i))*z1(i) + zcosbis(i) = COS(rlonv(i))*z1bis(i) + zsin(i) = SIN(rlonv(i))*z1(i) + zsinbis(i) = SIN(rlonv(i))*z1bis(i) + ENDDO + + zufi(ngridmx,l) = SSUM(iim,zcos,1)/pi + pcvgu(ngridmx,l) = SSUM(iim,zcosbis,1)/pi + zvfi(ngridmx,l) = SSUM(iim,zsin,1)/pi + pcvgv(ngridmx,l) = SSUM(iim,zsinbis,1)/pi + + ENDDO +c + if (planet_type=="earth") then +#ifdef CPP_EARTH +cIM calcul PV a teta=350, 380, 405K + CALL PVtheta(ngridmx,llm,pucov,pvcov,pteta, + $ ztfi,zplay,zplev, + $ ntetaSTD,rtetaSTD,PVteta) +#endif + endif +c +c On change de grille, dynamique vers physiq, pour le flux de masse verticale + CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,flxw,flxwfi) + +c----------------------------------------------------------------------- +c Appel de la physique: +c --------------------- + + + if (planet_type=="earth") then +#ifdef CPP_EARTH + CALL physiq (ngridmx, + . llm, + . debut, + . lafin, + . jD_cur, + . jH_cur, + . dtphys, + . zplev, + . zplay, + . zphi, + . zphis, + . presnivs, + . clesphy0, + . zufi, + . zvfi, + . ztfi, + . zqfi, + . flxwfi, + . zdufi, + . zdvfi, + . zdtfi, + . zdqfi, + . zdpsrf, +cIM diagnostique PVteta, Amip2 + . pducov, + . PVteta) +#endif + endif !of if (planet_type=="earth") + +500 CONTINUE + +c----------------------------------------------------------------------- +c transformation des tendances physiques en tendances dynamiques: +c --------------------------------------------------------------- + +c tendance sur la pression : +c ----------------------------------- + + CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,zdpsrf,pdpsfi) +c +c 62. enthalpie potentielle +c --------------------- + + DO l=1,llm + + DO i=1,iip1 + pdhfi(i,1,l) = cpp * zdtfi(1,l) / ppk(i, 1 ,l) + pdhfi(i,jjp1,l) = cpp * zdtfi(ngridmx,l)/ ppk(i,jjp1,l) + ENDDO + + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim + pdhfi(i,j,l) = cpp * zdtfi(ig0+i,l) / ppk(i,j,l) + ENDDO + pdhfi(iip1,j,l) = pdhfi(1,j,l) + ENDDO + + ENDDO + + +c 62. humidite specifique +c --------------------- +! Ehouarn: removed this useless bit: was overwritten at step 63 anyways +! DO iq=1,nqtot +! DO l=1,llm +! DO i=1,iip1 +! pdqfi(i,1,l,iq) = zdqfi(1,l,iq) +! pdqfi(i,jjp1,l,iq) = zdqfi(ngridmx,l,iq) +! ENDDO +! DO j=2,jjm +! ig0=1+(j-2)*iim +! DO i=1,iim +! pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,iq) +! ENDDO +! pdqfi(iip1,j,l,iq) = pdqfi(1,j,l,iq) +! ENDDO +! ENDDO +! ENDDO + +c 63. traceurs +c ------------ +C initialisation des tendances + pdqfi(:,:,:,:)=0. +C + DO iq=1,nqtot + iiq=niadv(iq) + DO l=1,llm + DO i=1,iip1 + pdqfi(i,1,l,iiq) = zdqfi(1,l,iq) + pdqfi(i,jjp1,l,iiq) = zdqfi(ngridmx,l,iq) + ENDDO + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim + pdqfi(i,j,l,iiq) = zdqfi(ig0+i,l,iq) + ENDDO + pdqfi(iip1,j,l,iiq) = pdqfi(1,j,l,iq) + ENDDO + ENDDO + ENDDO + +c 65. champ u: +c ------------ + + DO l=1,llm + + DO i=1,iip1 + pdufi(i,1,l) = 0. + pdufi(i,jjp1,l) = 0. + ENDDO + + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim-1 + pdufi(i,j,l)= + $ 0.5*(zdufi(ig0+i,l)+zdufi(ig0+i+1,l))*cu(i,j) + ENDDO + pdufi(iim,j,l)= + $ 0.5*(zdufi(ig0+1,l)+zdufi(ig0+iim,l))*cu(iim,j) + pdufi(iip1,j,l)=pdufi(1,j,l) + ENDDO + + ENDDO + + +c 67. champ v: +c ------------ + + DO l=1,llm + + DO j=2,jjm-1 + ig0=1+(j-2)*iim + DO i=1,iim + pdvfi(i,j,l)= + $ 0.5*(zdvfi(ig0+i,l)+zdvfi(ig0+i+iim,l))*cv(i,j) + ENDDO + pdvfi(iip1,j,l) = pdvfi(1,j,l) + ENDDO + ENDDO + + +c 68. champ v pres des poles: +c --------------------------- +c v = U * cos(long) + V * SIN(long) + + DO l=1,llm + + DO i=1,iim + pdvfi(i,1,l)= + $ zdufi(1,l)*COS(rlonv(i))+zdvfi(1,l)*SIN(rlonv(i)) + pdvfi(i,jjm,l)=zdufi(ngridmx,l)*COS(rlonv(i)) + $ +zdvfi(ngridmx,l)*SIN(rlonv(i)) + pdvfi(i,1,l)= + $ 0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1) + pdvfi(i,jjm,l)= + $ 0.5*(pdvfi(i,jjm,l)+zdvfi(ngridmx-iip1+i,l))*cv(i,jjm) + ENDDO + + pdvfi(iip1,1,l) = pdvfi(1,1,l) + pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l) + + ENDDO + +c----------------------------------------------------------------------- + +700 CONTINUE + + firstcal = .FALSE. + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/clesph0.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/clesph0.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/clesph0.h (revision 1280) @@ -0,0 +1,11 @@ +! +! $Header$ +! +c..include clesph0.h +c + COMMON/clesph0/cycle_diurne, soil_model,new_oliq, ok_orodr , + , ok_orolf ,ok_limitvrai, nbapp_rad, iflag_con +c + LOGICAL cycle_diurne,soil_model,ok_orodr,ok_orolf,new_oliq + LOGICAL ok_limitvrai + INTEGER nbapp_rad, iflag_con Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/coefpoly.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/coefpoly.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/coefpoly.F (revision 1280) @@ -0,0 +1,40 @@ +! +! $Header$ +! + SUBROUTINE coefpoly ( Xf1, Xf2, Xprim1, Xprim2, xtild1,xtild2 , + , a0,a1,a2,a3 ) + IMPLICIT NONE +c +c ... Auteur : P. Le Van ... +c +c +c Calcul des coefficients a0, a1, a2, a3 du polynome de degre 3 qui +c satisfait aux 4 equations suivantes : + +c a0 + a1*xtild1 + a2*xtild1*xtild1 + a3*xtild1*xtild1*xtild1 = Xf1 +c a0 + a1*xtild2 + a2*xtild2*xtild2 + a3*xtild2*xtild2*xtild2 = Xf2 +c a1 + 2.*a2*xtild1 + 3.*a3*xtild1*xtild1 = Xprim1 +c a1 + 2.*a2*xtild2 + 3.*a3*xtild2*xtild2 = Xprim2 + +c On en revient a resoudre un systeme de 4 equat.a 4 inconnues a0,a1,a2,a3 + + REAL(KIND=8) Xf1, Xf2,Xprim1,Xprim2, xtild1,xtild2, xi + REAL(KIND=8) Xfout, Xprim + REAL(KIND=8) a1,a2,a3,a0, xtil1car, xtil2car,derr,x1x2car + + xtil1car = xtild1 * xtild1 + xtil2car = xtild2 * xtild2 + + derr= 2. *(Xf2-Xf1)/( xtild1-xtild2) + + x1x2car = ( xtild1-xtild2)*(xtild1-xtild2) + + a3 = (derr + Xprim1+Xprim2 )/x1x2car + a2 = ( Xprim1 - Xprim2 + 3.* a3 * ( xtil2car-xtil1car ) ) / + / ( 2.* ( xtild1 - xtild2 ) ) + + a1 = Xprim1 -3.* a3 * xtil1car -2.* a2 * xtild1 + a0 = Xf1 - a3 * xtild1* xtil1car -a2 * xtil1car - a1 *xtild1 + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/com_io_dyn.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/com_io_dyn.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/com_io_dyn.h (revision 1280) @@ -0,0 +1,5 @@ +! +! $Header$ +! + integer histid, histvid, histaveid + common/com_io_dyn/histid, histvid, histaveid Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comconst.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comconst.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comconst.h (revision 1280) @@ -0,0 +1,23 @@ +! +! $Id$ +! +!----------------------------------------------------------------------- +! INCLUDE comconst.h + + COMMON/comconst/im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl, & + & dtvr,daysec, & + & pi,dtphys,dtdiss,rad,r,cpp,kappa,cotot,unsim,g,omeg & + & ,dissip_factz,dissip_deltaz,dissip_zref & + & ,iflag_top_bound,tau_top_bound + + + INTEGER im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl + REAL dtvr,daysec + REAL pi,dtphys,dtdiss,rad,r,cpp,kappa + REAL cotot,unsim,g,omeg + REAL dissip_factz,dissip_deltaz,dissip_zref + INTEGER iflag_top_bound + REAL tau_top_bound + + +!----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comdissip.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comdissip.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comdissip.h (revision 1280) @@ -0,0 +1,15 @@ +! +! $Header$ +! +!----------------------------------------------------------------------- +! INCLUDE comdissip.h + + COMMON/comdissip/ & + & niterdis,coefdis,tetavel,tetatemp,gamdissip + + + INTEGER niterdis + + REAL tetavel,tetatemp,coefdis,gamdissip + +!----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comdissipn.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comdissipn.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comdissipn.h (revision 1280) @@ -0,0 +1,16 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c INCLUDE comdissipn.h + + REAL tetaudiv, tetaurot, tetah, cdivu, crot, cdivh +c + COMMON/comdissipn/ tetaudiv(llm),tetaurot(llm),tetah(llm) , + 1 cdivu, crot, cdivh + +c +c Les parametres de ce common proviennent des calculs effectues dans +c Inidissip . +c +c----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comdissnew.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comdissnew.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comdissnew.h (revision 1280) @@ -0,0 +1,18 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c INCLUDE comdissnew.h + + COMMON/comdissnew/ lstardis,nitergdiv,nitergrot,niterh,tetagdiv, + 1 tetagrot,tetatemp,coefdis + + LOGICAL lstardis + INTEGER nitergdiv, nitergrot, niterh + REAL tetagdiv, tetagrot, tetatemp, coefdis + +c +c ... Les parametres de ce common comdissnew sont lues par defrun_new +c sur le fichier run.def .... +c +c----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comgeom.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comgeom.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comgeom.h (revision 1280) @@ -0,0 +1,33 @@ +! +! $Header$ +! +!CDK comgeom + COMMON/comgeom/ & + & cu(ip1jmp1),cv(ip1jm),unscu2(ip1jmp1),unscv2(ip1jm), & + & aire(ip1jmp1),airesurg(ip1jmp1),aireu(ip1jmp1), & + & airev(ip1jm),unsaire(ip1jmp1),apoln,apols, & + & unsairez(ip1jm),airuscv2(ip1jm),airvscu2(ip1jm), & + & aireij1(ip1jmp1),aireij2(ip1jmp1),aireij3(ip1jmp1), & + & aireij4(ip1jmp1),alpha1(ip1jmp1),alpha2(ip1jmp1), & + & alpha3(ip1jmp1),alpha4(ip1jmp1),alpha1p2(ip1jmp1), & + & alpha1p4(ip1jmp1),alpha2p3(ip1jmp1),alpha3p4(ip1jmp1), & + & fext(ip1jm),constang(ip1jmp1),rlatu(jjp1),rlatv(jjm), & + & rlonu(iip1),rlonv(iip1),cuvsurcv(ip1jm),cvsurcuv(ip1jm), & + & cvusurcu(ip1jmp1),cusurcvu(ip1jmp1),cuvscvgam1(ip1jm), & + & cuvscvgam2(ip1jm),cvuscugam1(ip1jmp1), & + & cvuscugam2(ip1jmp1),cvscuvgam(ip1jm),cuscvugam(ip1jmp1), & + & unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2, & + & unsair_gam1(ip1jmp1),unsair_gam2(ip1jmp1),unsairz_gam(ip1jm), & + & aivscu2gam(ip1jm),aiuscv2gam(ip1jm),xprimu(iip1),xprimv(iip1) + +! + REAL & + & cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,unsaire,apoln ,& + & apols,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4,& + & alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 ,& + & fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2 ,& + & cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1,unsapolnga2& + & ,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2,unsairz_gam ,& + & aivscu2gam ,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu,cusurcvu,xprimu& + & , xprimv +! Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comgeom2.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comgeom2.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comgeom2.h (revision 1280) @@ -0,0 +1,33 @@ +! +! $Header$ +! +!CDK comgeom2 + COMMON/comgeom/ & + & cu(iip1,jjp1),cv(iip1,jjm),unscu2(iip1,jjp1),unscv2(iip1,jjm) , & + & aire(iip1,jjp1),airesurg(iip1,jjp1),aireu(iip1,jjp1) , & + & airev(iip1,jjm),unsaire(iip1,jjp1),apoln,apols , & + & unsairez(iip1,jjm),airuscv2(iip1,jjm),airvscu2(iip1,jjm) , & + & aireij1(iip1,jjp1),aireij2(iip1,jjp1),aireij3(iip1,jjp1) , & + & aireij4(iip1,jjp1),alpha1(iip1,jjp1),alpha2(iip1,jjp1) , & + & alpha3(iip1,jjp1),alpha4(iip1,jjp1),alpha1p2(iip1,jjp1) , & + & alpha1p4(iip1,jjp1),alpha2p3(iip1,jjp1),alpha3p4(iip1,jjp1) , & + & fext(iip1,jjm),constang(iip1,jjp1), rlatu(jjp1),rlatv(jjm), & + & rlonu(iip1),rlonv(iip1),cuvsurcv(iip1,jjm),cvsurcuv(iip1,jjm) , & + & cvusurcu(iip1,jjp1),cusurcvu(iip1,jjp1) , & + & cuvscvgam1(iip1,jjm),cuvscvgam2(iip1,jjm),cvuscugam1(iip1,jjp1), & + & cvuscugam2(iip1,jjp1),cvscuvgam(iip1,jjm),cuscvugam(iip1,jjp1) , & + & unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2 , & + & unsair_gam1(iip1,jjp1),unsair_gam2(iip1,jjp1) , & + & unsairz_gam(iip1,jjm),aivscu2gam(iip1,jjm),aiuscv2gam(iip1,jjm) & + & , xprimu(iip1),xprimv(iip1) + + + REAL & + & cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,apoln,apols,unsaire & + & ,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4 , & + & alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 , & + & fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2 , & + & cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1 , & + & unsapolnga2,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2 , & + & unsairz_gam,aivscu2gam,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu , & + & cusurcvu,xprimu,xprimv Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comvert.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comvert.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/comvert.h (revision 1280) @@ -0,0 +1,12 @@ +! +! $Id$ +! +!----------------------------------------------------------------------- +! INCLUDE 'comvert.h' + + COMMON/comvert/ap(llm+1),bp(llm+1),presnivs(llm),dpres(llm), & + & pa,preff,nivsigs(llm),nivsig(llm+1) + + REAL ap,bp,presnivs,dpres,pa,preff,nivsigs,nivsig + + !----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/conf_dat2d.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/conf_dat2d.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/conf_dat2d.F (revision 1280) @@ -0,0 +1,221 @@ +! +! $Header$ +! +C +C + SUBROUTINE conf_dat2d( title,lons,lats,xd,yd,xf,yf,champd , + , interbar ) +c +c Auteur : P. Le Van + +c Ce s-pr. configure le champ de donnees 2D 'champd' de telle facon que +c qu'on ait - pi a pi en longitude +c et qu'on ait pi/2. a - pi/2. en latitude +c +c xd et yd sont les longitudes et latitudes initiales +c xf et yf sont les longitudes et latitudes en sortie , eventuellement +c modifiees pour etre configurees comme ci-dessus . + + IMPLICIT NONE + +c *** Arguments en entree *** + INTEGER lons,lats + CHARACTER*25 title + REAL xd(lons),yd(lats) + LOGICAL interbar +c +c *** Arguments en sortie *** + REAL xf(lons),yf(lats) +c +c *** Arguments en entree et sortie *** + REAL champd(lons,lats) + +c *** Variables locales *** +c + REAL pi,pis2,depi + LOGICAL radianlon, invlon ,radianlat, invlat, alloc + REAL rlatmin,rlatmax,oldxd1 + INTEGER i,j,ip180,ind + + REAL, ALLOCATABLE :: xtemp(:) + REAL, ALLOCATABLE :: ytemp(:) + REAL, ALLOCATABLE :: champf(:,:) + +c +c WRITE(6,*) ' conf_dat2d pour la variable ', title + + ALLOCATE( xtemp(lons) ) + ALLOCATE( ytemp(lats) ) + ALLOCATE( champf(lons,lats) ) + + DO i = 1, lons + xtemp(i) = xd(i) + ENDDO + DO j = 1, lats + ytemp(j) = yd(j) + ENDDO + + pi = 2. * ASIN(1.) + pis2 = pi/2. + depi = 2. * pi + + radianlon = .FALSE. + IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 ) THEN + radianlon = .TRUE. + invlon = .FALSE. + ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN + radianlon = .TRUE. + invlon = .TRUE. + ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 ) THEN + radianlon = .FALSE. + invlon = .FALSE. + ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 ) THEN + radianlon = .FALSE. + invlon = .TRUE. + ELSE + WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier' + , , title + ENDIF + + invlat = .FALSE. + + IF( ytemp(1).LT.ytemp(lats) ) THEN + invlat = .TRUE. + ENDIF + + rlatmin = MIN( ytemp(1), ytemp(lats) ) + rlatmax = MAX( ytemp(1), ytemp(lats) ) + + IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN + radianlat = .TRUE. + ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN + radianlat = .FALSE. + ELSE + WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier' + , , title + ENDIF + + IF( .NOT. radianlon ) THEN + DO i = 1, lons + xtemp(i) = xtemp(i) * pi/180. + ENDDO + ENDIF + + IF( .NOT. radianlat ) THEN + DO j = 1, lats + ytemp(j) = ytemp(j) * pi/180. + ENDDO + ENDIF + + + IF ( invlon ) THEN + + DO j = 1, lats + DO i = 1,lons + champf(i,j) = champd(i,j) + ENDDO + ENDDO + + DO i = 1 ,lons + xf(i) = xtemp(i) + ENDDO +c +c *** On tourne les longit. pour avoir - pi a + pi **** +c + DO i=1,lons + IF( xf(i).GT. pi ) THEN + GO TO 88 + ENDIF + ENDDO + +88 CONTINUE +c + ip180 = i + + DO i = 1,lons + IF (xf(i).GT. pi) THEN + xf(i) = xf(i) - depi + ENDIF + ENDDO + + DO i= ip180,lons + ind = i-ip180 +1 + xtemp(ind) = xf(i) + ENDDO + + DO i= ind +1,lons + xtemp(i) = xf(i-ind) + ENDDO + +c ..... on tourne les longitudes pour champf .... +c + DO j = 1,lats + + DO i = ip180,lons + ind = i-ip180 +1 + champd (ind,j) = champf (i,j) + ENDDO + + DO i= ind +1,lons + champd (i,j) = champf (i-ind,j) + ENDDO + + ENDDO + + + ENDIF +c +c ***** fin de IF(invlon) **** + + IF ( invlat ) THEN + + DO j = 1,lats + yf(j) = ytemp(j) + ENDDO + + DO j = 1, lats + DO i = 1,lons + champf(i,j) = champd(i,j) + ENDDO + ENDDO + + DO j = 1, lats + ytemp( lats-j+1 ) = yf(j) + DO i = 1, lons + champd (i,lats-j+1) = champf (i,j) + ENDDO + ENDDO + + + ENDIF + +c ***** fin de IF(invlat) **** + +c + IF( interbar ) THEN + oldxd1 = xtemp(1) + DO i = 1, lons -1 + xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) ) + ENDDO + xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi ) + + DO j = 1, lats -1 + ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) ) + ENDDO + + ENDIF +c + DEALLOCATE(champf) + + DO i = 1, lons + xf(i) = xtemp(i) + ENDDO + DO j = 1, lats + yf(j) = ytemp(j) + ENDDO + + deallocate(xtemp) + deallocate(ytemp) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/conf_dat3d.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/conf_dat3d.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/conf_dat3d.F (revision 1280) @@ -0,0 +1,296 @@ +! +! $Header$ +! +C +C + SUBROUTINE conf_dat3d( title, lons,lats,levs,xd,yd,zd,xf,yf,zf, + , champd , interbar ) +c +c Auteur : P. Le Van +c +c Ce s-pr. configure le champ de donnees 3D 'champd' de telle facon +c qu'on ait - pi a pi en longitude +c qu'on ait pi/2. a - pi/2. en latitude +c et qu'on ait les niveaux verticaux variant du sol vers le ht de l'atmos. +c ( en Pascals ) . +c +c xd et yd sont les longitudes et latitudes initiales +c zd les pressions initiales +c +c xf et yf sont les longitudes et latitudes en sortie , eventuellement +c modifiees pour etre configurees comme ci-dessus . +c zf les pressions en sortie +c +c champd en meme temps le champ initial et final +c +c interbar = .TRUE. si on appelle l'interpo. barycentrique inter_barxy +c sinon , l'interpolation grille_m ( grid_atob ) . +c + + IMPLICIT NONE + +c *** Arguments en entree *** + CHARACTER*(*) :: title + INTEGER lons, lats, levs + REAL xd(lons), yd(lats), zd(levs) + LOGICAL interbar +c +c *** Arguments en sortie *** + REAL xf(lons), yf(lats), zf(levs) + +c *** Arguments en entree et sortie *** + REAL champd(lons,lats,levs) + +c *** Variables locales *** +c + REAL pi,pis2,depi,presmax + LOGICAL radianlon, invlon ,radianlat, invlat, invlev, alloc + REAL rlatmin,rlatmax,oldxd1 + INTEGER i,j,ip180,ind,l + + REAL, ALLOCATABLE :: xtemp(:) + REAL, ALLOCATABLE :: ytemp(:) + REAL, ALLOCATABLE :: ztemp(:) + REAL, ALLOCATABLE :: champf(:,:,:) + + +c WRITE(6,*) ' Conf_dat3d pour ',title + + ALLOCATE(xtemp(lons)) + ALLOCATE(ytemp(lats)) + ALLOCATE(ztemp(levs)) + + DO i = 1, lons + xtemp(i) = xd(i) + ENDDO + DO j = 1, lats + ytemp(j) = yd(j) + ENDDO + DO l = 1, levs + ztemp(l) = zd(l) + ENDDO + + pi = 2. * ASIN(1.) + pis2 = pi/2. + depi = 2. * pi + + IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 ) THEN + radianlon = .TRUE. + invlon = .FALSE. + ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN + radianlon = .TRUE. + invlon = .TRUE. + ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 ) THEN + radianlon = .FALSE. + invlon = .FALSE. + ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 ) THEN + radianlon = .FALSE. + invlon = .TRUE. + ELSE + WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier' + , , title + ENDIF + + invlat = .FALSE. + + IF( ytemp(1).LT.ytemp(lats) ) THEN + invlat = .TRUE. + ENDIF + + rlatmin = MIN( ytemp(1), ytemp(lats) ) + rlatmax = MAX( ytemp(1), ytemp(lats) ) + + IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN + radianlat = .TRUE. + ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN + radianlat = .FALSE. + ELSE + WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier' + , , title + ENDIF + + IF( .NOT. radianlon ) THEN + DO i = 1, lons + xtemp(i) = xtemp(i) * pi/180. + ENDDO + ENDIF + + IF( .NOT. radianlat ) THEN + DO j = 1, lats + ytemp(j) = ytemp(j) * pi/180. + ENDDO + ENDIF + + + alloc =.FALSE. + + IF ( invlon ) THEN + + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + + DO i = 1 ,lons + xf(i) = xtemp(i) + ENDDO + + DO l = 1, levs + DO j = 1, lats + DO i= 1, lons + champf (i,j,l) = champd (i,j,l) + ENDDO + ENDDO + ENDDO +c +c *** On tourne les longit. pour avoir - pi a + pi **** +c + DO i=1,lons + IF( xf(i).GT. pi ) THEN + GO TO 88 + ENDIF + ENDDO + +88 CONTINUE +c + ip180 = i + + DO i = 1,lons + IF (xf(i).GT. pi) THEN + xf(i) = xf(i) - depi + ENDIF + ENDDO + + DO i= ip180,lons + ind = i-ip180 +1 + xtemp(ind) = xf(i) + ENDDO + + DO i= ind +1,lons + xtemp(i) = xf(i-ind) + ENDDO + +c ..... on tourne les longitudes pour champf .... +c + DO l = 1,levs + DO j = 1,lats + DO i = ip180,lons + ind = i-ip180 +1 + champd (ind,j,l) = champf (i,j,l) + ENDDO + + DO i= ind +1,lons + champd (i,j,l) = champf (i-ind,j,l) + ENDDO + ENDDO + ENDDO + + ENDIF +c +c ***** fin de IF(invlon) **** + + IF ( invlat ) THEN + + IF(.NOT.alloc) THEN + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + ENDIF + + DO j = 1, lats + yf(j) = ytemp(j) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champf(i,j,l) = champd(i,j,l) + ENDDO + ENDDO + + DO j = 1, lats + ytemp( lats-j+1 ) = yf(j) + DO i = 1, lons + champd (i,lats-j+1,l) = champf (i,j,l) + ENDDO + ENDDO + ENDDO + + + ENDIF + +c ***** fin de IF(invlat) **** +c +c + IF( interbar ) THEN + oldxd1 = xtemp(1) + DO i = 1, lons -1 + xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) ) + ENDDO + xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi ) + + DO j = 1, lats -1 + ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) ) + ENDDO + ENDIF +c + + invlev = .FALSE. + IF( ztemp(1).LT.ztemp(levs) ) invlev = .TRUE. + + presmax = MAX( ztemp(1), ztemp(levs) ) + IF( presmax.LT.1200. ) THEN + DO l = 1,levs + ztemp(l) = ztemp(l) * 100. + ENDDO + ENDIF + + IF( invlev ) THEN + + IF(.NOT.alloc) THEN + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + ENDIF + + DO l = 1,levs + zf(l) = ztemp(l) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champf(i,j,l) = champd(i,j,l) + ENDDO + ENDDO + ENDDO + + DO l = 1,levs + ztemp(levs+1-l) = zf(l) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champd(i,j,levs+1-l) = champf(i,j,l) + ENDDO + ENDDO + ENDDO + + + ENDIF + + IF(alloc) DEALLOCATE(champf) + + DO i = 1, lons + xf(i) = xtemp(i) + ENDDO + DO j = 1, lats + yf(j) = ytemp(j) + ENDDO + DO l = 1, levs + zf(l) = ztemp(l) + ENDDO + + DEALLOCATE(xtemp) + DEALLOCATE(ytemp) + DEALLOCATE(ztemp) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/conf_gcm.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/conf_gcm.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/conf_gcm.F (revision 1280) @@ -0,0 +1,813 @@ +! +! $Id$ +! +c +c + SUBROUTINE conf_gcm( tapedef, etatinit, clesphy0 ) +c +#ifdef CPP_IOIPSL + use IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + use ioipsl_getincom +#endif + IMPLICIT NONE +c----------------------------------------------------------------------- +c Auteurs : L. Fairhead , P. Le Van . +c +c Arguments : +c +c tapedef : +c etatinit : = TRUE , on ne compare pas les valeurs des para- +c -metres du zoom avec celles lues sur le fichier start . +c clesphy0 : sortie . +c + LOGICAL etatinit + INTEGER tapedef + + INTEGER longcles + PARAMETER( longcles = 20 ) + REAL clesphy0( longcles ) +c +c Declarations : +c -------------- +#include "dimensions.h" +#include "paramet.h" +#include "control.h" +#include "logic.h" +#include "serre.h" +#include "comdissnew.h" +#include "temps.h" +#include "comconst.h" + +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +! #include "clesphys.h" +#include "iniprint.h" +c +c +c local: +c ------ + + CHARACTER ch1*72,ch2*72,ch3*72,ch4*12 + REAL clonn,clatt,grossismxx,grossismyy + REAL dzoomxx,dzoomyy, tauxx,tauyy + LOGICAL fxyhypbb, ysinuss + INTEGER i + +c +c ------------------------------------------------------------------- +c +c ......... Version du 29/04/97 .......... +c +c Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot, +c tetatemp ajoutes pour la dissipation . +c +c Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** +c +c Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb. +c Sinon , choix de fxynew , a derivee sinusoidale .. +c +c ...... etatinit = . TRUE. si defrun est appele dans ETAT0_LMD ou +c LIMIT_LMD pour l'initialisation de start.dat (dic) et +c de limit.dat ( dic) ........... +c Sinon etatinit = . FALSE . +c +c Donc etatinit = .F. si on veut comparer les valeurs de grossismx , +c grossismy,clon,clat, fxyhypb lues sur le fichier start avec +c celles passees par run.def , au debut du gcm, apres l'appel a +c lectba . +c Ces parmetres definissant entre autres la grille et doivent etre +c pareils et coherents , sinon il y aura divergence du gcm . +c +c----------------------------------------------------------------------- +c initialisations: +c ---------------- + +!Config Key = lunout +!Config Desc = unite de fichier pour les impressions +!Config Def = 6 +!Config Help = unite de fichier pour les impressions +!Config (defaut sortie standard = 6) + lunout=6 + CALL getin('lunout', lunout) + IF (lunout /= 5 .and. lunout /= 6) THEN + OPEN(lunout,FILE='lmdz.out') + ENDIF + +!Config Key = prt_level +!Config Desc = niveau d'impressions de débogage +!Config Def = 0 +!Config Help = Niveau d'impression pour le débogage +!Config (0 = minimum d'impression) + prt_level = 0 + CALL getin('prt_level',prt_level) + +c----------------------------------------------------------------------- +c Parametres de controle du run: +c----------------------------------------------------------------------- +!Config Key = planet_type +!Config Desc = planet type ("earth", "mars", "venus", ...) +!Config Def = earth +!Config Help = this flag sets the type of atymosphere that is considered + planet_type="earth" + CALL getin('planet_type',planet_type) + +!Config Key = calend +!Config Desc = type de calendrier utilise +!Config Def = earth_360d +!Config Help = valeur possible: earth_360d, earth_365d, earth_366d +!Config + calend = 'earth_360d' + CALL getin('calend', calend) + +!Config Key = dayref +!Config Desc = Jour de l'etat initial +!Config Def = 1 +!Config Help = Jour de l'etat initial ( = 350 si 20 Decembre , +!Config par expl. ,comme ici ) ... A completer + dayref=1 + CALL getin('dayref', dayref) + +!Config Key = anneeref +!Config Desc = Annee de l'etat initial +!Config Def = 1998 +!Config Help = Annee de l'etat initial +!Config ( avec 4 chiffres ) ... A completer + anneeref = 1998 + CALL getin('anneeref',anneeref) + +!Config Key = raz_date +!Config Desc = Remise a zero de la date initiale +!Config Def = 0 (pas de remise a zero) +!Config Help = Remise a zero de la date initiale +!Config 0 pas de remise a zero, on garde la date du fichier restart +!Config 1 prise en compte de la date de gcm.def avec remise a zero +!Config des compteurs de pas de temps + raz_date = 0 + CALL getin('raz_date', raz_date) + +!Config Key = nday +!Config Desc = Nombre de jours d'integration +!Config Def = 10 +!Config Help = Nombre de jours d'integration +!Config ... On pourait aussi permettre des mois ou des annees ! + nday = 10 + CALL getin('nday',nday) + +!Config Key = day_step +!Config Desc = nombre de pas par jour +!Config Def = 240 +!Config Help = nombre de pas par jour (multiple de iperiod) ( +!Config ici pour dt = 1 min ) + day_step = 240 + CALL getin('day_step',day_step) + +!Config Key = iperiod +!Config Desc = periode pour le pas Matsuno +!Config Def = 5 +!Config Help = periode pour le pas Matsuno (en pas de temps) + iperiod = 5 + CALL getin('iperiod',iperiod) + +!Config Key = iapp_tracvl +!Config Desc = frequence du groupement des flux +!Config Def = iperiod +!Config Help = frequence du groupement des flux (en pas de temps) + iapp_tracvl = iperiod + CALL getin('iapp_tracvl',iapp_tracvl) + +!Config Key = iconser +!Config Desc = periode de sortie des variables de controle +!Config Def = 240 +!Config Help = periode de sortie des variables de controle +!Config (En pas de temps) + iconser = 240 + CALL getin('iconser', iconser) + +!Config Key = iecri +!Config Desc = periode d'ecriture du fichier histoire +!Config Def = 1 +!Config Help = periode d'ecriture du fichier histoire (en jour) + iecri = 1 + CALL getin('iecri',iecri) + + +!Config Key = periodav +!Config Desc = periode de stockage fichier histmoy +!Config Def = 1 +!Config Help = periode de stockage fichier histmoy (en jour) + periodav = 1. + CALL getin('periodav',periodav) + +!Config Key = output_grads_dyn +!Config Desc = output dynamics diagnostics in 'dyn.dat' file +!Config Def = n +!Config Help = output dynamics diagnostics in Grads-readable 'dyn.dat' file + output_grads_dyn=.false. + CALL getin('output_grads_dyn',output_grads_dyn) + +!Config Key = idissip +!Config Desc = periode de la dissipation +!Config Def = 10 +!Config Help = periode de la dissipation +!Config (en pas) ... a completer ! + idissip = 10 + CALL getin('idissip',idissip) + +ccc .... P. Le Van , modif le 29/04/97 .pour la dissipation ... +ccc + +!Config Key = lstardis +!Config Desc = choix de l'operateur de dissipation +!Config Def = y +!Config Help = choix de l'operateur de dissipation +!Config 'y' si on veut star et 'n' si on veut non-start ! +!Config Moi y en a pas comprendre ! + lstardis = .TRUE. + CALL getin('lstardis',lstardis) + + +!Config Key = nitergdiv +!Config Desc = Nombre d'iteration de gradiv +!Config Def = 1 +!Config Help = nombre d'iterations de l'operateur de dissipation +!Config gradiv + nitergdiv = 1 + CALL getin('nitergdiv',nitergdiv) + +!Config Key = nitergrot +!Config Desc = nombre d'iterations de nxgradrot +!Config Def = 2 +!Config Help = nombre d'iterations de l'operateur de dissipation +!Config nxgradrot + nitergrot = 2 + CALL getin('nitergrot',nitergrot) + + +!Config Key = niterh +!Config Desc = nombre d'iterations de divgrad +!Config Def = 2 +!Config Help = nombre d'iterations de l'operateur de dissipation +!Config divgrad + niterh = 2 + CALL getin('niterh',niterh) + + +!Config Key = tetagdiv +!Config Desc = temps de dissipation pour div +!Config Def = 7200 +!Config Help = temps de dissipation des plus petites longeur +!Config d'ondes pour u,v (gradiv) + tetagdiv = 7200. + CALL getin('tetagdiv',tetagdiv) + +!Config Key = tetagrot +!Config Desc = temps de dissipation pour grad +!Config Def = 7200 +!Config Help = temps de dissipation des plus petites longeur +!Config d'ondes pour u,v (nxgradrot) + tetagrot = 7200. + CALL getin('tetagrot',tetagrot) + +!Config Key = tetatemp +!Config Desc = temps de dissipation pour h +!Config Def = 7200 +!Config Help = temps de dissipation des plus petites longeur +!Config d'ondes pour h (divgrad) + tetatemp = 7200. + CALL getin('tetatemp',tetatemp ) + +! Parametres controlant la variation sur la verticale des constantes de +! dissipation. +! Pour le moment actifs uniquement dans la version a 39 niveaux +! avec ok_strato=y + + dissip_factz=4. + dissip_deltaz=10. + dissip_zref=30. + CALL getin('dissip_factz',dissip_factz ) + CALL getin('dissip_deltaz',dissip_deltaz ) + CALL getin('dissip_zref',dissip_zref ) + + iflag_top_bound=1 + tau_top_bound=1.e-5 + CALL getin('iflag_top_bound',iflag_top_bound) + CALL getin('tau_top_bound',tau_top_bound) + +!Config Key = coefdis +!Config Desc = coefficient pour gamdissip +!Config Def = 0 +!Config Help = coefficient pour gamdissip + coefdis = 0. + CALL getin('coefdis',coefdis) + +!Config Key = purmats +!Config Desc = Schema d'integration +!Config Def = n +!Config Help = Choix du schema d'integration temporel. +!Config y = pure Matsuno sinon c'est du Matsuno-leapfrog + purmats = .FALSE. + CALL getin('purmats',purmats) + +!Config Key = ok_guide +!Config Desc = Guidage +!Config Def = n +!Config Help = Guidage + ok_guide = .FALSE. + CALL getin('ok_guide',ok_guide) + +c ............................................................... + +!Config Key = read_start +!Config Desc = Initialize model using a 'start.nc' file +!Config Def = y +!Config Help = y: intialize dynamical fields using a 'start.nc' file +! n: fields are initialized by 'iniacademic' routine + read_start= .true. + CALL getin('read_start',read_start) + +!Config Key = iflag_phys +!Config Desc = Avec ls physique +!Config Def = 1 +!Config Help = Permet de faire tourner le modele sans +!Config physique. + iflag_phys = 1 + CALL getin('iflag_phys',iflag_phys) + + +!Config Key = iphysiq +!Config Desc = Periode de la physique +!Config Def = 5 +!Config Help = Periode de la physique en pas de temps de la dynamique. + iphysiq = 5 + CALL getin('iphysiq', iphysiq) + +!Config Key = ip_ebil_dyn +!Config Desc = PRINT level for energy conserv. diag. +!Config Def = 0 +!Config Help = PRINT level for energy conservation diag. ; +! les options suivantes existent : +!Config 0 pas de print +!Config 1 pas de print +!Config 2 print, + ip_ebil_dyn = 0 + CALL getin('ip_ebil_dyn',ip_ebil_dyn) +! + + DO i = 1, longcles + clesphy0(i) = 0. + ENDDO + +ccc .... P. Le Van , ajout le 7/03/95 .pour le zoom ... +c ......... ( modif le 17/04/96 ) ......... +c + IF( etatinit ) GO TO 100 + +!Config Key = clon +!Config Desc = centre du zoom, longitude +!Config Def = 0 +!Config Help = longitude en degres du centre +!Config du zoom + clonn = 0. + CALL getin('clon',clonn) + +!Config Key = clat +!Config Desc = centre du zoom, latitude +!Config Def = 0 +!Config Help = latitude en degres du centre du zoom +!Config + clatt = 0. + CALL getin('clat',clatt) + +c +c + IF( ABS(clat - clatt).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de clat passee par run.def', + & ' est differente de celle lue sur le fichier start ' + STOP + ENDIF + +!Config Key = grossismx +!Config Desc = zoom en longitude +!Config Def = 1.0 +!Config Help = facteur de grossissement du zoom, +!Config selon la longitude + grossismxx = 1.0 + CALL getin('grossismx',grossismxx) + + + IF( ABS(grossismx - grossismxx).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de grossismx passee par ', + & 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + +!Config Key = grossismy +!Config Desc = zoom en latitude +!Config Def = 1.0 +!Config Help = facteur de grossissement du zoom, +!Config selon la latitude + grossismyy = 1.0 + CALL getin('grossismy',grossismyy) + + IF( ABS(grossismy - grossismyy).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de grossismy passee par ', + & 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + + IF( grossismx.LT.1. ) THEN + write(lunout,*) + & 'conf_gcm: *** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + + IF( grossismy.LT.1. ) THEN + write(lunout,*) + & 'conf_gcm: *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + + write(lunout,*)'conf_gcm: alphax alphay',alphax,alphay +c +c alphax et alphay sont les anciennes formulat. des grossissements +c +c + +!Config Key = fxyhypb +!Config Desc = Fonction hyperbolique +!Config Def = y +!Config Help = Fonction f(y) hyperbolique si = .true. +!Config sinon sinusoidale + fxyhypbb = .TRUE. + CALL getin('fxyhypb',fxyhypbb) + + IF( .NOT.fxyhypb ) THEN + IF( fxyhypbb ) THEN + write(lunout,*)' ******** PBS DANS CONF_GCM ******** ' + write(lunout,*)' *** fxyhypb lu sur le fichier start est ', + * 'F alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.fxyhypbb ) THEN + write(lunout,*)' ******** PBS DANS CONF_GCM ******** ' + write(lunout,*)' *** fxyhypb lu sur le fichier start est ', + * 'T alors qu il est F sur run.def **** ' + STOP + ENDIF + ENDIF +c +!Config Key = dzoomx +!Config Desc = extension en longitude +!Config Def = 0 +!Config Help = extension en longitude de la zone du zoom +!Config ( fraction de la zone totale) + dzoomxx = 0.0 + CALL getin('dzoomx',dzoomxx) + + IF( fxyhypb ) THEN + IF( ABS(dzoomx - dzoomxx).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de dzoomx passee par ', + * 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + ENDIF + +!Config Key = dzoomy +!Config Desc = extension en latitude +!Config Def = 0 +!Config Help = extension en latitude de la zone du zoom +!Config ( fraction de la zone totale) + dzoomyy = 0.0 + CALL getin('dzoomy',dzoomyy) + + IF( fxyhypb ) THEN + IF( ABS(dzoomy - dzoomyy).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de dzoomy passee par ', + * 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + ENDIF + +!Config Key = taux +!Config Desc = raideur du zoom en X +!Config Def = 3 +!Config Help = raideur du zoom en X + tauxx = 3.0 + CALL getin('taux',tauxx) + + IF( fxyhypb ) THEN + IF( ABS(taux - tauxx).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de taux passee par ', + * 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + ENDIF + +!Config Key = tauyy +!Config Desc = raideur du zoom en Y +!Config Def = 3 +!Config Help = raideur du zoom en Y + tauyy = 3.0 + CALL getin('tauy',tauyy) + + IF( fxyhypb ) THEN + IF( ABS(tauy - tauyy).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de tauy passee par ', + * 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + ENDIF + +cc + IF( .NOT.fxyhypb ) THEN + +!Config Key = ysinus +!Config IF = !fxyhypb +!Config Desc = Fonction en Sinus +!Config Def = y +!Config Help = Fonction f(y) avec y = Sin(latit.) si = .true. +!Config sinon y = latit. + ysinuss = .TRUE. + CALL getin('ysinus',ysinuss) + + IF( .NOT.ysinus ) THEN + IF( ysinuss ) THEN + write(lunout,*)' ******** PBS DANS CONF_GCM ******** ' + write(lunout,*)' *** ysinus lu sur le fichier start est F', + * ' alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.ysinuss ) THEN + write(lunout,*)' ******** PBS DANS CONF_GCM ******** ' + write(lunout,*)' *** ysinus lu sur le fichier start est T', + * ' alors qu il est F sur run.def **** ' + STOP + ENDIF + ENDIF + ENDIF ! of IF( .NOT.fxyhypb ) +c +!Config Key = offline +!Config Desc = Nouvelle eau liquide +!Config Def = n +!Config Help = Permet de mettre en route la +!Config nouvelle parametrisation de l'eau liquide ! + offline = .FALSE. + CALL getin('offline',offline) + +!Config Key = config_inca +!Config Desc = Choix de configuration de INCA +!Config Def = none +!Config Help = Choix de configuration de INCA : +!Config 'none' = sans INCA +!Config 'chem' = INCA avec calcul de chemie +!Config 'aero' = INCA avec calcul des aerosols + config_inca = 'none' + CALL getin('config_inca',config_inca) + + +!Config Key = ok_dynzon +!Config Desc = calcul et sortie des transports +!Config Def = n +!Config Help = Permet de mettre en route le calcul des transports +!Config + ok_dynzon = .FALSE. + CALL getin('ok_dynzon',ok_dynzon) + + write(lunout,*)' #########################################' + write(lunout,*)' Configuration des parametres du gcm: ' + write(lunout,*)' planet_type = ', planet_type + write(lunout,*)' calend = ', calend + write(lunout,*)' dayref = ', dayref + write(lunout,*)' anneeref = ', anneeref + write(lunout,*)' nday = ', nday + write(lunout,*)' day_step = ', day_step + write(lunout,*)' iperiod = ', iperiod + write(lunout,*)' iconser = ', iconser + write(lunout,*)' iecri = ', iecri + write(lunout,*)' periodav = ', periodav + write(lunout,*)' output_grads_dyn = ', output_grads_dyn + write(lunout,*)' idissip = ', idissip + write(lunout,*)' lstardis = ', lstardis + write(lunout,*)' nitergdiv = ', nitergdiv + write(lunout,*)' nitergrot = ', nitergrot + write(lunout,*)' niterh = ', niterh + write(lunout,*)' tetagdiv = ', tetagdiv + write(lunout,*)' tetagrot = ', tetagrot + write(lunout,*)' tetatemp = ', tetatemp + write(lunout,*)' coefdis = ', coefdis + write(lunout,*)' purmats = ', purmats + write(lunout,*)' read_start = ', read_start + write(lunout,*)' iflag_phys = ', iflag_phys + write(lunout,*)' iphysiq = ', iphysiq + write(lunout,*)' clonn = ', clonn + write(lunout,*)' clatt = ', clatt + write(lunout,*)' grossismx = ', grossismx + write(lunout,*)' grossismy = ', grossismy + write(lunout,*)' fxyhypbb = ', fxyhypbb + write(lunout,*)' dzoomxx = ', dzoomxx + write(lunout,*)' dzoomy = ', dzoomyy + write(lunout,*)' tauxx = ', tauxx + write(lunout,*)' tauyy = ', tauyy + write(lunout,*)' offline = ', offline + write(lunout,*)' config_inca = ', config_inca + write(lunout,*)' ok_dynzon = ', ok_dynzon + + RETURN +c ............................................... +c +100 CONTINUE +!Config Key = clon +!Config Desc = centre du zoom, longitude +!Config Def = 0 +!Config Help = longitude en degres du centre +!Config du zoom + clon = 0. + CALL getin('clon',clon) + +!Config Key = clat +!Config Desc = centre du zoom, latitude +!Config Def = 0 +!Config Help = latitude en degres du centre du zoom +!Config + clat = 0. + CALL getin('clat',clat) + +!Config Key = grossismx +!Config Desc = zoom en longitude +!Config Def = 1.0 +!Config Help = facteur de grossissement du zoom, +!Config selon la longitude + grossismx = 1.0 + CALL getin('grossismx',grossismx) + +!Config Key = grossismy +!Config Desc = zoom en latitude +!Config Def = 1.0 +!Config Help = facteur de grossissement du zoom, +!Config selon la latitude + grossismy = 1.0 + CALL getin('grossismy',grossismy) + + IF( grossismx.LT.1. ) THEN + write(lunout,*) + & 'conf_gcm: *** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + + IF( grossismy.LT.1. ) THEN + write(lunout,*) + & 'conf_gcm: *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + + write(lunout,*)'conf_gcm: alphax alphay ',alphax,alphay +c +c alphax et alphay sont les anciennes formulat. des grossissements +c +c + +!Config Key = fxyhypb +!Config Desc = Fonction hyperbolique +!Config Def = y +!Config Help = Fonction f(y) hyperbolique si = .true. +!Config sinon sinusoidale + fxyhypb = .TRUE. + CALL getin('fxyhypb',fxyhypb) + +!Config Key = dzoomx +!Config Desc = extension en longitude +!Config Def = 0 +!Config Help = extension en longitude de la zone du zoom +!Config ( fraction de la zone totale) + dzoomx = 0.0 + CALL getin('dzoomx',dzoomx) + +!Config Key = dzoomy +!Config Desc = extension en latitude +!Config Def = 0 +!Config Help = extension en latitude de la zone du zoom +!Config ( fraction de la zone totale) + dzoomy = 0.0 + CALL getin('dzoomy',dzoomy) + +!Config Key = taux +!Config Desc = raideur du zoom en X +!Config Def = 3 +!Config Help = raideur du zoom en X + taux = 3.0 + CALL getin('taux',taux) + +!Config Key = tauy +!Config Desc = raideur du zoom en Y +!Config Def = 3 +!Config Help = raideur du zoom en Y + tauy = 3.0 + CALL getin('tauy',tauy) + +!Config Key = ysinus +!Config IF = !fxyhypb +!Config Desc = Fonction en Sinus +!Config Def = y +!Config Help = Fonction f(y) avec y = Sin(latit.) si = .true. +!Config sinon y = latit. + ysinus = .TRUE. + CALL getin('ysinus',ysinus) +c +!Config Key = offline +!Config Desc = Nouvelle eau liquide +!Config Def = n +!Config Help = Permet de mettre en route la +!Config nouvelle parametrisation de l'eau liquide ! + offline = .FALSE. + CALL getin('offline',offline) + +!Config Key = config_inca +!Config Desc = Choix de configuration de INCA +!Config Def = none +!Config Help = Choix de configuration de INCA : +!Config 'none' = sans INCA +!Config 'chem' = INCA avec calcul de chemie +!Config 'aero' = INCA avec calcul des aerosols + config_inca = 'none' + CALL getin('config_inca',config_inca) + +!Config Key = ok_dynzon +!Config Desc = calcul et sortie des transports +!Config Def = n +!Config Help = Permet de mettre en route le calcul des transports +!Config + ok_dynzon = .FALSE. + CALL getin('ok_dynzon',ok_dynzon) + +!Config key = ok_strato +!Config Desc = activation de la version strato +!Config Def = .FALSE. +!Config Help = active la version stratosphérique de LMDZ de F. Lott + + ok_strato=.FALSE. + CALL getin('ok_strato',ok_strato) + +!Config Key = ok_gradsfile +!Config Desc = activation des sorties grads du guidage +!Config Def = n +!Config Help = active les sorties grads du guidage + + ok_gradsfile = .FALSE. + CALL getin('ok_gradsfile',ok_gradsfile) + + write(lunout,*)' #########################################' + write(lunout,*)' Configuration des parametres du gcm: ' + write(lunout,*)' planet_type = ', planet_type + write(lunout,*)' calend = ', calend + write(lunout,*)' dayref = ', dayref + write(lunout,*)' anneeref = ', anneeref + write(lunout,*)' nday = ', nday + write(lunout,*)' day_step = ', day_step + write(lunout,*)' iperiod = ', iperiod + write(lunout,*)' iconser = ', iconser + write(lunout,*)' iecri = ', iecri + write(lunout,*)' periodav = ', periodav + write(lunout,*)' output_grads_dyn = ', output_grads_dyn + write(lunout,*)' idissip = ', idissip + write(lunout,*)' lstardis = ', lstardis + write(lunout,*)' nitergdiv = ', nitergdiv + write(lunout,*)' nitergrot = ', nitergrot + write(lunout,*)' niterh = ', niterh + write(lunout,*)' tetagdiv = ', tetagdiv + write(lunout,*)' tetagrot = ', tetagrot + write(lunout,*)' tetatemp = ', tetatemp + write(lunout,*)' coefdis = ', coefdis + write(lunout,*)' purmats = ', purmats + write(lunout,*)' read_start = ', read_start + write(lunout,*)' iflag_phys = ', iflag_phys + write(lunout,*)' iphysiq = ', iphysiq + write(lunout,*)' clon = ', clon + write(lunout,*)' clat = ', clat + write(lunout,*)' grossismx = ', grossismx + write(lunout,*)' grossismy = ', grossismy + write(lunout,*)' fxyhypb = ', fxyhypb + write(lunout,*)' dzoomx = ', dzoomx + write(lunout,*)' dzoomy = ', dzoomy + write(lunout,*)' taux = ', taux + write(lunout,*)' tauy = ', tauy + write(lunout,*)' offline = ', offline + write(lunout,*)' config_inca = ', config_inca + write(lunout,*)' ok_dynzon = ', ok_dynzon + write(lunout,*)' ok_strato = ', ok_strato + write(lunout,*)' ok_gradsfile = ', ok_gradsfile +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/control.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/control.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/control.h (revision 1280) @@ -0,0 +1,29 @@ +! +! $Header$ +! +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez à n'utiliser que des ! pour les commentaires +! et à bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +!----------------------------------------------------------------------- +! INCLUDE 'control.h' + + COMMON/control/nday,day_step, & + & iperiod,iapp_tracvl,iconser,iecri,idissip,iphysiq , & + & periodav,iecrimoy,dayref,anneeref, & + & raz_date,offline,ip_ebil_dyn,config_inca, & + & planet_type,output_grads_dyn,ok_dynzon + + INTEGER nday,day_step,iperiod,iapp_tracvl,iconser,iecri, & + & idissip,iphysiq,iecrimoy,dayref,anneeref, raz_date & + & ,ip_ebil_dyn + REAL periodav + LOGICAL offline + CHARACTER (len=4) :: config_inca + CHARACTER(len=10) :: planet_type ! planet type ('earth','mars',...) + LOGICAL :: output_grads_dyn ! output dynamics diagnostics in + ! binary grads file 'dyn.dat' (y/n) + LOGICAL :: ok_dynzon +!----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/convflu.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/convflu.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/convflu.F (revision 1280) @@ -0,0 +1,62 @@ +! +! $Header$ +! + SUBROUTINE convflu( xflu,yflu,nbniv,convfl ) +c +c P. Le Van +c +c +c ******************************************************************* +c ... calcule la (convergence horiz. * aire locale)du flux ayant pour +c composantes xflu et yflu ,variables extensives . ...... +c ******************************************************************* +c xflu , yflu et nbniv sont des arguments d'entree pour le s-pg .. +c convfl est un argument de sortie pour le s-pg . +c +c njxflu est le nombre de lignes de latitude de xflu, +c ( = jjm ou jjp1 ) +c nbniv est le nombre de niveaux vert. de xflu et de yflu . +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + REAL xflu,yflu,convfl,convpn,convps + INTEGER l,ij,nbniv + DIMENSION xflu( ip1jmp1,nbniv ),yflu( ip1jm,nbniv ) , + * convfl( ip1jmp1,nbniv ) +c + REAL SSUM +c +c +#include "comgeom.h" +c + DO 5 l = 1,nbniv +c + DO 2 ij = iip2, ip1jm - 1 + convfl( ij + 1,l ) = xflu( ij,l ) - xflu( ij + 1,l ) + + * yflu(ij +1,l ) - yflu( ij -iim,l ) + 2 CONTINUE +c +c + +c .... correction pour convfl( 1,j,l) ...... +c .... convfl(1,j,l)= convfl(iip1,j,l) ... +c +CDIR$ IVDEP + DO 3 ij = iip2,ip1jm,iip1 + convfl( ij,l ) = convfl( ij + iim,l ) + 3 CONTINUE +c +c ...... calcul aux poles ....... +c + convpn = SSUM( iim, yflu( 1 ,l ), 1 ) + convps = - SSUM( iim, yflu( ip1jm-iim,l ), 1 ) + DO 4 ij = 1,iip1 + convfl( ij ,l ) = convpn * aire( ij ) / apoln + convfl( ij+ ip1jm,l ) = convps * aire( ij+ ip1jm) / apols + 4 CONTINUE +c + 5 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/convmas.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/convmas.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/convmas.F (revision 1280) @@ -0,0 +1,63 @@ +! +! $Header$ +! + SUBROUTINE convmas (pbaru, pbarv, convm ) +c + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************** +c .... calcul de la convergence du flux de masse aux niveaux p ... +c ******************************************************************** +c +c +c pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c ..... convm est un argument de sortie pour le s-pg .... +c +c le calcul se fait de haut en bas, +c la convergence de masse au niveau p(llm+1) est egale a 0. et +c n'est pas stockee dans le tableau convm . +c +c +c======================================================================= +c +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "logic.h" + + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ),convm( ip1jmp1,llm ) + INTEGER l,ij + + +c----------------------------------------------------------------------- +c .... calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ...... + + CALL convflu( pbaru, pbarv, llm, convm ) + +c----------------------------------------------------------------------- +c filtrage: +c --------- + + CALL filtreg( convm, jjp1, llm, 2, 2, .true., 1 ) + +c integration de la convergence de masse de haut en bas ...... + + DO l = llmm1, 1, -1 + DO ij = 1, ip1jmp1 + convm(ij,l) = convm(ij,l) + convm(ij,l+1) + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/coordij.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/coordij.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/coordij.F (revision 1280) @@ -0,0 +1,48 @@ +! +! $Header$ +! + SUBROUTINE coordij(lon,lat,ilon,jlat) + +c======================================================================= +c +c calcul des coordonnees i et j de la maille scalaire dans +c laquelle se trouve le point (lon,lat) en radian +c +c======================================================================= + + IMPLICIT NONE + REAL lon,lat + INTEGER ilon,jlat + INTEGER i,j + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "serre.h" + + real zlon,zlat + + zlon=lon*pi/180. + zlat=lat*pi/180. + + DO i=1,iim+1 + IF (rlonu(i).GT.zlon) THEN + ilon=i + GOTO 10 + ENDIF + ENDDO +10 CONTINUE + + j=0 + DO j=1,jjm + IF(rlatv(j).LT.zlat) THEN + jlat=j + GOTO 20 + ENDIF + ENDDO +20 CONTINUE + IF(j.EQ.0) j=jjm+1 + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/covcont.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/covcont.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/covcont.F (revision 1280) @@ -0,0 +1,43 @@ +! +! $Header$ +! + SUBROUTINE covcont (klevel,ucov, vcov, ucont, vcont ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c calcul des compos. contravariantes a partir des comp.covariantes +c ******************************************************************** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL ucov( ip1jmp1,klevel ), vcov( ip1jm,klevel ) + REAL ucont( ip1jmp1,klevel ), vcont( ip1jm,klevel ) + INTEGER l,ij + + + DO 10 l = 1,klevel + + DO 2 ij = iip2, ip1jm + ucont( ij,l ) = ucov( ij,l ) * unscu2( ij ) + 2 CONTINUE + + DO 4 ij = 1,ip1jm + vcont( ij,l ) = vcov( ij,l ) * unscv2( ij ) + 4 CONTINUE + + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/covnat.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/covnat.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/covnat.F (revision 1280) @@ -0,0 +1,49 @@ +! +! $Header$ +! + SUBROUTINE covnat (klevel,ucov, vcov, unat, vnat ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: F Hourdin Phu LeVan +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c calcul des compos. naturelles a partir des comp.covariantes +c ******************************************************************** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL ucov( ip1jmp1,klevel ), vcov( ip1jm,klevel ) + REAL unat( ip1jmp1,klevel ), vnat( ip1jm,klevel ) + INTEGER l,ij + + + DO l = 1,klevel + DO ij = 1, iip1 + unat (ij,l) =0. + END DO + + DO ij = iip2, ip1jm + unat( ij,l ) = ucov( ij,l ) / cu(ij) + ENDDO + DO ij = ip1jm+1, ip1jmp1 + unat (ij,l) =0. + END DO + + DO ij = 1,ip1jm + vnat( ij,l ) = vcov( ij,l ) / cv(ij) + ENDDO + + ENDDO + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/cray.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/cray.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/cray.F (revision 1280) @@ -0,0 +1,42 @@ +! +! $Header$ +! +#ifdef CRAY + SUBROUTINE riencray + END +#else + subroutine scopy(n,sx,incx,sy,incy) +c + IMPLICIT NONE +c + integer n,incx,incy,ix,iy,i + real sx((n-1)*incx+1),sy((n-1)*incy+1) +c + iy=1 + ix=1 + do 10 i=1,n + sy(iy)=sx(ix) + ix=ix+incx + iy=iy+incy +10 continue +c + return + end + + function ssum(n,sx,incx) +c + IMPLICIT NONE +c + integer n,incx,i,ix + real ssum,sx((n-1)*incx+1) +c + ssum=0. + ix=1 + do 10 i=1,n + ssum=ssum+sx(ix) + ix=ix+incx +10 continue +c + return + end +#endif Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/create_etat0_limit.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/create_etat0_limit.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/create_etat0_limit.F (revision 1280) @@ -0,0 +1,75 @@ +! +! $Id$ +! + PROGRAM create_etat0_limit +#ifdef CPP_EARTH +! This prog. is designed to work for Earth + USE dimphy + USE comgeomphy + USE infotrac +#ifdef CPP_IOIPSL + use ioipsl, only: ioconf_calendar +#endif + IMPLICIT NONE +c +c +c Programme d'appel a etat0, creation des etats initiaux et limit_netcdf +c +c +c interbar = .T . si appel a interpol. barycentrique inter_barxy +c +c extrap = .T . si on fait une extrapolation de donnees , comme pour +c les SST lorsque le fichier ne contient pas uniquement des points +c oceaniques . +c +c oldice = .T. si l'on veut garder les anciennes glaces , obtenues +c par grille_m ( grid_atob ) . +c +c on cree le masque dans etat0 que l'on passe ensuite dans limit pour +c garder les coherences + + LOGICAL interbar, extrap , oldice + PARAMETER ( interbar = .true. , extrap = .FALSE. , oldice=.false.) +#include "dimensions.h" +#include "paramet.h" +#include "indicesol.h" +#include "control.h" + REAL :: masque(iip1,jjp1) +! REAL :: pctsrf(iim*(jjm-1)+2, nbsrf) + + IF (config_inca /= 'none') THEN +#ifdef INCA + call init_const_lmdz( + $ nbtr,anneeref,dayref, + $ iphysiq, day_step,nday) +#endif + print *, 'nbtr =' , nbtr + END IF + + CALL Init_Phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/)) + PRINT *,'---> klon=',klon + call InitComgeomphy + +#ifdef CPP_IOIPSL + call ioconf_calendar('360d') +#endif + + WRITE(6,*) ' ********************* ' + WRITE(6,*) ' interbar = ',interbar + CALL etat0_netcdf ( interbar, masque ) +c + WRITE(6,1) + WRITE(6,*) ' ********************* ' + WRITE(6,*) ' *** Limit_netcdf *** ' + WRITE(6,*) ' ********************* ' + WRITE(6,1) + +c + CALL limit_netcdf ( interbar, extrap , oldice, masque) + +1 FORMAT(//) + +#endif +! of #ifdef CPP_EARTH + STOP + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/defrun.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/defrun.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/defrun.F (revision 1280) @@ -0,0 +1,495 @@ +! +! $Header$ +! +c +c + SUBROUTINE defrun( tapedef, etatinit, clesphy0 ) +c + IMPLICIT NONE +c----------------------------------------------------------------------- +c Auteurs : L. Fairhead , P. Le Van . +c +c Arguments : +c +c tapedef : +c etatinit : = TRUE , on ne compare pas les valeurs des para- +c -metres du zoom avec celles lues sur le fichier start . +c clesphy0 : sortie . +c + LOGICAL etatinit + INTEGER tapedef + + INTEGER longcles + PARAMETER( longcles = 20 ) + REAL clesphy0( longcles ) +c +c Declarations : +c -------------- +#include "dimensions.h" +#include "paramet.h" +#include "control.h" +#include "logic.h" +#include "serre.h" +#include "comdissnew.h" +#include "clesph0.h" +c +c +c local: +c ------ + + CHARACTER ch1*72,ch2*72,ch3*72,ch4*12 + INTEGER tapeout + REAL clonn,clatt,grossismxx,grossismyy + REAL dzoomxx,dzoomyy,tauxx,tauyy + LOGICAL fxyhypbb, ysinuss + INTEGER i + +c +c ------------------------------------------------------------------- +c +c ......... Version du 29/04/97 .......... +c +c Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot, +c tetatemp ajoutes pour la dissipation . +c +c Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** +c +c Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb. +c Sinon , choix de fxynew , a derivee sinusoidale .. +c +c ...... etatinit = . TRUE. si defrun est appele dans ETAT0_LMD ou +c LIMIT_LMD pour l'initialisation de start.dat (dic) et +c de limit.dat ( dic) ........... +c Sinon etatinit = . FALSE . +c +c Donc etatinit = .F. si on veut comparer les valeurs de grossismx , +c grossismy,clon,clat, fxyhypb lues sur le fichier start avec +c celles passees par run.def , au debut du gcm, apres l'appel a +c lectba . +c Ces parmetres definissant entre autres la grille et doivent etre +c pareils et coherents , sinon il y aura divergence du gcm . +c +c----------------------------------------------------------------------- +c initialisations: +c ---------------- + + tapeout = 6 + +c----------------------------------------------------------------------- +c Parametres de controle du run: +c----------------------------------------------------------------------- + + OPEN( tapedef,file ='gcm.def',status='old',form='formatted') + + + READ (tapedef,9000) ch1,ch2,ch3 + WRITE(tapeout,9000) ch1,ch2,ch3 + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dayref + WRITE(tapeout,9001) ch1,'dayref' + WRITE(tapeout,*) dayref + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) anneeref + WRITE(tapeout,9001) ch1,'anneeref' + WRITE(tapeout,*) anneeref + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nday + WRITE(tapeout,9001) ch1,'nday' + WRITE(tapeout,*) nday + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) day_step + WRITE(tapeout,9001) ch1,'day_step' + WRITE(tapeout,*) day_step + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iperiod + WRITE(tapeout,9001) ch1,'iperiod' + WRITE(tapeout,*) iperiod + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iapp_tracvl + WRITE(tapeout,9001) ch1,'iapp_tracvl' + WRITE(tapeout,*) iapp_tracvl + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iconser + WRITE(tapeout,9001) ch1,'iconser' + WRITE(tapeout,*) iconser + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iecri + WRITE(tapeout,9001) ch1,'iecri' + WRITE(tapeout,*) iecri + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) periodav + WRITE(tapeout,9001) ch1,'periodav' + WRITE(tapeout,*) periodav + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) idissip + WRITE(tapeout,9001) ch1,'idissip' + WRITE(tapeout,*) idissip + +ccc .... P. Le Van , modif le 29/04/97 .pour la dissipation ... +ccc + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) lstardis + WRITE(tapeout,9001) ch1,'lstardis' + WRITE(tapeout,*) lstardis + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nitergdiv + WRITE(tapeout,9001) ch1,'nitergdiv' + WRITE(tapeout,*) nitergdiv + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nitergrot + WRITE(tapeout,9001) ch1,'nitergrot' + WRITE(tapeout,*) nitergrot + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) niterh + WRITE(tapeout,9001) ch1,'niterh' + WRITE(tapeout,*) niterh + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tetagdiv + WRITE(tapeout,9001) ch1,'tetagdiv' + WRITE(tapeout,*) tetagdiv + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tetagrot + WRITE(tapeout,9001) ch1,'tetagrot' + WRITE(tapeout,*) tetagrot + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tetatemp + WRITE(tapeout,9001) ch1,'tetatemp' + WRITE(tapeout,*) tetatemp + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) coefdis + WRITE(tapeout,9001) ch1,'coefdis' + WRITE(tapeout,*) coefdis +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) purmats + WRITE(tapeout,9001) ch1,'purmats' + WRITE(tapeout,*) purmats + +c ............................................................... + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iflag_phys + WRITE(tapeout,9001) ch1,'iflag_phys' + WRITE(tapeout,*) iflag_phys + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iphysiq + WRITE(tapeout,9001) ch1,'iphysiq' + WRITE(tapeout,*) iphysiq + + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) cycle_diurne + WRITE(tapeout,9001) ch1,'cycle_diurne' + WRITE(tapeout,*) cycle_diurne + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) soil_model + WRITE(tapeout,9001) ch1,'soil_model' + WRITE(tapeout,*) soil_model + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) new_oliq + WRITE(tapeout,9001) ch1,'new_oliq' + WRITE(tapeout,*) new_oliq + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ok_orodr + WRITE(tapeout,9001) ch1,'ok_orodr' + WRITE(tapeout,*) ok_orodr + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ok_orolf + WRITE(tapeout,9001) ch1,'ok_orolf' + WRITE(tapeout,*) ok_orolf + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ok_limitvrai + WRITE(tapeout,9001) ch1,'ok_limitvrai' + WRITE(tapeout,*) ok_limitvrai + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nbapp_rad + WRITE(tapeout,9001) ch1,'nbapp_rad' + WRITE(tapeout,*) nbapp_rad + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iflag_con + WRITE(tapeout,9001) ch1,'iflag_con' + WRITE(tapeout,*) iflag_con + + DO i = 1, longcles + clesphy0(i) = 0. + ENDDO + clesphy0(1) = FLOAT( iflag_con ) + clesphy0(2) = FLOAT( nbapp_rad ) + + IF( cycle_diurne ) clesphy0(3) = 1. + IF( soil_model ) clesphy0(4) = 1. + IF( new_oliq ) clesphy0(5) = 1. + IF( ok_orodr ) clesphy0(6) = 1. + IF( ok_orolf ) clesphy0(7) = 1. + IF( ok_limitvrai ) clesphy0(8) = 1. + + +ccc .... P. Le Van , ajout le 7/03/95 .pour le zoom ... +c ......... ( modif le 17/04/96 ) ......... +c + IF( etatinit ) GO TO 100 + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clonn + WRITE(tapeout,9001) ch1,'clon' + WRITE(tapeout,*) clonn + IF( ABS(clon - clonn).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de clon passee par run.def est diffe + *rente de celle lue sur le fichier start ' + STOP + ENDIF +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clatt + WRITE(tapeout,9001) ch1,'clat' + WRITE(tapeout,*) clatt + + IF( ABS(clat - clatt).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de clat passee par run.def est diffe + *rente de celle lue sur le fichier start ' + STOP + ENDIF + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismxx + WRITE(tapeout,9001) ch1,'grossismx' + WRITE(tapeout,*) grossismxx + + IF( ABS(grossismx - grossismxx).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de grossismx passee par run.def est + , differente de celle lue sur le fichier start ' + STOP + ENDIF + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismyy + WRITE(tapeout,9001) ch1,'grossismy' + WRITE(tapeout,*) grossismyy + + IF( ABS(grossismy - grossismyy).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de grossismy passee par run.def est + , differente de celle lue sur le fichier start ' + STOP + ENDIF + + IF( grossismx.LT.1. ) THEN + WRITE(tapeout,*) ' *** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + + IF( grossismy.LT.1. ) THEN + WRITE(tapeout,*) ' *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + +c +c alphax et alphay sont les anciennes formulat. des grossissements +c +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) fxyhypbb + WRITE(tapeout,9001) ch1,'fxyhypbb' + WRITE(tapeout,*) fxyhypbb + + IF( .NOT.fxyhypb ) THEN + IF( fxyhypbb ) THEN + WRITE(tapeout,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est F' + *, ' alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.fxyhypbb ) THEN + WRITE(tapeout,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est t' + *, ' alors qu il est F sur run.def ***' + STOP + ENDIF + ENDIF +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomxx + WRITE(tapeout,9001) ch1,'dzoomx' + WRITE(tapeout,*) dzoomxx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomyy + WRITE(tapeout,9001) ch1,'dzoomy' + WRITE(tapeout,*) dzoomyy + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tauxx + WRITE(tapeout,9001) ch1,'taux' + WRITE(tapeout,*) tauxx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tauyy + WRITE(tapeout,9001) ch1,'tauy' + WRITE(tapeout,*) tauyy + + IF( fxyhypb ) THEN + + IF( ABS(dzoomx - dzoomxx).GE. 0.001 ) THEN + WRITE(tapeout,*)' La valeur de dzoomx passee par run.def est dif + *ferente de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + IF( ABS(dzoomy - dzoomyy).GE. 0.001 ) THEN + WRITE(tapeout,*)' La valeur de dzoomy passee par run.def est dif + *ferente de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + IF( ABS(taux - tauxx).GE. 0.001 ) THEN + WRITE(6,*)' La valeur de taux passee par run.def est differente + * de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + IF( ABS(tauy - tauyy).GE. 0.001 ) THEN + WRITE(6,*)' La valeur de tauy passee par run.def est differente + * de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + ENDIF + +cc + IF( .NOT.fxyhypb ) THEN + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ysinuss + WRITE(tapeout,9001) ch1,'ysinus' + WRITE(tapeout,*) ysinuss + + + IF( .NOT.ysinus ) THEN + IF( ysinuss ) THEN + WRITE(6,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)'** ysinus lu sur le fichier start est F', + * ' alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.ysinuss ) THEN + WRITE(6,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)'** ysinus lu sur le fichier start est T', + * ' alors qu il est F sur run.def ***' + STOP + ENDIF + ENDIF + ENDIF +c + WRITE(6,*) ' alphax alphay defrun ',alphax,alphay + + CLOSE(tapedef) + + RETURN +c ............................................... +c +100 CONTINUE +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clon + WRITE(tapeout,9001) ch1,'clon' + WRITE(tapeout,*) clon +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clat + WRITE(tapeout,9001) ch1,'clat' + WRITE(tapeout,*) clat + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismx + WRITE(tapeout,9001) ch1,'grossismx' + WRITE(tapeout,*) grossismx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismy + WRITE(tapeout,9001) ch1,'grossismy' + WRITE(tapeout,*) grossismy + + IF( grossismx.LT.1. ) THEN + WRITE(tapeout,*) '*** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + IF( grossismy.LT.1. ) THEN + WRITE(tapeout,*) ' *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) fxyhypb + WRITE(tapeout,9001) ch1,'fxyhypb' + WRITE(tapeout,*) fxyhypb + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomx + WRITE(tapeout,9001) ch1,'dzoomx' + WRITE(tapeout,*) dzoomx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomy + WRITE(tapeout,9001) ch1,'dzoomy' + WRITE(tapeout,*) dzoomy + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) taux + WRITE(tapeout,9001) ch1,'taux' + WRITE(tapeout,*) taux +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tauy + WRITE(tapeout,9001) ch1,'tauy' + WRITE(tapeout,*) tauy + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ysinus + WRITE(tapeout,9001) ch1,'ysinus' + WRITE(tapeout,*) ysinus + + WRITE(tapeout,*) ' alphax alphay defrun ',alphax,alphay +c +9000 FORMAT(3(/,a72)) +9001 FORMAT(/,a72,/,a12) +cc + CLOSE(tapedef) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/description.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/description.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/description.h (revision 1280) @@ -0,0 +1,5 @@ +! +! $Header$ +! + character *120 descript + common /titre/descript Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/diagedyn.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/diagedyn.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/diagedyn.F (revision 1280) @@ -0,0 +1,321 @@ +! +! $Id$ +! + +C====================================================================== + SUBROUTINE diagedyn(tit,iprt,idiag,idiag2,dtime + e , ucov , vcov , ps, p ,pk , teta , q, ql) +C====================================================================== +C +C Purpose: +C Calcul la difference d'enthalpie et de masse d'eau entre 2 appels, +C et calcul le flux de chaleur et le flux d'eau necessaire a ces +C changements. Ces valeurs sont moyennees sur la surface de tout +C le globe et sont exprime en W/2 et kg/s/m2 +C Outil pour diagnostiquer la conservation de l'energie +C et de la masse dans la dynamique. +C +C +c====================================================================== +C Arguments: +C tit-----imput-A15- Comment added in PRINT (CHARACTER*15) +C iprt----input-I- PRINT level ( <=1 : no PRINT) +C idiag---input-I- indice dans lequel sera range les nouveaux +C bilans d' entalpie et de masse +C idiag2--input-I-les nouveaux bilans d'entalpie et de masse +C sont compare au bilan de d'enthalpie de masse de +C l'indice numero idiag2 +C Cas parriculier : si idiag2=0, pas de comparaison, on +c sort directement les bilans d'enthalpie et de masse +C dtime----input-R- time step (s) +C uconv, vconv-input-R- vents covariants (m/s) +C ps-------input-R- Surface pressure (Pa) +C p--------input-R- pressure at the interfaces +C pk-------input-R- pk= (p/Pref)**kappa +c teta-----input-R- potential temperature (K) +c q--------input-R- vapeur d'eau (kg/kg) +c ql-------input-R- liquid watter (kg/kg) +c aire-----input-R- mesh surafce (m2) +c +C the following total value are computed by UNIT of earth surface +C +C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy +c change (J/m2) during one time step (dtime) for the whole +C atmosphere (air, watter vapour, liquid and solid) +C d_qt------output-R- total water mass flux (kg/m2/s) defined as the +C total watter (kg/m2) change during one time step (dtime), +C d_qw------output-R- same, for the watter vapour only (kg/m2/s) +C d_ql------output-R- same, for the liquid watter only (kg/m2/s) +C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column +C +C +C J.L. Dufresne, July 2002 +c====================================================================== + + IMPLICIT NONE +C +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "iniprint.h" + +#ifdef CPP_EARTH +#include "../phylmd/YOMCST.h" +#include "../phylmd/YOETHF.h" +#endif +C + INTEGER imjmp1 + PARAMETER( imjmp1=iim*jjp1) +c Input variables + CHARACTER*15 tit + INTEGER iprt,idiag, idiag2 + REAL dtime + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL ps(ip1jmp1) ! pression au sol + REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL pk (ip1jmp1,llm ) ! = (p/Pref)**kappa + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL q(ip1jmp1,llm) ! champs eau vapeur + REAL ql(ip1jmp1,llm) ! champs eau liquide + + +c Output variables + REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec +C +C Local variables +c + REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + . , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot +c h_vcol_tot-- total enthalpy of vertical air column +C (air with watter vapour, liquid and solid) (J/m2) +c h_dair_tot-- total enthalpy of dry air (J/m2) +c h_qw_tot---- total enthalpy of watter vapour (J/m2) +c h_ql_tot---- total enthalpy of liquid watter (J/m2) +c h_qs_tot---- total enthalpy of solid watter (J/m2) +c qw_tot------ total mass of watter vapour (kg/m2) +c ql_tot------ total mass of liquid watter (kg/m2) +c qs_tot------ total mass of solid watter (kg/m2) +c ec_tot------ total cinetic energy (kg/m2) +C + REAL masse(ip1jmp1,llm) ! masse d'air + REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL ecin(ip1jmp1,llm) + + REAL zaire(imjmp1) + REAL zps(imjmp1) + REAL zairm(imjmp1,llm) + REAL zecin(imjmp1,llm) + REAL zpaprs(imjmp1,llm) + REAL zpk(imjmp1,llm) + REAL zt(imjmp1,llm) + REAL zh(imjmp1,llm) + REAL zqw(imjmp1,llm) + REAL zql(imjmp1,llm) + REAL zqs(imjmp1,llm) + + REAL zqw_col(imjmp1) + REAL zql_col(imjmp1) + REAL zqs_col(imjmp1) + REAL zec_col(imjmp1) + REAL zh_dair_col(imjmp1) + REAL zh_qw_col(imjmp1), zh_ql_col(imjmp1), zh_qs_col(imjmp1) +C + REAL d_h_dair, d_h_qw, d_h_ql, d_h_qs +C + REAL airetot, zcpvap, zcwat, zcice +C + INTEGER i, k, jj, ij , l ,ip1jjm1 +C + INTEGER ndiag ! max number of diagnostic in parallel + PARAMETER (ndiag=10) + integer pas(ndiag) + save pas + data pas/ndiag*0/ +C + REAL h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag) + $ , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag) + $ , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag) + SAVE h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre + $ , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre + + +#ifdef CPP_EARTH +c====================================================================== +C Compute Kinetic enrgy + CALL covcont ( llm , ucov , vcov , ucont, vcont ) + CALL enercin ( vcov , ucov , vcont , ucont , ecin ) + CALL massdair( p, masse ) +c====================================================================== +C +C + print*,'MAIS POURQUOI DONC DIAGEDYN NE MARCHE PAS ?' + return +C On ne garde les donnees que dans les colonnes i=1,iim + DO jj = 1,jjp1 + ip1jjm1=iip1*(jj-1) + DO ij = 1,iim + i=iim*(jj-1)+ij + zaire(i)=aire(ij+ip1jjm1) + zps(i)=ps(ij+ip1jjm1) + ENDDO + ENDDO +C 3D arrays + DO l = 1, llm + DO jj = 1,jjp1 + ip1jjm1=iip1*(jj-1) + DO ij = 1,iim + i=iim*(jj-1)+ij + zairm(i,l) = masse(ij+ip1jjm1,l) + zecin(i,l) = ecin(ij+ip1jjm1,l) + zpaprs(i,l) = p(ij+ip1jjm1,l) + zpk(i,l) = pk(ij+ip1jjm1,l) + zh(i,l) = teta(ij+ip1jjm1,l) + zqw(i,l) = q(ij+ip1jjm1,l) + zql(i,l) = ql(ij+ip1jjm1,l) + zqs(i,l) = 0. + ENDDO + ENDDO + ENDDO +C +C Reset variables + DO i = 1, imjmp1 + zqw_col(i)=0. + zql_col(i)=0. + zqs_col(i)=0. + zec_col(i) = 0. + zh_dair_col(i) = 0. + zh_qw_col(i) = 0. + zh_ql_col(i) = 0. + zh_qs_col(i) = 0. + ENDDO +C + zcpvap=RCPV + zcwat=RCW + zcice=RCS +C +C Compute vertical sum for each atmospheric column +C ================================================ + DO k = 1, llm + DO i = 1, imjmp1 +C Watter mass + zqw_col(i) = zqw_col(i) + zqw(i,k)*zairm(i,k) + zql_col(i) = zql_col(i) + zql(i,k)*zairm(i,k) + zqs_col(i) = zqs_col(i) + zqs(i,k)*zairm(i,k) +C Cinetic Energy + zec_col(i) = zec_col(i) + $ +zecin(i,k)*zairm(i,k) +C Air enthalpy + zt(i,k)= zh(i,k) * zpk(i,k) / RCPD + zh_dair_col(i) = zh_dair_col(i) + $ + RCPD*(1.-zqw(i,k)-zql(i,k)-zqs(i,k))*zairm(i,k)*zt(i,k) + zh_qw_col(i) = zh_qw_col(i) + $ + zcpvap*zqw(i,k)*zairm(i,k)*zt(i,k) + zh_ql_col(i) = zh_ql_col(i) + $ + zcwat*zql(i,k)*zairm(i,k)*zt(i,k) + $ - RLVTT*zql(i,k)*zairm(i,k) + zh_qs_col(i) = zh_qs_col(i) + $ + zcice*zqs(i,k)*zairm(i,k)*zt(i,k) + $ - RLSTT*zqs(i,k)*zairm(i,k) + + END DO + ENDDO +C +C Mean over the planete surface +C ============================= + qw_tot = 0. + ql_tot = 0. + qs_tot = 0. + ec_tot = 0. + h_vcol_tot = 0. + h_dair_tot = 0. + h_qw_tot = 0. + h_ql_tot = 0. + h_qs_tot = 0. + airetot=0. +C + do i=1,imjmp1 + qw_tot = qw_tot + zqw_col(i) + ql_tot = ql_tot + zql_col(i) + qs_tot = qs_tot + zqs_col(i) + ec_tot = ec_tot + zec_col(i) + h_dair_tot = h_dair_tot + zh_dair_col(i) + h_qw_tot = h_qw_tot + zh_qw_col(i) + h_ql_tot = h_ql_tot + zh_ql_col(i) + h_qs_tot = h_qs_tot + zh_qs_col(i) + airetot=airetot+zaire(i) + END DO +C + qw_tot = qw_tot/airetot + ql_tot = ql_tot/airetot + qs_tot = qs_tot/airetot + ec_tot = ec_tot/airetot + h_dair_tot = h_dair_tot/airetot + h_qw_tot = h_qw_tot/airetot + h_ql_tot = h_ql_tot/airetot + h_qs_tot = h_qs_tot/airetot +C + h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot +C +C Compute the change of the atmospheric state compare to the one +C stored in "idiag2", and convert it in flux. THis computation +C is performed IF idiag2 /= 0 and IF it is not the first CALL +c for "idiag" +C =================================== +C + IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN + d_h_vcol = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime + d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime + d_h_qw = (h_qw_tot - h_qw_pre(idiag2) )/dtime + d_h_ql = (h_ql_tot - h_ql_pre(idiag2) )/dtime + d_h_qs = (h_qs_tot - h_qs_pre(idiag2) )/dtime + d_qw = (qw_tot - qw_pre(idiag2) )/dtime + d_ql = (ql_tot - ql_pre(idiag2) )/dtime + d_qs = (qs_tot - qs_pre(idiag2) )/dtime + d_ec = (ec_tot - ec_pre(idiag2) )/dtime + d_qt = d_qw + d_ql + d_qs + ELSE + d_h_vcol = 0. + d_h_dair = 0. + d_h_qw = 0. + d_h_ql = 0. + d_h_qs = 0. + d_qw = 0. + d_ql = 0. + d_qs = 0. + d_ec = 0. + d_qt = 0. + ENDIF +C + IF (iprt.ge.2) THEN + WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs + 9000 format('Dyn3d. Watter Mass Budget (kg/m2/s)',A15 + $ ,1i6,10(1pE14.6)) + WRITE(6,9001) tit,pas(idiag), d_h_vcol + 9001 format('Dyn3d. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2)) + WRITE(6,9002) tit,pas(idiag), d_ec + 9002 format('Dyn3d. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2)) +C WRITE(6,9003) tit,pas(idiag), ec_tot + 9003 format('Dyn3d. Cinetic Energy (W/m2) ',A15,1i6,10(E15.6)) + WRITE(6,9004) tit,pas(idiag), d_h_vcol+d_ec + 9004 format('Dyn3d. Total Energy Budget (W/m2) ',A15,1i6,10(F8.2)) + END IF +C +C Store the new atmospheric state in "idiag" +C + pas(idiag)=pas(idiag)+1 + h_vcol_pre(idiag) = h_vcol_tot + h_dair_pre(idiag) = h_dair_tot + h_qw_pre(idiag) = h_qw_tot + h_ql_pre(idiag) = h_ql_tot + h_qs_pre(idiag) = h_qs_tot + qw_pre(idiag) = qw_tot + ql_pre(idiag) = ql_tot + qs_pre(idiag) = qs_tot + ec_pre (idiag) = ec_tot +C +#else + write(lunout,*)'diagedyn: Needs Earth physics to function' +#endif +! #endif of #ifdef CPP_EARTH + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dissip.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dissip.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dissip.F (revision 1280) @@ -0,0 +1,143 @@ +! +! $Header$ +! + SUBROUTINE dissip( vcov,ucov,teta,p, dv,du,dh ) +c + IMPLICIT NONE + + +c .. Avec nouveaux operateurs star : gradiv2 , divgrad2, nxgraro2 ... +c ( 10/01/98 ) + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c Dissipation horizontale +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comdissnew.h" +#include "comdissipn.h" + +c Arguments: +c ---------- + + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL p( ip1jmp1,llmp1 ) + REAL dv(ip1jm,llm),du(ip1jmp1,llm),dh(ip1jmp1,llm) + +c Local: +c ------ + + REAL gdx(ip1jmp1,llm),gdy(ip1jm,llm) + REAL grx(ip1jmp1,llm),gry(ip1jm,llm) + REAL te1dt(llm),te2dt(llm),te3dt(llm) + REAL deltapres(ip1jmp1,llm) + + INTEGER l,ij + + REAL SSUM + +c----------------------------------------------------------------------- +c initialisations: +c ---------------- + + DO l=1,llm + te1dt(l) = tetaudiv(l) * dtdiss + te2dt(l) = tetaurot(l) * dtdiss + te3dt(l) = tetah(l) * dtdiss + ENDDO + du=0. + dv=0. + dh=0. + +c----------------------------------------------------------------------- +c Calcul de la dissipation: +c ------------------------- + +c Calcul de la partie grad ( div ) : +c ------------------------------------- + + + IF(lstardis) THEN + CALL gradiv2( llm,ucov,vcov,nitergdiv,gdx,gdy ) + ELSE + CALL gradiv ( llm,ucov,vcov,nitergdiv,gdx,gdy ) + ENDIF + + DO l=1,llm + + DO ij = 1, iip1 + gdx( ij ,l) = 0. + gdx(ij+ip1jm,l) = 0. + ENDDO + + DO ij = iip2,ip1jm + du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l) + ENDDO + DO ij = 1,ip1jm + dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l) + ENDDO + + ENDDO + +c calcul de la partie n X grad ( rot ): +c --------------------------------------- + + IF(lstardis) THEN + CALL nxgraro2( llm,ucov, vcov, nitergrot,grx,gry ) + ELSE + CALL nxgrarot( llm,ucov, vcov, nitergrot,grx,gry ) + ENDIF + + + DO l=1,llm + DO ij = 1, iip1 + grx(ij,l) = 0. + ENDDO + + DO ij = iip2,ip1jm + du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l) + ENDDO + DO ij = 1, ip1jm + dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l) + ENDDO + ENDDO + +c calcul de la partie div ( grad ): +c ----------------------------------- + + + IF(lstardis) THEN + + DO l = 1, llm + DO ij = 1, ip1jmp1 + deltapres(ij,l) = AMAX1( 0., p(ij,l) - p(ij,l+1) ) + ENDDO + ENDDO + + CALL divgrad2( llm,teta, deltapres ,niterh, gdx ) + ELSE + CALL divgrad ( llm,teta, niterh, gdx ) + ENDIF + + DO l = 1,llm + DO ij = 1,ip1jmp1 + dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l ) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/disvert.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/disvert.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/disvert.F (revision 1280) @@ -0,0 +1,194 @@ +! +! $Id$ +! + SUBROUTINE disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig) + +c Auteur : P. Le Van . +c + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +#include "logic.h" +c +c======================================================================= +c +c +c s = sigma ** kappa : coordonnee verticale +c dsig(l) : epaisseur de la couche l ds la coord. s +c sig(l) : sigma a l'interface des couches l et l-1 +c ds(l) : distance entre les couches l et l-1 en coord.s +c +c======================================================================= +c + REAL pa,preff + REAL ap(llmp1),bp(llmp1),dpres(llm),nivsigs(llm),nivsig(llmp1) + REAL presnivs(llm) +c +c declarations: +c ------------- +c + REAL sig(llm+1),dsig(llm) + real zzz(1:llm+1) + real dzz(1:llm) + real zk,zkm1,dzk1,dzk2,k0,k1 +c + INTEGER l + REAL snorm,dsigmin + REAL alpha,beta,gama,delta,deltaz,h + INTEGER np,ierr + REAL pi,x + + REAL SSUM +c +c----------------------------------------------------------------------- +c + pi=2.*ASIN(1.) + + OPEN(99,file='sigma.def',status='old',form='formatted', + s iostat=ierr) + +c----------------------------------------------------------------------- +c cas 1 on lit les options dans sigma.def: +c ---------------------------------------- + + IF (ierr.eq.0) THEN + + READ(99,*) h ! hauteur d'echelle 8. + READ(99,*) deltaz ! epaiseur de la premiere couche 0.04 + READ(99,*) beta ! facteur d'acroissement en haut 1.3 + READ(99,*) k0 ! nombre de couches dans la transition surf + READ(99,*) k1 ! nombre de couches dans la transition haute + CLOSE(99) + alpha=deltaz/(llm*h) + write(lunout,*)'h,alpha,k0,k1,beta' + +c read(*,*) h,deltaz,beta,k0,k1 ! 8 0.04 4 20 1.2 + + alpha=deltaz/tanh(1./k0)*2. + zkm1=0. + sig(1)=1. + do l=1,llm + sig(l+1)=(cosh(l/k0))**(-alpha*k0/h) + + *exp(-alpha/h*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta)) + zk=-h*log(sig(l+1)) + + dzk1=alpha*tanh(l/k0) + dzk2=alpha*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta) + write(lunout,*)l,sig(l+1),zk,zk-zkm1,dzk1,dzk2 + zkm1=zk + enddo + + sig(llm+1)=0. + +c + DO 2 l = 1, llm + dsig(l) = sig(l)-sig(l+1) + 2 CONTINUE +c + + ELSE +c----------------------------------------------------------------------- +c cas 2 ancienne discretisation (LMD5...): +c ---------------------------------------- + + WRITE(LUNOUT,*)'WARNING!!! Ancienne discretisation verticale' + + if (ok_strato) then + if (llm==39) then + dsigmin=0.3 + else if (llm==50) then + dsigmin=1. + else + WRITE(LUNOUT,*) 'ATTENTION discretisation z a ajuster' + dsigmin=1. + endif + WRITE(LUNOUT,*) 'Discretisation verticale DSIGMIN=',dsigmin + endif + + h=7. + snorm = 0. + DO l = 1, llm + x = 2.*asin(1.) * (FLOAT(l)-0.5) / float(llm+1) + + IF (ok_strato) THEN + dsig(l) =(dsigmin + 7.0 * SIN(x)**2) + & *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2 + ELSE + dsig(l) = 1.0 + 7.0 * SIN(x)**2 + ENDIF + + snorm = snorm + dsig(l) + ENDDO + snorm = 1./snorm + DO l = 1, llm + dsig(l) = dsig(l)*snorm + ENDDO + sig(llm+1) = 0. + DO l = llm, 1, -1 + sig(l) = sig(l+1) + dsig(l) + ENDDO + + ENDIF + + + DO l=1,llm + nivsigs(l) = FLOAT(l) + ENDDO + + DO l=1,llmp1 + nivsig(l)= FLOAT(l) + ENDDO + +c +c .... Calculs de ap(l) et de bp(l) .... +c ......................................... +c +c +c ..... pa et preff sont lus sur les fichiers start par lectba ..... +c + + bp(llmp1) = 0. + + DO l = 1, llm +cc +ccc ap(l) = 0. +ccc bp(l) = sig(l) + + bp(l) = EXP( 1. -1./( sig(l)*sig(l)) ) + ap(l) = pa * ( sig(l) - bp(l) ) +c + ENDDO + + bp(1)=1. + ap(1)=0. + + ap(llmp1) = pa * ( sig(llmp1) - bp(llmp1) ) + + write(lunout,*)' BP ' + write(lunout,*) bp + write(lunout,*)' AP ' + write(lunout,*) ap + + write(lunout,*) + .'Niveaux de pressions approximatifs aux centres des' + write(lunout,*)'couches calcules pour une pression de surface =', + . preff + write(lunout,*) + . 'et altitudes equivalentes pour une hauteur d echelle de' + write(lunout,*)'8km' + DO l = 1, llm + dpres(l) = bp(l) - bp(l+1) + presnivs(l) = 0.5 *( ap(l)+bp(l)*preff + ap(l+1)+bp(l+1)*preff ) + write(lunout,*)'PRESNIVS(',l,')=',presnivs(l),' Z ~ ', + . log(preff/presnivs(l))*8. + . ,' DZ ~ ',8.*log((ap(l)+bp(l)*preff)/ + . max(ap(l+1)+bp(l+1)*preff,1.e-10)) + ENDDO + + write(lunout,*)' PRESNIVS ' + write(lunout,*)presnivs + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/diverg.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/diverg.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/diverg.F (revision 1280) @@ -0,0 +1,85 @@ +! +! $Header$ +! + SUBROUTINE diverg(klevel,x,y,div) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER l,ij +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps +c ................................................................... +c + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO ij = iip2, ip1jm - 1 + div( ij + 1, l ) = + * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + + * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + DO ij = 1,iim + aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) + aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) / apoln + sumyps = SSUM ( iim,aiy2,1 ) / apols +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + div( ij + ip1jm, l ) = sumyps + ENDDO + 10 CONTINUE +c + +ccc CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 ) + +c + DO l = 1, klevel + DO ij = iip2,ip1jm + div(ij,l) = div(ij,l) * unsaire(ij) + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/diverg_gam.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/diverg_gam.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/diverg_gam.F (revision 1280) @@ -0,0 +1,80 @@ +! +! $Header$ +! + SUBROUTINE diverg_gam(klevel,cuvscvgam,cvuscugam,unsairegam , + * unsapolnga,unsapolsga, x, y, div ) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1) + REAL unsapolnga,unsapolsga +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps + INTEGER l,ij +c ................................................................... +c + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO ij = iip2, ip1jm - 1 + div( ij + 1, l ) = ( + * cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) + + * cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* + * unsairegam( ij+1 ) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + DO ij = 1,iim + aiy1(ij) = cuvscvgam( ij ) * y( ij , l ) + aiy2(ij) = cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga + sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + div( ij + ip1jm, l ) = sumyps + ENDDO + 10 CONTINUE +c + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/divergf.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/divergf.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/divergf.F (revision 1280) @@ -0,0 +1,85 @@ +! +! $Header$ +! + SUBROUTINE divergf(klevel,x,y,div) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER l,ij +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps +c ................................................................... +c + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO ij = iip2, ip1jm - 1 + div( ij + 1, l ) = + * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + + * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + DO ij = 1,iim + aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) + aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) / apoln + sumyps = SSUM ( iim,aiy2,1 ) / apols +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + div( ij + ip1jm, l ) = sumyps + ENDDO + 10 CONTINUE +c + + CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 ) + +c + DO l = 1, klevel + DO ij = iip2,ip1jm + div(ij,l) = div(ij,l) * unsaire(ij) + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/divergst.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/divergst.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/divergst.F (revision 1280) @@ -0,0 +1,62 @@ +! +! $Header$ +! + SUBROUTINE divergst(klevel,x,y,div) + IMPLICIT NONE +c +c P. Le Van +c +c ****************************************************************** +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. x et y... +c x et y etant des composantes contravariantes ... +c **************************************************************** +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c ------------------------------------------------------------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER ij,l,i + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps + + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO 1 ij = iip2, ip1jm - 1 + div( ij + 1, l ) = x(ij+1,l) - x(ij,l)+ y(ij-iim,l)-y(ij+1,l) + 1 CONTINUE +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO 3 ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + 3 CONTINUE +c +c .... calcul aux poles ..... +c +c + DO 5 i = 1,iim + aiy1(i)= y(i,l) + aiy2(i)= y(i+ip1jmi1,l) + 5 CONTINUE + sumypn = SSUM ( iim,aiy1,1 ) + sumyps = SSUM ( iim,aiy2,1 ) + DO 7 i = 1,iip1 + div( i , l ) = - sumypn/iim + div( i + ip1jm, l ) = sumyps/iim + 7 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/divgrad.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/divgrad.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/divgrad.F (revision 1280) @@ -0,0 +1,56 @@ +! +! $Header$ +! + SUBROUTINE divgrad (klevel,h, lh, divgra ) + IMPLICIT NONE +c +c======================================================================= +c +c Auteur : P. Le Van +c ---------- +c +c lh +c calcul de (div( grad )) de h ..... +c h et lh sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c +c======================================================================= +c +c declarations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comdissipn.h" +#include "logic.h" +c + INTEGER klevel + REAL h( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) + + INTEGER l,ij,iter,lh +c +c +c + CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 ) +c + DO 10 iter = 1,lh + + CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1 ) + + CALL grad (klevel,divgra, ghx , ghy ) + CALL diverg (klevel, ghx , ghy , divgra ) + + CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1) + + DO 5 l = 1,klevel + DO 4 ij = 1, ip1jmp1 + divgra( ij,l ) = - cdivh * divgra( ij,l ) + 4 CONTINUE + 5 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/divgrad2.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/divgrad2.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/divgrad2.F (revision 1280) @@ -0,0 +1,79 @@ +! +! $Header$ +! + SUBROUTINE divgrad2 ( klevel, h, deltapres, lh, divgra ) +c +c P. Le Van +c +c *************************************************************** +c +c ..... calcul de (div( grad )) de ( pext * h ) ..... +c **************************************************************** +c h ,klevel,lh et pext sont des arguments d'entree pour le s-prg +c divgra est un argument de sortie pour le s-prg +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comdissipn.h" + +c ....... variables en arguments ....... +c + INTEGER klevel + REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel ) + REAL divgra( ip1jmp1,klevel) +c +c ....... variables locales .......... +c + REAL signe, nudivgrs, sqrtps( ip1jmp1,llm ) + INTEGER l,ij,iter,lh +c ................................................................... + +c + signe = (-1.)**lh + nudivgrs = signe * cdivh + + CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 ) + +c + CALL laplacien( klevel, divgra, divgra ) + + DO l = 1, klevel + DO ij = 1, ip1jmp1 + sqrtps( ij,l ) = SQRT( deltapres(ij,l) ) + ENDDO + ENDDO +c + DO l = 1, klevel + DO ij = 1, ip1jmp1 + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO + +c ........ Iteration de l'operateur laplacien_gam ........ +c + DO iter = 1, lh - 2 + CALL laplacien_gam ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2, + * unsapolnga2, unsapolsga2, divgra, divgra ) + ENDDO +c +c ............................................................... + + DO l = 1, klevel + DO ij = 1, ip1jmp1 + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO +c + CALL laplacien ( klevel, divgra, divgra ) +c + DO l = 1,klevel + DO ij = 1,ip1jmp1 + divgra(ij,l) = nudivgrs * divgra(ij,l) / deltapres(ij,l) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dteta1.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dteta1.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dteta1.F (revision 1280) @@ -0,0 +1,68 @@ +! +! $Header$ +! + SUBROUTINE dteta1 ( teta, pbaru, pbarv, dteta) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c Modif F.Forget 03/94 (on retire q et dq pour construire dteta1) +c +c ******************************************************************** +c ... calcul du terme de convergence horizontale du flux d'enthalpie +c potentielle ...... +c ******************************************************************** +c .. teta,pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c dteta sont des arguments de sortie pour le s-pg .... +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" + + REAL teta( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL dteta( ip1jmp1,llm ) + INTEGER l,ij + + REAL hbyv( ip1jm,llm ), hbxu( ip1jmp1,llm ) + +c + + DO 5 l = 1,llm + + DO 1 ij = iip2, ip1jm - 1 + hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l) + teta(ij+1,l) ) + 1 CONTINUE + +c .... correction pour hbxu(iip1,j,l) ..... +c .... hbxu(iip1,j,l)= hbxu(1,j,l) .... + +CDIR$ IVDEP + DO 2 ij = iip1+ iip1, ip1jm, iip1 + hbxu( ij, l ) = hbxu( ij - iim, l ) + 2 CONTINUE + + + DO 3 ij = 1,ip1jm + hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+ teta(ij +iip1,l) ) + 3 CONTINUE + + 5 CONTINUE + + + CALL convflu ( hbxu, hbyv, llm, dteta ) + + +c stockage dans dh de la convergence horizont. filtree' du flux +c .... ........... +c d'enthalpie potentielle . + + CALL filtreg( dteta, jjp1, llm, 2, 2, .true., 1) + +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dudv1.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dudv1.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dudv1.F (revision 1280) @@ -0,0 +1,53 @@ +! +! $Header$ +! + SUBROUTINE dudv1 ( vorpot, pbaru, pbarv, du, dv ) + IMPLICIT NONE +c +c----------------------------------------------------------------------- +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c calcul du terme de rotation +c ce terme est ajoute a d(ucov)/dt et a d(vcov)/dt .. +c vorpot, pbaru et pbarv sont des arguments d'entree pour le s-pg .. +c du et dv sont des arguments de sortie pour le s-pg .. +c +c----------------------------------------------------------------------- + +#include "dimensions.h" +#include "paramet.h" + + REAL vorpot( ip1jm,llm ) ,pbaru( ip1jmp1,llm ) , + * pbarv( ip1jm,llm ) ,du( ip1jmp1,llm ) ,dv( ip1jm,llm ) + INTEGER l,ij +c +c + DO 10 l = 1,llm +c + DO 2 ij = iip2, ip1jm - 1 + du( ij,l ) = 0.125 *( vorpot(ij-iip1, l) + vorpot( ij, l) ) * + * ( pbarv(ij-iip1, l) + pbarv(ij-iim, l) + + * pbarv( ij , l) + pbarv(ij+ 1 , l) ) + 2 CONTINUE +c + DO 3 ij = 1, ip1jm - 1 + dv( ij+1,l ) = - 0.125 *( vorpot(ij, l) + vorpot(ij+1, l) ) * + * ( pbaru(ij, l) + pbaru(ij+1 , l) + + * pbaru(ij+iip1, l) + pbaru(ij+iip2, l) ) + 3 CONTINUE +c +c .... correction pour dv( 1,j,l ) ..... +c .... dv(1,j,l)= dv(iip1,j,l) .... +c +CDIR$ IVDEP + DO 4 ij = 1, ip1jm, iip1 + dv( ij,l ) = dv( ij + iim, l ) + 4 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dudv2.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dudv2.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dudv2.F (revision 1280) @@ -0,0 +1,63 @@ +! +! $Header$ +! + SUBROUTINE dudv2 ( teta, pkf, bern, du, dv ) + + IMPLICIT NONE +c +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ***************************************************************** +c ..... calcul du terme de pression (gradient de p/densite ) et +c du terme de ( -gradient de la fonction de Bernouilli ) ... +c ***************************************************************** +c Ces termes sont ajoutes a d(ucov)/dt et a d(vcov)/dt .. +c +c +c teta , pkf, bern sont des arguments d'entree pour le s-pg .... +c du et dv sont des arguments de sortie pour le s-pg .... +c +c======================================================================= +c +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + + REAL teta( ip1jmp1,llm ),pkf( ip1jmp1,llm ) ,bern( ip1jmp1,llm ), + * du( ip1jmp1,llm ), dv( ip1jm,llm ) + INTEGER l,ij +c +c + DO 5 l = 1,llm +c + DO 2 ij = iip2, ip1jm - 1 + du(ij,l) = du(ij,l) + 0.5* ( teta( ij,l ) + teta( ij+1,l ) ) * + * ( pkf( ij,l ) - pkf(ij+1,l) ) + bern(ij,l) - bern(ij+1,l) + 2 CONTINUE +c +c +c ..... correction pour du(iip1,j,l), j=2,jjm ...... +c ... du(iip1,j,l) = du(1,j,l) ... +c +CDIR$ IVDEP + DO 3 ij = iip1+ iip1, ip1jm, iip1 + du( ij,l ) = du( ij - iim,l ) + 3 CONTINUE +c +c + DO 4 ij = 1,ip1jm + dv( ij,l) = dv(ij,l) + 0.5 * ( teta(ij,l) + teta( ij+iip1,l ) ) * + * ( pkf(ij+iip1,l) - pkf( ij,l ) ) + * + bern( ij+iip1,l ) - bern( ij ,l ) + 4 CONTINUE +c + 5 CONTINUE +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dump2d.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dump2d.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dump2d.F (revision 1280) @@ -0,0 +1,46 @@ +! +! $Id$ +! + SUBROUTINE dump2d(im,jm,z,nom_z) + IMPLICIT NONE + INTEGER im,jm + REAL z(im,jm) + CHARACTER (len=*) :: nom_z + + INTEGER i,j,imin,illm,jmin,jllm + REAL zmin,zllm + + WRITE(*,*) "dump2d: ",trim(nom_z) + + zmin=z(1,1) + zllm=z(1,1) + imin=1 + illm=1 + jmin=1 + jllm=1 + + DO j=1,jm + DO i=1,im + IF(z(i,j).GT.zllm) THEN + illm=i + jllm=j + zllm=z(i,j) + ENDIF + IF(z(i,j).LT.zmin) THEN + imin=i + jmin=j + zmin=z(i,j) + ENDIF + ENDDO + ENDDO + + PRINT*,'MIN: ',zmin + PRINT*,'MAX: ',zllm + + IF(zllm.GT.zmin) THEN + DO j=1,jm + WRITE(*,'(600i1)') (NINT(10.*(z(i,j)-zmin)/(zllm-zmin)),i=1,im) + ENDDO + ENDIF + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dynetat0.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dynetat0.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dynetat0.F (revision 1280) @@ -0,0 +1,383 @@ +! +! $Header$ +! + SUBROUTINE dynetat0(fichnom,vcov,ucov, + . teta,q,masse,ps,phis,time) + + USE infotrac + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van / L.Fairhead +c ------- +c +c objet: +c ------ +c +c Lecture de l'etat initial +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "temps.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "ener.h" +#include "netcdf.inc" +#include "description.h" +#include "serre.h" +#include "logic.h" + +c Arguments: +c ---------- + + CHARACTER*(*) fichnom + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nqtot),masse(ip1jmp1,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + + REAL time + +c Variables +c + INTEGER length,iq + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + INTEGER ierr, nid, nvarid + +c----------------------------------------------------------------------- + +c Ouverture NetCDF du fichier etat initial + + ierr = NF_OPEN (fichnom, NF_NOWRITE,nid) + IF (ierr.NE.NF_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier start.nc' + write(6,*)' ierr = ', ierr + CALL ABORT + ENDIF + +c + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echoue pour " + CALL abort + ENDIF + + im = tab_cntrl(1) + jm = tab_cntrl(2) + lllm = tab_cntrl(3) + day_ref = tab_cntrl(4) + annee_ref = tab_cntrl(5) + rad = tab_cntrl(6) + omeg = tab_cntrl(7) + g = tab_cntrl(8) + cpp = tab_cntrl(9) + kappa = tab_cntrl(10) + daysec = tab_cntrl(11) + dtvr = tab_cntrl(12) + etot0 = tab_cntrl(13) + ptot0 = tab_cntrl(14) + ztot0 = tab_cntrl(15) + stot0 = tab_cntrl(16) + ang0 = tab_cntrl(17) + pa = tab_cntrl(18) + preff = tab_cntrl(19) +c + clon = tab_cntrl(20) + clat = tab_cntrl(21) + grossismx = tab_cntrl(22) + grossismy = tab_cntrl(23) +c + IF ( tab_cntrl(24).EQ.1. ) THEN + fxyhypb = . TRUE . +c dzoomx = tab_cntrl(25) +c dzoomy = tab_cntrl(26) +c taux = tab_cntrl(28) +c tauy = tab_cntrl(29) + ELSE + fxyhypb = . FALSE . + ysinus = . FALSE . + IF( tab_cntrl(27).EQ.1. ) ysinus = . TRUE. + ENDIF + + day_ini = tab_cntrl(30) + itau_dyn = tab_cntrl(31) +c ................................................................. +c +c + PRINT*,'rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa + + IF( im.ne.iim ) THEN + PRINT 1,im,iim + STOP + ELSE IF( jm.ne.jjm ) THEN + PRINT 2,jm,jjm + STOP + ELSE IF( lllm.ne.llm ) THEN + PRINT 3,lllm,llm + STOP + ENDIF + + ierr = NF_INQ_VARID (nid, "rlonu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlatu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlonv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlatv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour rlatv" + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "cu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, cu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "cv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, cv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "aire", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, aire) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, aire) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "phisinit", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phis) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, phis) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, time) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, time) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ucov) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ucov) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, vcov) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, vcov) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, teta) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, teta) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + + IF(nqtot.GE.1) THEN + DO iq=1,nqtot + ierr = NF_INQ_VARID (nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ <"//tname(iq)//"> est absent" + PRINT*, " Il est donc initialise a zero" + q(:,:,iq)=0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q(1,1,iq)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, q(1,1,iq)) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour "//tname(iq) + CALL abort + ENDIF + ENDIF + ENDDO + ENDIF + + ierr = NF_INQ_VARID (nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, masse) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, masse) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ps) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ps) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_CLOSE(nid) + + day_ini=day_ini+INT(time) + time=time-INT(time) + + 1 FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dem + *arrage est differente de la valeur parametree iim =',i4//) + 2 FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dem + *arrage est differente de la valeur parametree jjm =',i4//) + 3 FORMAT(//10x,'la valeur de lmax =',i4,2x,'lue sur le fichier dema + *rrage est differente de la valeur parametree llm =',i4//) + 4 FORMAT(//10x,'la valeur de dtrv =',i4,2x,'lue sur le fichier dema + *rrage est differente de la valeur dtinteg =',i4//) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dynredem.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dynredem.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/dynredem.F (revision 1280) @@ -0,0 +1,741 @@ +! +! $Id$ +! +c + SUBROUTINE dynredem0(fichnom,iday_end,phis) +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + USE infotrac + IMPLICIT NONE +c======================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF (initialisation) +c======================================================================= +c Declarations: +c ------------- +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "netcdf.inc" +#include "description.h" +#include "serre.h" + +c Arguments: +c ---------- + INTEGER iday_end + REAL phis(ip1jmp1) + CHARACTER*(*) fichnom + +c Local: +c ------ + INTEGER iq,l + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + INTEGER ierr + character*20 modname + character*80 abort_message + +c Variables locales pour NetCDF: +c + INTEGER dims2(2), dims3(3), dims4(4) + INTEGER idim_index + INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv + INTEGER idim_s, idim_sig + INTEGER idim_tim + INTEGER nid,nvarid + + REAL zan0,zjulian,hours + INTEGER yyears0,jjour0, mmois0 + character*30 unites + + +c----------------------------------------------------------------------- + modname='dynredem0' + +#ifdef CPP_IOIPSL + call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian) + call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours) +#else +! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used) + yyears0=0 + mmois0=1 + jjour0=1 +#endif + + DO l=1,length + tab_cntrl(l) = 0. + ENDDO + tab_cntrl(1) = FLOAT(iim) + tab_cntrl(2) = FLOAT(jjm) + tab_cntrl(3) = FLOAT(llm) + tab_cntrl(4) = FLOAT(day_ref) + tab_cntrl(5) = FLOAT(annee_ref) + tab_cntrl(6) = rad + tab_cntrl(7) = omeg + tab_cntrl(8) = g + tab_cntrl(9) = cpp + tab_cntrl(10) = kappa + tab_cntrl(11) = daysec + tab_cntrl(12) = dtvr + tab_cntrl(13) = etot0 + tab_cntrl(14) = ptot0 + tab_cntrl(15) = ztot0 + tab_cntrl(16) = stot0 + tab_cntrl(17) = ang0 + tab_cntrl(18) = pa + tab_cntrl(19) = preff +c +c ..... parametres pour le zoom ...... + + tab_cntrl(20) = clon + tab_cntrl(21) = clat + tab_cntrl(22) = grossismx + tab_cntrl(23) = grossismy +c + IF ( fxyhypb ) THEN + tab_cntrl(24) = 1. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = taux + tab_cntrl(29) = tauy + ELSE + tab_cntrl(24) = 0. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = 0. + tab_cntrl(29) = 0. + IF( ysinus ) tab_cntrl(27) = 1. + ENDIF + + tab_cntrl(30) = FLOAT(iday_end) + tab_cntrl(31) = FLOAT(itau_dyn + itaufin) +c +c ......................................................... +c +c Creation du fichier: +c + ierr = NF_CREATE(fichnom, NF_CLOBBER, nid) + IF (ierr.NE.NF_NOERR) THEN + WRITE(6,*)" Pb d ouverture du fichier "//fichnom + WRITE(6,*)' ierr = ', ierr + CALL ABORT + ENDIF +c +c Preciser quelques attributs globaux: +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27, + . "Fichier demmarage dynamique") +c +c Definir les dimensions du fichiers: +c + ierr = NF_DEF_DIM (nid, "index", length, idim_index) + ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu) + ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu) + ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv) + ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv) + ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s) + ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig) + ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim) +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition +c +c Definir et enregistrer certains champs invariants: +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid) +#else + ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Parametres de controle") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28, + . "Numero naturel des couches s") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32, + . "Numero naturel des couches sigma") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient A pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ap) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient B pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,bp) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs) +#endif +c +c Coefficients de passage cov. <-> contra. <--> naturel +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonu + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cu) +#endif +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatv +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cv) +#endif +c +c Aire de chaque maille: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Aires de chaque maille") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,aire) +#endif +c +c Geopentiel au sol: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Geopotentiel au sol") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,phis) +#endif +c +c Definir les variables pour pouvoir les enregistrer plus tard: +c + ierr = NF_REDEF (nid) ! entrer dans le mode de definition +c +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid) +#else + ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Temps de simulation") + write(unites,200)yyears0,mmois0,jjour0 +200 format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00') + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30, + . unites) + +c + dims4(1) = idim_rlonu + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse U") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatv + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse V") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11, + . "Temperature") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim + IF(nqtot.GE.1) THEN + DO iq=1,nqtot +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq)) + ENDDO + ENDIF +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12, + . "C est quoi ?") +c + dims3(1) = idim_rlonv + dims3(2) = idim_rlatu + dims3(3) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15, + . "Pression au sol") +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition + ierr = NF_CLOSE(nid) ! fermer le fichier + + PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end + PRINT*,'rad,omeg,g,cpp,kappa', + , rad,omeg,g,cpp,kappa + + RETURN + END + SUBROUTINE dynredem1(fichnom,time, + . vcov,ucov,teta,q,masse,ps) + USE infotrac + IMPLICIT NONE +c================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF +c================================================================= +#include "dimensions.h" +#include "paramet.h" +#include "description.h" +#include "netcdf.inc" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "control.h" + + INTEGER l + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nqtot) + CHARACTER*(*) fichnom + + REAL time + INTEGER nid, nvarid, nid_trac, nvarid_trac + REAL trac_tmp(ip1jmp1,llm) + INTEGER ierr, ierr_file + INTEGER iq + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + character*20 modname + character*80 abort_message +c + INTEGER nb + SAVE nb + DATA nb / 0 / + + modname = 'dynredem1' + ierr = NF_OPEN(fichnom, NF_WRITE, nid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Pb. d ouverture "//fichnom + CALL abort + ENDIF + +c Ecriture/extension de la coordonnee temps + + nb = nb + 1 + ierr = NF_INQ_VARID(nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + print *, NF_STRERROR(ierr) + abort_message='Variable temps n est pas definie' + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time) +#else + ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time) +#endif + PRINT*, "Enregistrement pour ", nb, time + +c +c Re-ecriture du tableau de controle, itaufin n'est plus defini quand +c on passe dans dynredem0 + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Le champ est absent" + ierr = 1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + tab_cntrl(31) = FLOAT(itau_dyn + itaufin) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif + +c Ecriture des champs +c + ierr = NF_INQ_VARID(nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ucov n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov) +#endif + + ierr = NF_INQ_VARID(nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable vcov n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov) +#endif + + ierr = NF_INQ_VARID(nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable teta n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,teta) +#endif + + IF (config_inca /= 'none') THEN +! Ajout Anne pour lecture valeurs traceurs dans un fichier start_trac.nc + ierr_file = NF_OPEN ("start_trac.nc", NF_NOWRITE,nid_trac) + IF (ierr_file .NE.NF_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier start_trac.nc' + write(6,*)' ierr = ', ierr_file + ENDIF + END IF + + IF(nqtot.GE.1) THEN + do iq=1,nqtot + + IF (config_inca == 'none') THEN + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable tname(iq) n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ELSE ! config_inca = 'chem' ou 'aero' +! lecture de la valeur du traceur dans start_trac.nc + IF (ierr_file .ne. 2) THEN + ierr = NF_INQ_VARID (nid_trac, tname(iq), nvarid_trac) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, tname(iq),"est absent de start_trac.nc" + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ", tname(iq)," n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + + ELSE + PRINT*, tname(iq), "est present dans start_trac.nc" +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid_trac, nvarid_trac, trac_tmp) +#else + ierr = NF_GET_VAR_REAL(nid_trac, nvarid_trac, trac_tmp) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Lecture echouee pour", tname(iq) + CALL abort + ENDIF + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ", tname(iq)," n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,trac_tmp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,trac_tmp) +#endif + + ENDIF ! IF (ierr .NE. NF_NOERR) +! fin lecture du traceur + ELSE ! si il n'y a pas de fichier start_trac.nc +! print *, 'il n y a pas de fichier start_trac' + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable tname(iq) n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ENDIF ! (ierr_file .ne. 2) + END IF ! config_inca + + ENDDO + ENDIF +c + ierr = NF_INQ_VARID(nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable masse n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,masse) +#endif +c + ierr = NF_INQ_VARID(nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ps n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ps) +#endif + + ierr = NF_CLOSE(nid) +c + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ener.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ener.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ener.h (revision 1280) @@ -0,0 +1,14 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c INCLUDE 'ener.h' + + COMMON/ener/ang0,etot0,ptot0,ztot0,stot0, + * ang,etot,ptot,ztot,stot,rmsdpdt , + * rmsv,gtot(llmm1) + + REAL ang0,etot0,ptot0,ztot0,stot0, + s ang,etot,ptot,ztot,stot,rmsdpdt,rmsv,gtot + +c----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/enercin.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/enercin.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/enercin.F (revision 1280) @@ -0,0 +1,98 @@ +! +! $Header$ +! + SUBROUTINE enercin ( vcov, ucov, vcont, ucont, ecin ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c .. calcul de l'energie cinetique aux niveaux s ...... +c ********************************************************************* +c vcov, vcont, ucov et ucont sont des arguments d'entree pour le s-pg . +c ecin est un argument de sortie pour le s-pg +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL vcov( ip1jm,llm ),vcont( ip1jm,llm ), + * ucov( ip1jmp1,llm ),ucont( ip1jmp1,llm ),ecin( ip1jmp1,llm ) + + REAL ecinni( iip1 ),ecinsi( iip1 ) + + REAL ecinpn, ecinps + INTEGER l,ij,i + + REAL SSUM + + + +c . V +c i,j-1 + +c alpha4 . . alpha1 + + +c U . . P . U +c i-1,j i,j i,j + +c alpha3 . . alpha2 + + +c . V +c i,j + +c +c L'energie cinetique au point scalaire P(i,j) ,autre que les poles, est : +c Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 ) + +c 0.5 * U(i ,j)**2 *( alpha1 + alpha2 ) + +c 0.5 * V(i,j-1)**2 *( alpha1 + alpha4 ) + +c 0.5 * V(i, j)**2 *( alpha2 + alpha3 ) + + + DO 5 l = 1,llm + + DO 1 ij = iip2, ip1jm -1 + ecin( ij+1, l ) = 0.5 * + * ( ucov( ij ,l ) * ucont( ij ,l ) * alpha3p4( ij +1 ) + + * ucov( ij+1 ,l ) * ucont( ij+1 ,l ) * alpha1p2( ij +1 ) + + * vcov(ij-iim,l ) * vcont(ij-iim,l ) * alpha1p4( ij +1 ) + + * vcov( ij+ 1,l ) * vcont( ij+ 1,l ) * alpha2p3( ij +1 ) ) + 1 CONTINUE + +c ... correction pour ecin(1,j,l) .... +c ... ecin(1,j,l)= ecin(iip1,j,l) ... + +CDIR$ IVDEP + DO 2 ij = iip2, ip1jm, iip1 + ecin( ij,l ) = ecin( ij + iim, l ) + 2 CONTINUE + +c calcul aux poles ....... + + + DO 3 i = 1, iim + ecinni(i) = vcov( i , l) * vcont( i ,l) * aire( i ) + ecinsi(i) = vcov(i+ip1jmi1,l) * vcont(i+ip1jmi1,l) * aire(i+ip1jm) + 3 CONTINUE + + ecinpn = 0.5 * SSUM( iim,ecinni,1 ) / apoln + ecinps = 0.5 * SSUM( iim,ecinsi,1 ) / apols + + DO 4 ij = 1,iip1 + ecin( ij , l ) = ecinpn + ecin( ij+ ip1jm, l ) = ecinps + 4 CONTINUE + + 5 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/etat0_netcdf.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/etat0_netcdf.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/etat0_netcdf.F (revision 1280) @@ -0,0 +1,791 @@ +! +! $Header$ +! +c +c + SUBROUTINE etat0_netcdf (interbar, masque) +#ifdef CPP_EARTH + USE startvar + USE ioipsl + USE dimphy + USE infotrac + USE fonte_neige_mod + USE pbl_surface_mod + USE phys_state_var_mod + USE filtreg_mod + use regr_lat_time_climoz_m, only: regr_lat_time_climoz + use conf_phys_m, only: conf_phys +#endif +!#endif of #ifdef CPP_EARTH + use netcdf, only: nf90_open, NF90_NOWRITE, nf90_close + ! + IMPLICIT NONE + ! +#include "dimensions.h" +#include "paramet.h" + ! + ! +! INTEGER, PARAMETER :: KIDIA=1, KFDIA=iim*(jjm-1)+2, +! .KLON=KFDIA-KIDIA+1,KLEV=llm + ! +#ifdef CPP_EARTH +#include "comgeom2.h" +#include "comvert.h" +#include "comconst.h" +#include "indicesol.h" +#include "dimsoil.h" +#include "temps.h" +#endif +!#endif of #ifdef CPP_EARTH + ! arguments: + LOGICAL interbar + REAL :: masque(iip1,jjp1) + +#ifdef CPP_EARTH + ! local variables: + REAL :: latfi(klon), lonfi(klon) + REAL :: orog(iip1,jjp1), rugo(iip1,jjp1) + REAL :: psol(iip1, jjp1), phis(iip1, jjp1) + REAL :: p3d(iip1, jjp1, llm+1) + REAL :: uvent(iip1, jjp1, llm) + REAL :: vvent(iip1, jjm, llm) + REAL :: t3d(iip1, jjp1, llm), tpot(iip1, jjp1, llm) + REAL :: qsat(iip1, jjp1, llm) + REAL,ALLOCATABLE :: q3d(:, :, :,:) + REAL :: tsol(klon), qsol(klon), sn(klon) +!! REAL :: tsolsrf(klon,nbsrf) + real qsolsrf(klon,nbsrf),snsrf(klon,nbsrf) + REAL :: albe(klon,nbsrf), evap(klon,nbsrf) + REAL :: alblw(klon,nbsrf) + REAL :: tsoil(klon,nsoilmx,nbsrf) + REAL :: frugs(klon,nbsrf), agesno(klon,nbsrf) + REAL :: rugmer(klon) + REAL :: qd(iip1, jjp1, llm) + REAL :: run_off_lic_0(klon) + ! declarations pour lecture glace de mer + REAL :: rugv(klon) + INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret + INTEGER :: itaul(1), fid + REAL :: lev(1), date + REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic + REAL, ALLOCATABLE, DIMENSION(:) :: dlon_lic, dlat_lic + REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic + REAL :: flic_tmp(iip1, jjp1) + REAL :: champint(iim, jjp1) + ! + + CHARACTER(len=80) :: varname + ! + INTEGER :: i,j, ig, l, ji,ii1,ii2 + REAL :: xpi + ! + REAL :: alpha(iip1,jjp1,llm),beta(iip1,jjp1,llm) + REAL :: pk(iip1,jjp1,llm), pls(iip1,jjp1,llm), pks(ip1jmp1) + REAL :: workvar(iip1,jjp1,llm) + ! + REAL :: prefkap, unskap + ! + real :: time_step,t_ops,t_wrt + +#include "comdissnew.h" +#include "control.h" +#include "serre.h" +#include "clesphys.h" + + INTEGER :: longcles + PARAMETER ( longcles = 20 ) + REAL :: clesphy0 ( longcles ) + REAL :: p(iip1,jjp1,llm) + INTEGER :: itau, iday + REAL :: masse(iip1,jjp1,llm) + REAL :: xpn,xps,xppn(iim),xpps(iim) + real :: time + REAL :: phi(ip1jmp1,llm) + REAL :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL :: w(ip1jmp1,llm) + REAL ::phystep +CC REAL :: rugsrel(iip1*jjp1) + REAL :: fder(klon) +!! real zrel(iip1*jjp1),chmin,chmax + +!! CHARACTER(len=80) :: visu_file + INTEGER :: visuid + +! pour la lecture du fichier masque ocean + integer :: nid_o2a + logical :: couple = .false. + INTEGER :: iml_omask, jml_omask + REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_omask, lat_omask + REAL, ALLOCATABLE, DIMENSION(:) :: dlon_omask, dlat_omask + REAL, ALLOCATABLE, DIMENSION (:,:) :: ocemask, ocetmp + real, dimension(klon) :: ocemask_fi + integer :: isst(klon-2) + real zx_tmp_2d(iim,jjp1) + + REAL :: dummy + + logical :: ok_newmicro + integer :: iflag_radia + logical :: ok_journe, ok_mensuel, ok_instan, ok_hf + logical :: ok_LES + LOGICAL :: ok_ade, ok_aie, aerosol_couple, new_aod + INTEGER :: flag_aerosol + REAL :: bl95_b0, bl95_b1 + real :: fact_cldcon, facttemps,ratqsbas,ratqshaut + real :: tau_ratqs + integer :: iflag_cldcon + integer :: iflag_ratqs + integer :: iflag_coupl + integer :: iflag_clos + integer :: iflag_wake + integer :: iflag_thermals,nsplit_thermals + real :: tau_thermals + integer :: iflag_thermals_ed,iflag_thermals_optflux + REAL :: solarlong0 + real :: seuil_inversion + + integer read_climoz ! read ozone climatology +C Allowed values are 0, 1 and 2 +C 0: do not read an ozone climatology +C 1: read a single ozone climatology that will be used day and night +C 2: read two ozone climatologies, the average day and night +C climatology and the daylight climatology + + ! + ! Constantes + ! + pi = 4. * ATAN(1.) + rad = 6371229. + omeg = 4.* ASIN(1.)/(24.*3600.) + g = 9.8 + daysec = 86400. + kappa = 0.2857143 + cpp = 1004.70885 + ! + preff = 101325. + pa = 50000. + unskap = 1./kappa + ! + jmp1 = jjm + 1 + ! + ! Construct a grid + ! + +! CALL defrun_new(99,.TRUE.,clesphy0) + CALL conf_gcm( 99, .TRUE. , clesphy0 ) + call conf_phys( ok_journe, ok_mensuel, ok_instan, ok_hf, ok_LES, & + & solarlong0,seuil_inversion, & + & fact_cldcon, facttemps,ok_newmicro,iflag_radia, & + & iflag_cldcon, & + & iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, & + & ok_ade, ok_aie, aerosol_couple, & + & flag_aerosol, new_aod, & + & bl95_b0, bl95_b1, & + & iflag_thermals,nsplit_thermals,tau_thermals, & + & iflag_thermals_ed,iflag_thermals_optflux, & + & iflag_coupl,iflag_clos,iflag_wake, read_climoz ) + +! co2_ppm0 : initial value of atmospheric CO2 from .def file (co2_ppm value) + co2_ppm0 = co2_ppm + + dtvr = daysec/FLOAT(day_step) + print*,'dtvr',dtvr + + CALL iniconst() + CALL inigeom() + +! Initialisation pour traceurs + call infotrac_init + ALLOCATE(q3d(iip1, jjp1, llm, nqtot)) + + CALL inifilr() + CALL phys_state_var_init(read_climoz) + ! + latfi(1) = ASIN(1.0) + DO j = 2, jjm + DO i = 1, iim + latfi((j-2)*iim+1+i)= rlatu(j) + ENDDO + ENDDO + latfi(klon) = - ASIN(1.0) + ! + lonfi(1) = 0.0 + DO j = 2, jjm + DO i = 1, iim + lonfi((j-2)*iim+1+i) = rlonv(i) + ENDDO + ENDDO + lonfi(klon) = 0.0 + ! + xpi = 2.0 * ASIN(1.0) + DO ig = 1, klon + latfi(ig) = latfi(ig) * 180.0 / xpi + lonfi(ig) = lonfi(ig) * 180.0 / xpi + ENDDO + ! + rlat(1) = ASIN(1.0) + DO j = 2, jjm + DO i = 1, iim + rlat((j-2)*iim+1+i)= rlatu(j) + ENDDO + ENDDO + rlat(klon) = - ASIN(1.0) + ! + rlon(1) = 0.0 + DO j = 2, jjm + DO i = 1, iim + rlon((j-2)*iim+1+i) = rlonv(i) + ENDDO + ENDDO + rlon(klon) = 0.0 + ! + xpi = 2.0 * ASIN(1.0) + DO ig = 1, klon + rlat(ig) = rlat(ig) * 180.0 / xpi + rlon(ig) = rlon(ig) * 180.0 / xpi + ENDDO + ! + + + +C +C En cas de simulation couplee, lecture du masque ocean issu du modele ocean +C utilise pour calculer les poids et pour assurer l'adequation entre les +C fractions d'ocean vu par l'atmosphere et l'ocean. Sinon, on cree le masque +C a partir du fichier relief +C + + write(*,*)'Essai de lecture masque ocean' + iret = nf90_open("o2a.nc", NF90_NOWRITE, nid_o2a) + if (iret .ne. 0) then + write(*,*)'ATTENTION!! pas de fichier o2a.nc trouve' + write(*,*)'Run force' + varname = 'masque' + masque(:,:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, masque, 0.0, + , jjm ,rlonu,rlatv , interbar ) + WRITE(*,*) 'MASQUE construit : Masque' + WRITE(*,'(97I1)') nINT(masque(:,:)) + call gr_dyn_fi(1, iip1, jjp1, klon, masque, zmasq) + WHERE (zmasq(1 : klon) .LT. EPSFRA) + zmasq(1 : klon) = 0. + END WHERE + WHERE (1. - zmasq(1 : klon) .LT. EPSFRA) + zmasq(1 : klon) = 1. + END WHERE + else + couple = .true. + iret = nf90_close(nid_o2a) + call flininfo("o2a.nc", iml_omask, jml_omask, llm_tmp, ttm_tmp + $ , nid_o2a) + if (iml_omask /= iim .or. jml_omask /= jjp1) then + write(*,*)'Dimensions non compatibles pour masque ocean' + write(*,*)'iim = ',iim,' iml_omask = ',iml_omask + write(*,*)'jjp1 = ',jjp1,' jml_omask = ',jml_omask + stop + endif + ALLOCATE(lat_omask(iml_omask, jml_omask), stat=iret) + ALLOCATE(lon_omask(iml_omask, jml_omask), stat=iret) + ALLOCATE(dlon_omask(iml_omask), stat=iret) + ALLOCATE(dlat_omask(jml_omask), stat=iret) + ALLOCATE(ocemask(iml_omask, jml_omask), stat=iret) + ALLOCATE(ocetmp(iml_omask, jml_omask), stat=iret) + CALL flinopen("o2a.nc", .FALSE., iml_omask, jml_omask, llm_tmp + $ , lon_omask, lat_omask, lev, ttm_tmp, itaul, date, dt, fid) + CALL flinget(fid, 'OceMask', iml_omask, jml_omask, llm_tmp, + $ ttm_tmp, 1, 1, ocetmp) + CALL flinclo(fid) + dlon_omask(1 : iml_omask) = lon_omask(1 : iml_omask, 1) + dlat_omask(1 : jml_omask) = lat_omask(1 , 1 : jml_omask) + ocemask = ocetmp + if (dlat_omask(1) < dlat_omask(jml_omask)) then + do j = 1, jml_omask + ocemask(:,j) = ocetmp(:,jml_omask-j+1) + enddo + endif +C +C passage masque ocean a la grille physique +C + write(*,*)'ocemask ' + write(*,'(96i1)')int(ocemask) + ocemask_fi(1) = ocemask(1,1) + do j = 2, jjm + do i = 1, iim + ocemask_fi((j-2)*iim + i + 1) = ocemask(i,j) + enddo + enddo + ocemask_fi(klon) = ocemask(1,jjp1) + zmasq = 1. - ocemask_fi + endif + + call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque) + + varname = 'relief' + ! This line needs to be replaced by a call to restget to get the values in the restart file + orog(:,:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, orog, 0.0 , + , jjm ,rlonu,rlatv , interbar, masque ) + ! + WRITE(*,*) 'OUT OF GET VARIABLE : Relief' +! WRITE(*,'(49I1)') INT(orog(:,:)) + ! + varname = 'rugosite' + ! This line needs to be replaced by a call to restget to get the values in the restart file + rugo(:,:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, rugo, 0.0 , + , jjm, rlonu,rlatv , interbar ) + ! + WRITE(*,*) 'OUT OF GET VARIABLE : Rugosite' +! WRITE(*,'(49I1)') INT(rugo(:,:)*10) + ! +C +C on initialise les sous surfaces +C + pctsrf=0. +c + varname = 'psol' + psol(:,:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, psol, 0.0 , + , jjm ,rlonu,rlatv , interbar ) + ! + ! Compute here the pressure on the intermediate levels. One would expect that this is available in the GCM + ! anyway. + ! +! WRITE(*,*) 'PSOL :', psol(10,20) +! WRITE(*,*) ap(:), bp(:) + CALL pression(ip1jmp1, ap, bp, psol, p3d) +! WRITE(*,*) 'P3D :', p3d(10,20,:) + CALL exner_hyb(ip1jmp1, psol, p3d, alpha, beta, pks, pk, workvar) +! WRITE(*,*) 'PK:', pk(10,20,:) + ! + ! + ! + prefkap = preff ** kappa +! WRITE(*,*) 'unskap, cpp, preff :', unskap, cpp, preff + DO l = 1, llm + DO j=1,jjp1 + DO i =1, iip1 + pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap + ENDDO + ENDDO + ENDDO + ! +! WRITE(*,*) 'PLS :', pls(10,20,:) + ! + varname = 'surfgeo' + phis(:,:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, phis, 0.0 , + , jjm ,rlonu,rlatv, interbar ) + ! + varname = 'u' + uvent(:,:,:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonu, rlatu, llm, pls, + . workvar, uvent, 0.0, jjm ,rlonv, rlatv, interbar ) + ! + varname = 'v' + vvent(:,:,:) = 0.0 + CALL startget(varname, iip1, jjm, rlonv, rlatv, llm, pls, + . workvar, vvent, 0.0, jjp1, rlonu, rlatu, interbar ) + ! + varname = 't' + t3d(:,:,:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, llm, pls, + . workvar, t3d, 0.0 , jjm, rlonu, rlatv , interbar ) + ! + WRITE(*,*) 'T3D min,max:',minval(t3d(:,:,:)), + . maxval(t3d(:,:,:)) + varname = 'tpot' + tpot(:,:,:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, llm, pls, + . pk, tpot, 0.0 , jjm, rlonu, rlatv , interbar ) + ! + WRITE(*,*) 'T3D min,max:',minval(t3d(:,:,:)), + . maxval(t3d(:,:,:)) + WRITE(*,*) 'PLS min,max:',minval(pls(:,:,:)), + . maxval(pls(:,:,:)) + +c Calcul de l'humidite a saturation + print*,'avant q_sat' + call q_sat(llm*jjp1*iip1,t3d,pls,qsat) + print*,'apres q_sat' + + WRITE(*,*) 'QSAT min,max:',minval(qsat(:,:,:)), + . maxval(qsat(:,:,:)) + ! +CC WRITE(*,*) 'QSAT :', qsat(10,20,:) + ! + varname = 'q' + qd(:,:,:) = 0.0 + q3d(:,:,:,:) = 0.0 + WRITE(*,*) 'QSAT min,max:',minval(qsat(:,:,:)), + . maxval(qsat(:,:,:)) + CALL startget(varname, iip1, jjp1, rlonv, rlatu, llm, pls, + . qsat, qd, 0.0, jjm, rlonu, rlatv , interbar ) + q3d(:,:,:,1) = qd(:,:,:) + ! + +! Ozone climatology: + if (read_climoz >= 1) call regr_lat_time_climoz(read_climoz) + + varname = 'tsol' + ! This line needs to be replaced by a call to restget to get the values in the restart file + tsol(:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, tsol, 0.0, + . jjm, rlonu, rlatv , interbar ) + ! + WRITE(*,*) 'TSOL construit :' +! WRITE(*,'(48I3)') INT(TSOL(2:klon)-273) + ! + varname = 'qsol' + qsol(:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, qsol, 0.0, + . jjm, rlonu, rlatv , interbar ) + ! + varname = 'snow' + sn(:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, sn, 0.0, + . jjm, rlonu, rlatv , interbar ) + ! + varname = 'rads' + radsol(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,radsol,0.0, + . jjm, rlonu, rlatv , interbar ) + ! + varname = 'rugmer' + rugmer(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,rugmer,0.0, + . jjm, rlonu, rlatv , interbar ) + ! +! varname = 'agesno' +! agesno(:) = 0.0 +! CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,agesno,0.0, +! . jjm, rlonu, rlatv , interbar ) + + varname = 'zmea' + zmea(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zmea,0.0, + . jjm, rlonu, rlatv , interbar ) + + varname = 'zstd' + zstd(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zstd,0.0, + . jjm, rlonu, rlatv , interbar ) + varname = 'zsig' + zsig(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zsig,0.0, + . jjm, rlonu, rlatv , interbar ) + varname = 'zgam' + zgam(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zgam,0.0, + . jjm, rlonu, rlatv , interbar ) + varname = 'zthe' + zthe(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zthe,0.0, + . jjm, rlonu, rlatv , interbar ) + varname = 'zpic' + zpic(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zpic,0.0, + . jjm, rlonu, rlatv , interbar ) + varname = 'zval' + zval(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zval,0.0, + . jjm, rlonu, rlatv , interbar ) +c +cc rugsrel(:) = 0.0 +cc IF(ok_orodr) THEN +cc DO i = 1, iip1* jjp1 +cc rugsrel(i) = MAX( 1.e-05, zstd(i)* zsig(i) /2. ) +cc ENDDO +cc ENDIF + + +C +C lecture du fichier glace de terre pour fixer la fraction de terre +C et de glace de terre +C + CALL flininfo("landiceref.nc", iml_lic, jml_lic,llm_tmp, ttm_tmp + $ , fid) + ALLOCATE(lat_lic(iml_lic, jml_lic), stat=iret) + ALLOCATE(lon_lic(iml_lic, jml_lic), stat=iret) + ALLOCATE(dlon_lic(iml_lic), stat=iret) + ALLOCATE(dlat_lic(jml_lic), stat=iret) + ALLOCATE(fraclic(iml_lic, jml_lic), stat=iret) + CALL flinopen("landiceref.nc", .FALSE., iml_lic, jml_lic, llm_tmp + $ , lon_lic, lat_lic, lev, ttm_tmp, itaul, date, dt, fid) + CALL flinget(fid, 'landice', iml_lic, jml_lic, llm_tmp, ttm_tmp + $ , 1, 1, fraclic) + CALL flinclo(fid) +C +C interpolation sur la grille T du modele +C + WRITE(*,*) 'dimensions de landice iml_lic, jml_lic : ', + $ iml_lic, jml_lic +c +C sil les coordonnees sont en degres, on les transforme +C + IF( MAXVAL( lon_lic(:,:) ) .GT. 2.0 * asin(1.0) ) THEN + lon_lic(:,:) = lon_lic(:,:) * 2.0* ASIN(1.0) / 180. + ENDIF + IF( maxval( lat_lic(:,:) ) .GT. 2.0 * asin(1.0)) THEN + lat_lic(:,:) = lat_lic(:,:) * 2.0 * asin(1.0) / 180. + ENDIF + + dlon_lic(1 : iml_lic) = lon_lic(1 : iml_lic, 1) + dlat_lic(1 : jml_lic) = lat_lic(1 , 1 : jml_lic) +C + CALL grille_m(iml_lic, jml_lic, dlon_lic, dlat_lic, fraclic + $ ,iim, jjp1, + $ rlonv, rlatu, flic_tmp(1 : iim, 1 : jjp1)) +cx$$$ flic_tmp(1 : iim, 1 : jjp1) = champint(1: iim, 1 : jjp1) + flic_tmp(iip1, 1 : jjp1) = flic_tmp(1 , 1 : jjp1) +C +C passage sur la grille physique +C + CALL gr_dyn_fi(1, iip1, jjp1, klon, flic_tmp, + $ pctsrf(1:klon, is_lic)) +C adequation avec le maque terre/mer +c zmasq(157) = 0. + WHERE (pctsrf(1 : klon, is_lic) .LT. EPSFRA ) + pctsrf(1 : klon, is_lic) = 0. + END WHERE + WHERE (zmasq( 1 : klon) .LT. EPSFRA) + pctsrf(1 : klon, is_lic) = 0. + END WHERE + pctsrf(1 : klon, is_ter) = zmasq(1 : klon) + DO ji = 1, klon + IF (zmasq(ji) .GT. EPSFRA) THEN + IF ( pctsrf(ji, is_lic) .GE. zmasq(ji)) THEN + pctsrf(ji, is_lic) = zmasq(ji) + pctsrf(ji, is_ter) = 0. + ELSE + pctsrf(ji,is_ter) = zmasq(ji) - pctsrf(ji, is_lic) + IF (pctsrf(ji,is_ter) .LT. EPSFRA) THEN + pctsrf(ji,is_ter) = 0. + pctsrf(ji, is_lic) = zmasq(ji) + ENDIF + ENDIF + ENDIF + END DO +C +C sous surface ocean et glace de mer (pour demarrer on met glace de mer a 0) +C + pctsrf(1 : klon, is_oce) = (1. - zmasq(1 : klon)) + + + WHERE (pctsrf(1 : klon, is_oce) .LT. EPSFRA) + pctsrf(1 : klon, is_oce) = 0. + END WHERE + + if (couple) pctsrf(1 : klon, is_oce) = ocemask_fi(1 : klon) + + isst = 0 + where (pctsrf(2:klon-1,is_oce) >0.) isst = 1 +C +C verif que somme des sous surface = 1 +C + ji=count( (abs( sum(pctsrf(1 : klon, 1 : nbsrf),dim=2))-1.0) + $ .GT. EPSFRA) + IF (ji .NE. 0) THEN + WRITE(*,*) 'pb repartition sous maille pour ',ji,' points' + ENDIF + +! where (pctsrf(1:klon, is_ter) >= .5) +! pctsrf(1:klon, is_ter) = 1. +! pctsrf(1:klon, is_oce) = 0. +! pctsrf(1:klon, is_sic) = 0. +! pctsrf(1:klon, is_lic) = 0. +! zmasq = 1. +! endwhere +! where (pctsrf(1:klon, is_lic) >= .5) +! pctsrf(1:klon, is_ter) = 0. +! pctsrf(1:klon, is_oce) = 0. +! pctsrf(1:klon, is_sic) = 0. +! pctsrf(1:klon, is_lic) = 1. +! zmasq = 1. +! endwhere +! where (pctsrf(1:klon, is_oce) >= .5) +! pctsrf(1:klon, is_ter) = 0. +! pctsrf(1:klon, is_oce) = 1. +! pctsrf(1:klon, is_sic) = 0. +! pctsrf(1:klon, is_lic) = 0. +! zmasq = 0. +! endwhere +! where (pctsrf(1:klon, is_sic) >= .5) +! pctsrf(1:klon, is_ter) = 0. +! pctsrf(1:klon, is_oce) = 0. +! pctsrf(1:klon, is_sic) = 1. +! pctsrf(1:klon, is_lic) = 0. +! zmasq = 0. +! endwhere +! call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque) +C +C verif que somme des sous surface = 1 +C +! ji=count( (abs( sum(pctsrf(1 : klon, 1 : nbsrf), dim = 2)) - 1.0 ) +! $ .GT. EPSFRA) +! IF (ji .NE. 0) THEN +! WRITE(*,*) 'pb repartition sous maille pour ',ji,' points' +! ENDIF + + CALL gr_fi_ecrit(1,klon,iim,jjp1,zmasq,zx_tmp_2d) + write(*,*)'zmasq = ' + write(*,'(96i1)')nint(zx_tmp_2d) + call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque) + WRITE(*,*) 'MASQUE construit : Masque' + WRITE(*,'(97I1)') nINT(masque(:,:)) + + + +C Calcul intermediaire +c + CALL massdair( p3d, masse ) +c + + print *,' ALPHAX ',alphax + + DO l = 1, llm + DO i = 1, iim + xppn(i) = aire( i, 1 ) * masse( i , 1 , l ) + xpps(i) = aire( i,jjp1 ) * masse( i , jjp1 , l ) + ENDDO + xpn = SUM(xppn)/apoln + xps = SUM(xpps)/apols + DO i = 1, iip1 + masse( i , 1 , l ) = xpn + masse( i , jjp1 , l ) = xps + ENDDO + ENDDO + q3d(iip1,:,:,:) = q3d(1,:,:,:) + phis(iip1,:) = phis(1,:) + +C Ecriture + CALL inidissip( lstardis, nitergdiv, nitergrot, niterh , + * tetagdiv, tetagrot , tetatemp ) + print*,'sortie inidissip' + itau = 0 + itau_dyn = 0 + itau_phy = 0 + iday = dayref +itau/day_step + time = real(itau-(iday-dayref)*day_step)/day_step +c + IF(time.GT.1) THEN + time = time - 1 + iday = iday + 1 + ENDIF + day_ref = dayref + annee_ref = anneeref + + CALL geopot ( ip1jmp1, tpot , pk , pks, phis , phi ) + print*,'sortie geopot' + + CALL caldyn0 ( itau,uvent,vvent,tpot,psol,masse,pk,phis , + * phi,w, pbaru,pbarv,time+iday-dayref ) + print*,'sortie caldyn0' + CALL dynredem0("start.nc",dayref,phis) + print*,'sortie dynredem0' + CALL dynredem1("start.nc",0.0,vvent,uvent,tpot,q3d,masse , + . psol) + print*,'sortie dynredem1' +C +C Ecriture etat initial physique +C + write(*,*)'phystep ',dtvr,iphysiq,nbapp_rad + phystep = dtvr * FLOAT(iphysiq) + radpas = NINT (86400./phystep/ FLOAT(nbapp_rad) ) + write(*,*)'phystep =', phystep, radpas +cIM : lecture de co2_ppm & solaire ds physiq.def +c co2_ppm = 348.0 +c solaire = 1365.0 + +c +c Initialisation +c tsol, qsol, sn,albe, evap,tsoil,rain_fall, snow_fall,solsw, sollw,frugs +c + ftsol(:,is_ter) = tsol + ftsol(:,is_lic) = tsol + ftsol(:,is_oce) = tsol + ftsol(:,is_sic) = tsol + snsrf(:,is_ter) = sn + snsrf(:,is_lic) = sn + snsrf(:,is_oce) = sn + snsrf(:,is_sic) = sn + falb1(:,is_ter) = 0.08 + falb1(:,is_lic) = 0.6 + falb1(:,is_oce) = 0.5 + falb1(:,is_sic) = 0.6 + falb2 = falb1 + evap(:,:) = 0. + qsolsrf(:,is_ter) = 150 + qsolsrf(:,is_lic) = 150 + qsolsrf(:,is_oce) = 150. + qsolsrf(:,is_sic) = 150. + do i = 1, nbsrf + do j = 1, nsoilmx + tsoil(:,j,i) = tsol + enddo + enddo + rain_fall = 0.; snow_fall = 0. + solsw = 165. + sollw = -53. + t_ancien = 273.15 + q_ancien = 0. + agesno = 0. +c + frugs(1:klon,is_oce) = rugmer(1:klon) + frugs(1:klon,is_ter) = MAX(1.0e-05, zstd(1:klon)*zsig(1:klon)/2.0) + frugs(1:klon,is_lic) = MAX(1.0e-05, zstd(1:klon)*zsig(1:klon)/2.0) + frugs(1:klon,is_sic) = 0.001 + fder = 0.0 + clwcon = 0.0 + rnebcon = 0.0 + ratqs = 0.0 + run_off_lic_0 = 0.0 + rugoro = 0.0 + +c +c Avant l'appel a phyredem, on initialize les modules de surface +c avec les valeurs qui vont etre ecrit dans startphy.nc +c + dummy = 1.0 + pbl_tke(:,:,:) = 1.e-8 + zmax0(:) = 40. + f0(:) = 1.e-5 + ema_work1(:,:) = 0. + ema_work2(:,:) = 0. + wake_deltat(:,:) = 0. + wake_deltaq(:,:) = 0. + wake_s(:) = 0. + wake_cstar(:) = 0. + wake_fip(:) = 0. + + call fonte_neige_init(run_off_lic_0) + call pbl_surface_init(qsol, fder, snsrf, qsolsrf, + $ evap, frugs, agesno, tsoil) + + call phyredem("startphy.nc") + + + +C Sortie Visu pour les champs dynamiques +cc if (1.eq.0 ) then +cc print*,'sortie visu' +cc time_step = 1. +cc t_ops = 2. +cc t_wrt = 2. +cc itau = 2. +cc visu_file='Etat0_visu.nc' +cc CALL initdynav(visu_file,dayref,anneeref,time_step, +cc . t_ops, t_wrt, visuid) +cc CALL writedynav(visuid, itau,vvent , +cc . uvent,tpot,pk,phi,q3d,masse,psol,phis) +cc else + print*,'CCCCCCCCCCCCCCCCCC REACTIVER SORTIE VISU DANS ETAT0' +cc endif + print*,'entree histclo' + CALL histclo + +#endif +!#endif of #ifdef CPP_EARTH + RETURN + ! + END SUBROUTINE etat0_netcdf Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/exner_hyb.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/exner_hyb.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/exner_hyb.F (revision 1280) @@ -0,0 +1,114 @@ +! +! $Header$ +! + SUBROUTINE exner_hyb ( ngrid, ps, p,alpha,beta, pks, pk, pkf ) +c +c Auteurs : P.Le Van , Fr. Hourdin . +c .......... +c +c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... +c .... alpha,beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... +c +c ************************************************************************ +c Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des +c couches . Pk(l) sera calcule aux milieux des couches l ,entre les +c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . +c ************************************************************************ +c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont +c la pression et la fonction d'Exner au sol . +c +c -------- z +c A partir des relations ( 1 ) p*dz(pk) = kappa *pk*dz(p) et +c ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1) +c ( voir note de Fr.Hourdin ) , +c +c on determine successivement , du haut vers le bas des couches, les +c coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), +c puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches, +c pk(ij,l) donne par la relation (2), pour l = 2 a l = llm . +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" +#include "serre.h" + + INTEGER ngrid + REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm) + REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm) + +c .... variables locales ... + + INTEGER l, ij + REAL unpl2k,dellta + + REAL ppn(iim),pps(iim) + REAL xpn, xps + REAL SSUM +c + + unpl2k = 1.+ 2.* kappa +c + DO ij = 1, ngrid + pks(ij) = cpp * ( ps(ij)/preff ) ** kappa + ENDDO + + DO ij = 1, iim + ppn(ij) = aire( ij ) * pks( ij ) + pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) + ENDDO + xpn = SSUM(iim,ppn,1) /apoln + xps = SSUM(iim,pps,1) /apols + + DO ij = 1, iip1 + pks( ij ) = xpn + pks( ij+ip1jm ) = xps + ENDDO +c +c +c .... Calcul des coeff. alpha et beta pour la couche l = llm .. +c + DO ij = 1, ngrid + alpha(ij,llm) = 0. + beta (ij,llm) = 1./ unpl2k + ENDDO +c +c ... Calcul des coeff. alpha et beta pour l = llm-1 a l = 2 ... +c + DO l = llm -1 , 2 , -1 +c + DO ij = 1, ngrid + dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k ) + alpha(ij,l) = - p(ij,l+1) / dellta * alpha(ij,l+1) + beta (ij,l) = p(ij,l ) / dellta + ENDDO +c + ENDDO +c +c *********************************************************************** +c ..... Calcul de pk pour la couche 1 , pres du sol .... +c + DO ij = 1, ngrid + pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) ) / + * ( p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) ) + ENDDO +c +c ..... Calcul de pk(ij,l) , pour l = 2 a l = llm ........ +c + DO l = 2, llm + DO ij = 1, ngrid + pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1) + ENDDO + ENDDO +c +c + CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) + + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/extrapol.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/extrapol.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/extrapol.F (revision 1280) @@ -0,0 +1,200 @@ +! +! $Header$ +! +C +C + SUBROUTINE extrapol (pfild, kxlon, kylat, pmask, + . norsud, ldper, knbor, pwork) + IMPLICIT none +c +c OASIS routine (Adaptation: Laurent Li, le 14 mars 1997) +c Fill up missed values by using the neighbor points +c + INTEGER kxlon, kylat ! longitude and latitude dimensions (Input) + INTEGER knbor ! minimum neighbor number (Input) + LOGICAL norsud ! True if field is from North to South (Input) + LOGICAL ldper ! True if take into account the periodicity (Input) + REAL pmask ! mask value (Input) + REAL pfild(kxlon,kylat) ! field to be extrapolated (Input/Output) + REAL pwork(kxlon,kylat) ! working space +c + REAL zwmsk + INTEGER incre, idoit, i, j, k, inbor, ideb, ifin, ilon, jlat + INTEGER ix(9), jy(9) ! index arrays for the neighbors coordinates + REAL zmask(9) +C +C We search over the eight closest neighbors +C +C j+1 7 8 9 +C j 4 5 6 Current point 5 --> (i,j) +C j-1 1 2 3 +C i-1 i i+1 +c +c + IF (norsud) THEN + DO j = 1, kylat + DO i = 1, kxlon + pwork(i,j) = pfild(i,kylat-j+1) + ENDDO + ENDDO + DO j = 1, kylat + DO i = 1, kxlon + pfild(i,j) = pwork(i,j) + ENDDO + ENDDO + ENDIF +c + incre = 0 +c + DO j = 1, kylat + DO i = 1, kxlon + pwork(i,j) = pfild(i,j) + ENDDO + ENDDO +c +C* To avoid problems in floating point tests + zwmsk = pmask - 1.0 +c +200 CONTINUE + incre = incre + 1 + DO 99999 j = 1, kylat + DO 99999 i = 1, kxlon + IF (pfild(i,j).GT. zwmsk) THEN + pwork(i,j) = pfild(i,j) + inbor = 0 + ideb = 1 + ifin = 9 +C +C* Fill up ix array + ix(1) = MAX (1,i-1) + ix(2) = i + ix(3) = MIN (kxlon,i+1) + ix(4) = MAX (1,i-1) + ix(5) = i + ix(6) = MIN (kxlon,i+1) + ix(7) = MAX (1,i-1) + ix(8) = i + ix(9) = MIN (kxlon,i+1) +C +C* Fill up iy array + jy(1) = MAX (1,j-1) + jy(2) = MAX (1,j-1) + jy(3) = MAX (1,j-1) + jy(4) = j + jy(5) = j + jy(6) = j + jy(7) = MIN (kylat,j+1) + jy(8) = MIN (kylat,j+1) + jy(9) = MIN (kylat,j+1) +C +C* Correct latitude bounds if southernmost or northernmost points + IF (j .EQ. 1) ideb = 4 + IF (j .EQ. kylat) ifin = 6 +C +C* Account for periodicity in longitude +C + IF (ldper) THEN + IF (i .EQ. kxlon) THEN + ix(3) = 1 + ix(6) = 1 + ix(9) = 1 + ELSE IF (i .EQ. 1) THEN + ix(1) = kxlon + ix(4) = kxlon + ix(7) = kxlon + ENDIF + ELSE + IF (i .EQ. 1) THEN + ix(1) = i + ix(2) = i + 1 + ix(3) = i + ix(4) = i + 1 + ix(5) = i + ix(6) = i + 1 + ENDIF + IF (i .EQ. kxlon) THEN + ix(1) = i -1 + ix(2) = i + ix(3) = i - 1 + ix(4) = i + ix(5) = i - 1 + ix(6) = i + ENDIF +C + IF (i .EQ. 1 .OR. i .EQ. kxlon) THEN + jy(1) = MAX (1,j-1) + jy(2) = MAX (1,j-1) + jy(3) = j + jy(4) = j + jy(5) = MIN (kylat,j+1) + jy(6) = MIN (kylat,j+1) +C + ideb = 1 + ifin = 6 + IF (j .EQ. 1) ideb = 3 + IF (j .EQ. kylat) ifin = 4 + ENDIF + ENDIF ! end for ldper test +C +C* Find unmasked neighbors +C + DO 230 k = ideb, ifin + zmask(k) = 0. + ilon = ix(k) + jlat = jy(k) + IF (pfild(ilon,jlat) .LT. zwmsk) THEN + zmask(k) = 1. + inbor = inbor + 1 + ENDIF + 230 CONTINUE +C +C* Not enough points around point P are unmasked; interpolation on P +C will be done in a future call to extrap. +C + IF (inbor .GE. knbor) THEN + pwork(i,j) = 0. + DO k = ideb, ifin + ilon = ix(k) + jlat = jy(k) + pwork(i,j) = pwork(i,j) + $ + pfild(ilon,jlat) * zmask(k)/FLOAT(inbor) + ENDDO + ENDIF +C + ENDIF +99999 CONTINUE +C +C* 3. Writing back unmasked field in pfild +C ------------------------------------ +C +C* pfild then contains: +C - Values which were not masked +C - Interpolated values from the inbor neighbors +C - Values which are not yet interpolated +C + idoit = 0 + DO j = 1, kylat + DO i = 1, kxlon + IF (pwork(i,j) .GT. zwmsk) idoit = idoit + 1 + pfild(i,j) = pwork(i,j) + ENDDO + ENDDO +c + IF (idoit .ne. 0) GOTO 200 +ccc PRINT*, "Number of extrapolation steps incre =", incre +c + IF (norsud) THEN + DO j = 1, kylat + DO i = 1, kxlon + pwork(i,j) = pfild(i,kylat-j+1) + ENDDO + ENDDO + DO j = 1, kylat + DO i = 1, kxlon + pfild(i,j) = pwork(i,j) + ENDDO + ENDDO + ENDIF +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/flumass.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/flumass.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/flumass.F (revision 1280) @@ -0,0 +1,109 @@ +! +! $Header$ +! + SUBROUTINE flumass (massebx,masseby, vcont, ucont, pbaru, pbarv ) + + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van, F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c .... calcul du flux de masse aux niveaux s ...... +c ********************************************************************* +c massebx,masseby,vcont et ucont sont des argum. d'entree pour le s-pg . +c pbaru et pbarv sont des argum.de sortie pour le s-pg . +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL massebx( ip1jmp1,llm ),masseby( ip1jm,llm ) , + * vcont( ip1jm,llm ),ucont( ip1jmp1,llm ),pbaru( ip1jmp1,llm ), + * pbarv( ip1jm,llm ) + + REAL apbarun( iip1 ),apbarus( iip1 ) + + REAL sairen,saireun,saires,saireus,ctn,cts,ctn0,cts0 + INTEGER l,ij,i + + REAL SSUM + + + DO 5 l = 1,llm + + DO 1 ij = iip2,ip1jm + pbaru( ij,l ) = massebx( ij,l ) * ucont( ij,l ) + 1 CONTINUE + + DO 3 ij = 1,ip1jm + pbarv( ij,l ) = masseby( ij,l ) * vcont( ij,l ) + 3 CONTINUE + + 5 CONTINUE + +c ................................................................ +c calcul de la composante du flux de masse en x aux poles ....... +c ................................................................ +c par la resolution d'1 systeme de 2 equations . + +c la premiere equat.decrivant le calcul de la divergence en 1 point i +c du pole,ce calcul etant itere de i=1 a i=im . +c c.a.d , +c ( ( 0.5*pbaru(i)-0.5*pbaru(i-1) - pbarv(i))/aire(i) = +c - somme de ( pbarv(n) )/aire pole + +c l'autre equat.specifiant que la moyenne du flux de masse au pole est =0. +c c.a.d somme de pbaru(n)*aire locale(n) = 0. + +c on en revient ainsi a determiner la constante additive commune aux pbaru +c qui representait pbaru(0,j,l) dans l'equat.du calcul de la diverg.au pt +c i=1 . +c i variant de 1 a im +c n variant de 1 a im + + sairen = SSUM( iim, aire( 1 ), 1 ) + saireun= SSUM( iim, aireu( 1 ), 1 ) + saires = SSUM( iim, aire( ip1jm+1 ), 1 ) + saireus= SSUM( iim, aireu( ip1jm+1 ), 1 ) + + DO 20 l = 1,llm + + ctn = SSUM( iim, pbarv( 1 ,l), 1 )/ sairen + cts = SSUM( iim, pbarv(ip1jmi1+ 1,l), 1 )/ saires + + pbaru( 1 ,l )= pbarv( 1 ,l ) - ctn * aire( 1 ) + pbaru( ip1jm+1,l )= - pbarv( ip1jmi1+1,l ) + cts * aire( ip1jm+1 ) + + DO 11 i = 2,iim + pbaru( i ,l ) = pbaru( i - 1 ,l ) + + * pbarv( i ,l ) - ctn * aire( i ) + + pbaru( i+ ip1jm,l ) = pbaru( i+ ip1jm-1,l ) - + * pbarv( i+ ip1jmi1,l ) + cts * aire(i+ ip1jm) + 11 CONTINUE + DO 12 i = 1,iim + apbarun(i) = aireu( i ) * pbaru( i , l) + apbarus(i) = aireu(i +ip1jm) * pbaru(i +ip1jm, l) + 12 CONTINUE + ctn0 = -SSUM( iim,apbarun,1 )/saireun + cts0 = -SSUM( iim,apbarus,1 )/saireus + DO 14 i = 1,iim + pbaru( i , l) = 2. * ( pbaru( i , l) + ctn0 ) + pbaru(i+ ip1jm, l) = 2. * ( pbaru(i +ip1jm, l) + cts0 ) + 14 CONTINUE + + pbaru( iip1 ,l ) = pbaru( 1 ,l ) + pbaru( ip1jmp1,l ) = pbaru( ip1jm +1,l ) + 20 CONTINUE + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fluxstokenc.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fluxstokenc.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fluxstokenc.F (revision 1280) @@ -0,0 +1,173 @@ +! +! $Id$ +! + SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis, + . time_step,itau ) +#ifdef CPP_EARTH +! This routine is designed to work for Earth and with ioipsl + + USE IOIPSL +c +c Auteur : F. Hourdin +c +c +ccc .. Modif. P. Le Van ( 20/12/97 ) ... +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "tracstoke.h" +#include "temps.h" +#include "iniprint.h" + + REAL time_step,t_wrt, t_ops + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm) + REAL phis(ip1jmp1) + + REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm) + REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm) + + REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm) + + REAL pbarvst(iip1,jjp1,llm),zistdyn + real dtcum + + INTEGER iadvtr,ndex(1) + integer nscal + real tst(1),ist(1),istp(1) + INTEGER ij,l,irec,i,j,itau + INTEGER, SAVE :: fluxid, fluxvid,fluxdid + + SAVE iadvtr, massem,pbaruc,pbarvc,irec + SAVE phic,tetac + logical first + save first + data first/.true./ + DATA iadvtr/0/ + + +c AC initialisations + pbarug(:,:) = 0. + pbarvg(:,:,:) = 0. + wg(:,:) = 0. + + + if(first) then + + CALL initfluxsto( 'fluxstoke', + . time_step,istdyn* time_step,istdyn* time_step, + . fluxid,fluxvid,fluxdid) + + ndex(1) = 0 + call histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex) + call histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex) + + ndex(1) = 0 + nscal = 1 + tst(1) = time_step + call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex) + ist(1)=istdyn + call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex) + istp(1)= istphy + call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex) + + first = .false. + + endif + + + IF(iadvtr.EQ.0) THEN + CALL initial0(ijp1llm,phic) + CALL initial0(ijp1llm,tetac) + CALL initial0(ijp1llm,pbaruc) + CALL initial0(ijmllm,pbarvc) + ENDIF + +c accumulation des flux de masse horizontaux + DO l=1,llm + DO ij = 1,ip1jmp1 + pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l) + tetac(ij,l) = tetac(ij,l) + teta(ij,l) + phic(ij,l) = phic(ij,l) + phi(ij,l) + ENDDO + DO ij = 1,ip1jm + pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l) + ENDDO + ENDDO + +c selection de la masse instantannee des mailles avant le transport. + IF(iadvtr.EQ.0) THEN + CALL SCOPY(ip1jmp1*llm,masse,1,massem,1) + ENDIF + + iadvtr = iadvtr+1 + + +c Test pour savoir si on advecte a ce pas de temps + IF ( iadvtr.EQ.istdyn ) THEN +c normalisation + DO l=1,llm + DO ij = 1,ip1jmp1 + pbaruc(ij,l) = pbaruc(ij,l)/float(istdyn) + tetac(ij,l) = tetac(ij,l)/float(istdyn) + phic(ij,l) = phic(ij,l)/float(istdyn) + ENDDO + DO ij = 1,ip1jm + pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn) + ENDDO + ENDDO + +c traitement des flux de masse avant advection. +c 1. calcul de w +c 2. groupement des mailles pres du pole. + + CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg ) + + do l=1,llm + do j=1,jjm + do i=1,iip1 + pbarvst(i,j,l)=pbarvg(i,j,l) + enddo + enddo + do i=1,iip1 + pbarvst(i,jjp1,l)=0. + enddo + enddo + + iadvtr=0 + Print*,'ITAU auqel on stoke les fluxmasses',itau + + call histwrite(fluxid, 'masse', itau, massem, + . iip1*jjp1*llm, ndex) + + call histwrite(fluxid, 'pbaru', itau, pbarug, + . iip1*jjp1*llm, ndex) + + call histwrite(fluxvid, 'pbarv', itau, pbarvg, + . iip1*jjm*llm, ndex) + + call histwrite(fluxid, 'w' ,itau, wg, + . iip1*jjp1*llm, ndex) + + call histwrite(fluxid, 'teta' ,itau, tetac, + . iip1*jjp1*llm, ndex) + + call histwrite(fluxid, 'phi' ,itau, phic, + . iip1*jjp1*llm, ndex) + +C + + ENDIF ! if iadvtr.EQ.istdyn + +#else + write(lunout,*) + & 'fluxstokenc: Needs Earth physics (and ioipsl) to function' +#endif +! of #ifdef CPP_EARTH + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/friction.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/friction.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/friction.F (revision 1280) @@ -0,0 +1,99 @@ +! +! $Header$ +! +c======================================================================= + SUBROUTINE friction(ucov,vcov,pdt) + IMPLICIT NONE + +c======================================================================= +c +c +c Objet: +c ------ +c +c *********** +c Friction +c *********** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "control.h" +#include "comconst.h" + + REAL pdt + REAL modv(iip1,jjp1),zco,zsi + REAL vpn,vps,upoln,upols,vpols,vpoln + REAL u2(iip1,jjp1),v2(iip1,jjm) + REAL ucov( iip1,jjp1,llm ),vcov( iip1,jjm,llm ) + INTEGER i,j + REAL cfric + parameter (cfric=1.e-5) + + +c calcul des composantes au carre du vent naturel + do j=1,jjp1 + do i=1,iip1 + u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j) + enddo + enddo + do j=1,jjm + do i=1,iip1 + v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j) + enddo + enddo + +c calcul du module de V en dehors des poles + do j=2,jjm + do i=2,iip1 + modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j))) + enddo + modv(1,j)=modv(iip1,j) + enddo + +c les deux composantes du vent au pole sont obtenues comme +c premiers modes de fourier de v pres du pole + upoln=0. + vpoln=0. + upols=0. + vpols=0. + do i=2,iip1 + zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1)) + zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1)) + vpn=vcov(i,1,1)/cv(i,1) + vps=vcov(i,jjm,1)/cv(i,jjm) + upoln=upoln+zco*vpn + vpoln=vpoln+zsi*vpn + upols=upols+zco*vps + vpols=vpols+zsi*vps + enddo + vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi + vps=sqrt(upols*upols+vpols*vpols)/pi + do i=1,iip1 +c modv(i,1)=vpn +c modv(i,jjp1)=vps + modv(i,1)=modv(i,2) + modv(i,jjp1)=modv(i,jjm) + enddo + +c calcul du frottement au sol. + do j=2,jjm + do i=1,iim + ucov(i,j,1)=ucov(i,j,1) + s -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1) + enddo + ucov(iip1,j,1)=ucov(1,j,1) + enddo + do j=1,jjm + do i=1,iip1 + vcov(i,j,1)=vcov(i,j,1) + s -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1) + enddo + vcov(iip1,j,1)=vcov(1,j,1) + enddo + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fxhyp.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fxhyp.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fxhyp.F (revision 1280) @@ -0,0 +1,448 @@ +! +! $Header$ +! +c +c + SUBROUTINE fxhyp ( xzoomdeg,grossism,dzooma,tau , + , rlonm025,xprimm025,rlonv,xprimv,rlonu,xprimu,rlonp025,xprimp025, + , champmin,champmax ) + +c Auteur : P. Le Van + + IMPLICIT NONE + +c Calcule les longitudes et derivees dans la grille du GCM pour une +c fonction f(x) a tangente hyperbolique . +c +c grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois,etc.) +c dzoom etant la distance totale de la zone du zoom +c tau la raideur de la transition de l'interieur a l'exterieur du zoom +c +c On doit avoir grossism x dzoom < pi ( radians ) , en longitude. +c ******************************************************************** + + + INTEGER nmax, nmax2 + PARAMETER ( nmax = 30000, nmax2 = 2*nmax ) +c + LOGICAL scal180 + PARAMETER ( scal180 = .TRUE. ) + +c scal180 = .TRUE. si on veut avoir le premier point scalaire pour +c une grille reguliere ( grossism = 1.,tau=0.,clon=0. ) a -180. degres. +c sinon scal180 = .FALSE. + +#include "dimensions.h" +#include "paramet.h" + +c ...... arguments d'entree ....... +c + REAL xzoomdeg,dzooma,tau,grossism + +c ...... arguments de sortie ...... + + REAL rlonm025(iip1),xprimm025(iip1),rlonv(iip1),xprimv(iip1), + , rlonu(iip1),xprimu(iip1),rlonp025(iip1),xprimp025(iip1) + +c .... variables locales .... +c + REAL dzoom + REAL(KIND=8) xlon(iip1),xprimm(iip1),xuv + REAL(KIND=8) xtild(0:nmax2) + REAL(KIND=8) fhyp(0:nmax2),ffdx,beta,Xprimt(0:nmax2) + REAL(KIND=8) Xf(0:nmax2),xxpr(0:nmax2) + REAL(KIND=8) xvrai(iip1),xxprim(iip1) + REAL(KIND=8) pi,depi,epsilon,xzoom,fa,fb + REAL(KIND=8) Xf1, Xfi , a0,a1,a2,a3,xi2 + INTEGER i,it,ik,iter,ii,idif,ii1,ii2 + REAL(KIND=8) xi,xo1,xmoy,xlon2,fxm,Xprimin + REAL(KIND=8) champmin,champmax,decalx + INTEGER is2 + SAVE is2 + + REAL(KIND=8) heavyside + + pi = 2. * ASIN(1.) + depi = 2. * pi + epsilon = 1.e-3 + xzoom = xzoomdeg * pi/180. +c + decalx = .75 + IF( grossism.EQ.1..AND.scal180 ) THEN + decalx = 1. + ENDIF + + WRITE(6,*) 'FXHYP scal180,decalx', scal180,decalx +c + IF( dzooma.LT.1.) THEN + dzoom = dzooma * depi + ELSEIF( dzooma.LT. 25. ) THEN + WRITE(6,*) ' Le param. dzoomx pour fxhyp est trop petit ! L aug + ,menter et relancer ! ' + STOP 1 + ELSE + dzoom = dzooma * pi/180. + ENDIF + + WRITE(6,*) ' xzoom( rad.),grossism,tau,dzoom (radians)' + WRITE(6,24) xzoom,grossism,tau,dzoom + + DO i = 0, nmax2 + xtild(i) = - pi + FLOAT(i) * depi /nmax2 + ENDDO + + DO i = nmax, nmax2 + + fa = tau* ( dzoom/2. - xtild(i) ) + fb = xtild(i) * ( pi - xtild(i) ) + + IF( 200.* fb .LT. - fa ) THEN + fhyp ( i) = - 1. + ELSEIF( 200. * fb .LT. fa ) THEN + fhyp ( i) = 1. + ELSE + IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13) THEN + IF( 200.*fb + fa.LT.1.e-10 ) THEN + fhyp ( i ) = - 1. + ELSEIF( 200.*fb - fa.LT.1.e-10 ) THEN + fhyp ( i ) = 1. + ENDIF + ELSE + fhyp ( i ) = TANH ( fa/fb ) + ENDIF + ENDIF + IF ( xtild(i).EQ. 0. ) fhyp(i) = 1. + IF ( xtild(i).EQ. pi ) fhyp(i) = -1. + + ENDDO + +cc .... Calcul de beta .... + + ffdx = 0. + + DO i = nmax +1,nmax2 + + xmoy = 0.5 * ( xtild(i-1) + xtild( i ) ) + fa = tau* ( dzoom/2. - xmoy ) + fb = xmoy * ( pi - xmoy ) + + IF( 200.* fb .LT. - fa ) THEN + fxm = - 1. + ELSEIF( 200. * fb .LT. fa ) THEN + fxm = 1. + ELSE + IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13) THEN + IF( 200.*fb + fa.LT.1.e-10 ) THEN + fxm = - 1. + ELSEIF( 200.*fb - fa.LT.1.e-10 ) THEN + fxm = 1. + ENDIF + ELSE + fxm = TANH ( fa/fb ) + ENDIF + ENDIF + + IF ( xmoy.EQ. 0. ) fxm = 1. + IF ( xmoy.EQ. pi ) fxm = -1. + + ffdx = ffdx + fxm * ( xtild(i) - xtild(i-1) ) + + ENDDO + + beta = ( grossism * ffdx - pi ) / ( ffdx - pi ) + + IF( 2.*beta - grossism.LE. 0.) THEN + WRITE(6,*) ' ** Attention ! La valeur beta calculee dans la rou + ,tine fxhyp est mauvaise ! ' + WRITE(6,*)'Modifier les valeurs de grossismx ,tau ou dzoomx ', + , ' et relancer ! *** ' + CALL ABORT + ENDIF +c +c ..... calcul de Xprimt ..... +c + + DO i = nmax, nmax2 + Xprimt(i) = beta + ( grossism - beta ) * fhyp(i) + ENDDO +c + DO i = nmax+1, nmax2 + Xprimt( nmax2 - i ) = Xprimt( i ) + ENDDO +c + +c ..... Calcul de Xf ........ + + Xf(0) = - pi + + DO i = nmax +1, nmax2 + + xmoy = 0.5 * ( xtild(i-1) + xtild( i ) ) + fa = tau* ( dzoom/2. - xmoy ) + fb = xmoy * ( pi - xmoy ) + + IF( 200.* fb .LT. - fa ) THEN + fxm = - 1. + ELSEIF( 200. * fb .LT. fa ) THEN + fxm = 1. + ELSE + fxm = TANH ( fa/fb ) + ENDIF + + IF ( xmoy.EQ. 0. ) fxm = 1. + IF ( xmoy.EQ. pi ) fxm = -1. + xxpr(i) = beta + ( grossism - beta ) * fxm + + ENDDO + + DO i = nmax+1, nmax2 + xxpr(nmax2-i+1) = xxpr(i) + ENDDO + + DO i=1,nmax2 + Xf(i) = Xf(i-1) + xxpr(i) * ( xtild(i) - xtild(i-1) ) + ENDDO + + +c ***************************************************************** +c + +c ..... xuv = 0. si calcul aux pts scalaires ........ +c ..... xuv = 0.5 si calcul aux pts U ........ +c + WRITE(6,18) +c + DO 5000 ik = 1, 4 + + IF( ik.EQ.1 ) THEN + xuv = -0.25 + ELSE IF ( ik.EQ.2 ) THEN + xuv = 0. + ELSE IF ( ik.EQ.3 ) THEN + xuv = 0.50 + ELSE IF ( ik.EQ.4 ) THEN + xuv = 0.25 + ENDIF + + xo1 = 0. + + ii1=1 + ii2=iim + IF(ik.EQ.1.and.grossism.EQ.1.) THEN + ii1 = 2 + ii2 = iim+1 + ENDIF + DO 1500 i = ii1, ii2 + + xlon2 = - pi + (FLOAT(i) + xuv - decalx) * depi / FLOAT(iim) + + Xfi = xlon2 +c + DO 250 it = nmax2,0,-1 + IF( Xfi.GE.Xf(it)) GO TO 350 +250 CONTINUE + + it = 0 + +350 CONTINUE + +c ...... Calcul de Xf(xi) ...... +c + xi = xtild(it) + + IF(it.EQ.nmax2) THEN + it = nmax2 -1 + Xf(it+1) = pi + ENDIF +c ..................................................................... +c +c Appel de la routine qui calcule les coefficients a0,a1,a2,a3 d'un +c polynome de degre 3 qui passe par les points (Xf(it),xtild(it) ) +c et (Xf(it+1),xtild(it+1) ) + + CALL coefpoly ( Xf(it),Xf(it+1),Xprimt(it),Xprimt(it+1), + , xtild(it),xtild(it+1), a0, a1, a2, a3 ) + + Xf1 = Xf(it) + Xprimin = a1 + 2.* a2 * xi + 3.*a3 * xi *xi + + DO 500 iter = 1,300 + xi = xi - ( Xf1 - Xfi )/ Xprimin + + IF( ABS(xi-xo1).LE.epsilon) GO TO 550 + xo1 = xi + xi2 = xi * xi + Xf1 = a0 + a1 * xi + a2 * xi2 + a3 * xi2 * xi + Xprimin = a1 + 2.* a2 * xi + 3.* a3 * xi2 +500 CONTINUE + WRITE(6,*) ' Pas de solution ***** ',i,xlon2,iter + STOP 6 +550 CONTINUE + + xxprim(i) = depi/ ( FLOAT(iim) * Xprimin ) + xvrai(i) = xi + xzoom + +1500 CONTINUE + + + IF(ik.EQ.1.and.grossism.EQ.1.) THEN + xvrai(1) = xvrai(iip1)-depi + xxprim(1) = xxprim(iip1) + ENDIF + DO i = 1 , iim + xlon(i) = xvrai(i) + xprimm(i) = xxprim(i) + ENDDO + DO i = 1, iim -1 + IF( xvrai(i+1). LT. xvrai(i) ) THEN + WRITE(6,*) ' PBS. avec rlonu(',i+1,') plus petit que rlonu(',i, + , ')' + STOP 7 + ENDIF + ENDDO +c +c ... Reorganisation des longitudes pour les avoir entre - pi et pi .. +c ........................................................................ + + champmin = 1.e12 + champmax = -1.e12 + DO i = 1, iim + champmin = MIN( champmin,xvrai(i) ) + champmax = MAX( champmax,xvrai(i) ) + ENDDO + + IF(champmin .GE.-pi-0.10.and.champmax.LE.pi+0.10 ) THEN + GO TO 1600 + ELSE + WRITE(6,*) 'Reorganisation des longitudes pour avoir entre - pi', + , ' et pi ' +c + IF( xzoom.LE.0.) THEN + IF( ik.EQ. 1 ) THEN + DO i = 1, iim + IF( xvrai(i).GE. - pi ) GO TO 80 + ENDDO + WRITE(6,*) ' PBS. 1 ! Xvrai plus petit que - pi ! ' + STOP 8 + 80 CONTINUE + is2 = i + ENDIF + + IF( is2.NE. 1 ) THEN + DO ii = is2 , iim + xlon (ii-is2+1) = xvrai(ii) + xprimm(ii-is2+1) = xxprim(ii) + ENDDO + DO ii = 1 , is2 -1 + xlon (ii+iim-is2+1) = xvrai(ii) + depi + xprimm(ii+iim-is2+1) = xxprim(ii) + ENDDO + ENDIF + ELSE + IF( ik.EQ.1 ) THEN + DO i = iim,1,-1 + IF( xvrai(i).LE. pi ) GO TO 90 + ENDDO + WRITE(6,*) ' PBS. 2 ! Xvrai plus grand que pi ! ' + STOP 9 + 90 CONTINUE + is2 = i + ENDIF + idif = iim -is2 + DO ii = 1, is2 + xlon (ii+idif) = xvrai(ii) + xprimm(ii+idif) = xxprim(ii) + ENDDO + DO ii = 1, idif + xlon (ii) = xvrai (ii+is2) - depi + xprimm(ii) = xxprim(ii+is2) + ENDDO + ENDIF + ENDIF +c +c ......... Fin de la reorganisation ............................ + + 1600 CONTINUE + + + xlon ( iip1) = xlon(1) + depi + xprimm( iip1 ) = xprimm (1 ) + + DO i = 1, iim+1 + xvrai(i) = xlon(i)*180./pi + ENDDO + + IF( ik.EQ.1 ) THEN +c WRITE(6,*) ' XLON aux pts. V-0.25 apres ( en deg. ) ' +c WRITE(6,18) +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM k ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim +1 + rlonm025(i) = xlon( i ) + xprimm025(i) = xprimm(i) + ENDDO + ELSE IF( ik.EQ.2 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' XLON aux pts. V apres ( en deg. ) ' +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM k ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim + 1 + rlonv(i) = xlon( i ) + xprimv(i) = xprimm(i) + ENDDO + + ELSE IF( ik.EQ.3) THEN +c WRITE(6,18) +c WRITE(6,*) ' XLON aux pts. U apres ( en deg. ) ' +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM ik ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim + 1 + rlonu(i) = xlon( i ) + xprimu(i) = xprimm(i) + ENDDO + + ELSE IF( ik.EQ.4 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' XLON aux pts. V+0.25 apres ( en deg. ) ' +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM ik ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim + 1 + rlonp025(i) = xlon( i ) + xprimp025(i) = xprimm(i) + ENDDO + + ENDIF + +5000 CONTINUE +c + WRITE(6,18) +c +c ........... fin de la boucle do 5000 ............ + + DO i = 1, iim + xlon(i) = rlonv(i+1) - rlonv(i) + ENDDO + champmin = 1.e12 + champmax = -1.e12 + DO i = 1, iim + champmin = MIN( champmin, xlon(i) ) + champmax = MAX( champmax, xlon(i) ) + ENDDO + champmin = champmin * 180./pi + champmax = champmax * 180./pi + +18 FORMAT(/) +24 FORMAT(2x,'Parametres xzoom,gross,tau ,dzoom pour fxhyp ',4f8.3) +68 FORMAT(1x,7f9.2) +566 FORMAT(1x,7f9.4) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fxy.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fxy.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fxy.F (revision 1280) @@ -0,0 +1,69 @@ +! +! $Header$ +! + SUBROUTINE fxy (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + IMPLICIT NONE + +c Auteur : P. Le Van +c +c Calcul des longitudes et des latitudes pour une fonction f(x,y) +c a tangente sinusoidale et eventuellement avec zoom . +c +c +#include "dimensions.h" +#include "paramet.h" +#include "serre.h" +#include "comconst.h" + + INTEGER i,j + + REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1), + , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1) + +#include "fxy_new.h" + + +c ...... calcul des latitudes et de y' ..... +c + DO j = 1, jjm + 1 + rlatu(j) = fy ( FLOAT( j ) ) + yprimu(j) = fyprim( FLOAT( j ) ) + ENDDO + + + DO j = 1, jjm + + rlatv(j) = fy ( FLOAT( j ) + 0.5 ) + rlatu1(j) = fy ( FLOAT( j ) + 0.25 ) + rlatu2(j) = fy ( FLOAT( j ) + 0.75 ) + + yprimv(j) = fyprim( FLOAT( j ) + 0.5 ) + yprimu1(j) = fyprim( FLOAT( j ) + 0.25 ) + yprimu2(j) = fyprim( FLOAT( j ) + 0.75 ) + + ENDDO + +c +c ..... calcul des longitudes et de x' ..... +c + DO i = 1, iim + 1 + rlonv(i) = fx ( FLOAT( i ) ) + rlonu(i) = fx ( FLOAT( i ) + 0.5 ) + rlonm025(i) = fx ( FLOAT( i ) - 0.25 ) + rlonp025(i) = fx ( FLOAT( i ) + 0.25 ) + + xprimv (i) = fxprim ( FLOAT( i ) ) + xprimu (i) = fxprim ( FLOAT( i ) + 0.5 ) + xprimm025(i) = fxprim ( FLOAT( i ) - 0.25 ) + xprimp025(i) = fxprim ( FLOAT( i ) + 0.25 ) + ENDDO + +c + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fxyhyper.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fxyhyper.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fxyhyper.F (revision 1280) @@ -0,0 +1,139 @@ +! +! $Header$ +! +c +c + SUBROUTINE fxyhyper ( yzoom, grossy, dzoomy,tauy , + , xzoom, grossx, dzoomx,taux , + , rlatu,yprimu,rlatv,yprimv,rlatu1, yprimu1, rlatu2, yprimu2 , + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + IMPLICIT NONE +c +c Auteur : P. Le Van . +c +c d'apres formulations de R. Sadourny . +c +c +c Ce spg calcule les latitudes( routine fyhyp ) et longitudes( fxhyp ) +c par des fonctions a tangente hyperbolique . +c +c Il y a 3 parametres ,en plus des coordonnees du centre du zoom (xzoom +c et yzoom ) : +c +c a) le grossissement du zoom : grossy ( en y ) et grossx ( en x ) +c b) l' extension du zoom : dzoomy ( en y ) et dzoomx ( en x ) +c c) la raideur de la transition du zoom : taux et tauy +c +c N.B : Il vaut mieux avoir : grossx * dzoomx < pi ( radians ) +c ****** +c et grossy * dzoomy < pi/2 ( radians ) +c +#include "dimensions.h" +#include "paramet.h" + + +c ..... Arguments ... +c + REAL xzoom,yzoom,grossx,grossy,dzoomx,dzoomy,taux,tauy + REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1), + , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1) + REAL(KIND=8) dxmin, dxmax , dymin, dymax + +c .... var. locales ..... +c + INTEGER i,j +c + + CALL fyhyp ( yzoom, grossy, dzoomy,tauy , + , rlatu, yprimu,rlatv,yprimv,rlatu2,yprimu2,rlatu1,yprimu1 , + , dymin,dymax ) + + CALL fxhyp(xzoom,grossx,dzoomx,taux,rlonm025,xprimm025,rlonv, + , xprimv,rlonu,xprimu,rlonp025,xprimp025 , dxmin,dxmax ) + + + DO i = 1, iip1 + IF(rlonp025(i).LT.rlonv(i)) THEN + WRITE(6,*) ' Attention ! rlonp025 < rlonv',i + STOP + ENDIF + + IF(rlonv(i).LT.rlonm025(i)) THEN + WRITE(6,*) ' Attention ! rlonm025 > rlonv',i + STOP + ENDIF + + IF(rlonp025(i).GT.rlonu(i)) THEN + WRITE(6,*) ' Attention ! rlonp025 > rlonu',i + STOP + ENDIF + ENDDO + + WRITE(6,*) ' *** TEST DE COHERENCE OK POUR FX **** ' + +c + DO j = 1, jjm +c + IF(rlatu1(j).LE.rlatu2(j)) THEN + WRITE(6,*)'Attention ! rlatu1 < rlatu2 ',rlatu1(j), rlatu2(j),j + STOP 13 + ENDIF +c + IF(rlatu2(j).LE.rlatu(j+1)) THEN + WRITE(6,*)'Attention ! rlatu2 < rlatup1 ',rlatu2(j),rlatu(j+1),j + STOP 14 + ENDIF +c + IF(rlatu(j).LE.rlatu1(j)) THEN + WRITE(6,*)' Attention ! rlatu < rlatu1 ',rlatu(j),rlatu1(j),j + STOP 15 + ENDIF +c + IF(rlatv(j).LE.rlatu2(j)) THEN + WRITE(6,*)' Attention ! rlatv < rlatu2 ',rlatv(j),rlatu2(j),j + STOP 16 + ENDIF +c + IF(rlatv(j).ge.rlatu1(j)) THEN + WRITE(6,*)' Attention ! rlatv > rlatu1 ',rlatv(j),rlatu1(j),j + STOP 17 + ENDIF +c + IF(rlatv(j).ge.rlatu(j)) THEN + WRITE(6,*) ' Attention ! rlatv > rlatu ',rlatv(j),rlatu(j),j + STOP 18 + ENDIF +c + ENDDO +c + WRITE(6,*) ' *** TEST DE COHERENCE OK POUR FY **** ' +c + WRITE(6,18) + WRITE(6,*) ' Latitudes ' + WRITE(6,*) ' *********** ' + WRITE(6,18) + WRITE(6,3) dymin, dymax + WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par + ,ametres grossism , tau , dzoom pour Y et repasser ! ' +c + WRITE(6,18) + WRITE(6,*) ' Longitudes ' + WRITE(6,*) ' ************ ' + WRITE(6,18) + WRITE(6,3) dxmin, dxmax + WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par + ,ametres grossism , tau , dzoom pour Y et repasser ! ' + WRITE(6,18) +c +3 Format(1x, ' Au centre du zoom , la longueur de la maille est', + , ' d environ ',f8.2 ,' degres ', + , ' alors que la maille en dehors de la zone du zoom est d environ + , ', f8.2,' degres ' ) +18 FORMAT(/) + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fxysinus.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fxysinus.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fxysinus.F (revision 1280) @@ -0,0 +1,69 @@ +! +! $Header$ +! + SUBROUTINE fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + + IMPLICIT NONE +c +c Calcul des longitudes et des latitudes pour une fonction f(x,y) +c avec y = Asin( j ) . +c +c Auteur : P. Le Van +c +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" + + INTEGER i,j + + REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1), + , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1) + +#include "fxy_sin.h" + + +c ...... calcul des latitudes et de y' ..... +c + DO j = 1, jjm + 1 + rlatu(j) = fy ( FLOAT( j ) ) + yprimu(j) = fyprim( FLOAT( j ) ) + ENDDO + + + DO j = 1, jjm + + rlatv(j) = fy ( FLOAT( j ) + 0.5 ) + rlatu1(j) = fy ( FLOAT( j ) + 0.25 ) + rlatu2(j) = fy ( FLOAT( j ) + 0.75 ) + + yprimv(j) = fyprim( FLOAT( j ) + 0.5 ) + yprimu1(j) = fyprim( FLOAT( j ) + 0.25 ) + yprimu2(j) = fyprim( FLOAT( j ) + 0.75 ) + + ENDDO + +c +c ..... calcul des longitudes et de x' ..... +c + DO i = 1, iim + 1 + rlonv(i) = fx ( FLOAT( i ) ) + rlonu(i) = fx ( FLOAT( i ) + 0.5 ) + rlonm025(i) = fx ( FLOAT( i ) - 0.25 ) + rlonp025(i) = fx ( FLOAT( i ) + 0.25 ) + + xprimv (i) = fxprim ( FLOAT( i ) ) + xprimu (i) = fxprim ( FLOAT( i ) + 0.5 ) + xprimm025(i) = fxprim ( FLOAT( i ) - 0.25 ) + xprimp025(i) = fxprim ( FLOAT( i ) + 0.25 ) + ENDDO + +c + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fyhyp.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fyhyp.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/fyhyp.F (revision 1280) @@ -0,0 +1,378 @@ +! +! $Header$ +! +c +c + SUBROUTINE fyhyp ( yzoomdeg, grossism, dzooma,tau , + , rrlatu,yyprimu,rrlatv,yyprimv,rlatu2,yprimu2,rlatu1,yprimu1 , + , champmin,champmax ) + +cc ... Version du 01/04/2001 .... + + IMPLICIT NONE +c +c ... Auteur : P. Le Van ... +c +c ....... d'apres formulations de R. Sadourny ....... +c +c Calcule les latitudes et derivees dans la grille du GCM pour une +c fonction f(y) a tangente hyperbolique . +c +c grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois , etc) +c dzoom etant la distance totale de la zone du zoom ( en radians ) +c tau la raideur de la transition de l'interieur a l'exterieur du zoom +c +c +c N.B : Il vaut mieux avoir : grossism * dzoom < pi/2 (radians) ,en lati. +c ******************************************************************** +c +c +#include "dimensions.h" +#include "paramet.h" + + INTEGER nmax , nmax2 + PARAMETER ( nmax = 30000, nmax2 = 2*nmax ) +c +c +c ....... arguments d'entree ....... +c + REAL yzoomdeg, grossism,dzooma,tau +c ( rentres par run.def ) + +c ....... arguments de sortie ....... +c + REAL rrlatu(jjp1), yyprimu(jjp1),rrlatv(jjm), yyprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + +c +c ..... champs locaux ..... +c + + REAL dzoom + REAL(KIND=8) ylat(jjp1), yprim(jjp1) + REAL(KIND=8) yuv + REAL(KIND=8) yt(0:nmax2) + REAL(KIND=8) fhyp(0:nmax2),beta,Ytprim(0:nmax2),fxm(0:nmax2) + SAVE Ytprim, yt,Yf + REAL(KIND=8) Yf(0:nmax2),yypr(0:nmax2) + REAL(KIND=8) yvrai(jjp1), yprimm(jjp1),ylatt(jjp1) + REAL(KIND=8) pi,depi,pis2,epsilon,y0,pisjm + REAL(KIND=8) yo1,yi,ylon2,ymoy,Yprimin,champmin,champmax + REAL(KIND=8) yfi,Yf1,ffdy + REAL(KIND=8) ypn,deply,y00 + SAVE y00, deply + + INTEGER i,j,it,ik,iter,jlat + INTEGER jpn,jjpn + SAVE jpn + REAL(KIND=8) a0,a1,a2,a3,yi2,heavyy0,heavyy0m + REAL(KIND=8) fa(0:nmax2),fb(0:nmax2) + REAL y0min,y0max + + REAL(KIND=8) heavyside + + pi = 2. * ASIN(1.) + depi = 2. * pi + pis2 = pi/2. + pisjm = pi/ FLOAT(jjm) + epsilon = 1.e-3 + y0 = yzoomdeg * pi/180. + + IF( dzooma.LT.1.) THEN + dzoom = dzooma * pi + ELSEIF( dzooma.LT. 12. ) THEN + WRITE(6,*) ' Le param. dzoomy pour fyhyp est trop petit ! L aug + ,menter et relancer ! ' + STOP 1 + ELSE + dzoom = dzooma * pi/180. + ENDIF + + WRITE(6,18) + WRITE(6,*) ' yzoom( rad.),grossism,tau,dzoom (radians)' + WRITE(6,24) y0,grossism,tau,dzoom + + DO i = 0, nmax2 + yt(i) = - pis2 + FLOAT(i)* pi /nmax2 + ENDDO + + heavyy0m = heavyside( -y0 ) + heavyy0 = heavyside( y0 ) + y0min = 2.*y0*heavyy0m - pis2 + y0max = 2.*y0*heavyy0 + pis2 + + fa = 999.999 + fb = 999.999 + + DO i = 0, nmax2 + IF( yt(i).LT.y0 ) THEN + fa (i) = tau* (yt(i)-y0+dzoom/2. ) + fb(i) = (yt(i)-2.*y0*heavyy0m +pis2) * ( y0 - yt(i) ) + ELSEIF ( yt(i).GT.y0 ) THEN + fa(i) = tau *(y0-yt(i)+dzoom/2. ) + fb(i) = (2.*y0*heavyy0 -yt(i)+pis2) * ( yt(i) - y0 ) + ENDIF + + IF( 200.* fb(i) .LT. - fa(i) ) THEN + fhyp ( i) = - 1. + ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN + fhyp ( i) = 1. + ELSE + fhyp(i) = TANH ( fa(i)/fb(i) ) + ENDIF + + IF( yt(i).EQ.y0 ) fhyp(i) = 1. + IF(yt(i).EQ. y0min. OR.yt(i).EQ. y0max ) fhyp(i) = -1. + + ENDDO + +cc .... Calcul de beta .... +c + ffdy = 0. + + DO i = 1, nmax2 + ymoy = 0.5 * ( yt(i-1) + yt( i ) ) + IF( ymoy.LT.y0 ) THEN + fa(i)= tau * ( ymoy-y0+dzoom/2.) + fb(i) = (ymoy-2.*y0*heavyy0m +pis2) * ( y0 - ymoy ) + ELSEIF ( ymoy.GT.y0 ) THEN + fa(i)= tau * ( y0-ymoy+dzoom/2. ) + fb(i) = (2.*y0*heavyy0 -ymoy+pis2) * ( ymoy - y0 ) + ENDIF + + IF( 200.* fb(i) .LT. - fa(i) ) THEN + fxm ( i) = - 1. + ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN + fxm ( i) = 1. + ELSE + fxm(i) = TANH ( fa(i)/fb(i) ) + ENDIF + IF( ymoy.EQ.y0 ) fxm(i) = 1. + IF (ymoy.EQ. y0min. OR.yt(i).EQ. y0max ) fxm(i) = -1. + ffdy = ffdy + fxm(i) * ( yt(i) - yt(i-1) ) + + ENDDO + + beta = ( grossism * ffdy - pi ) / ( ffdy - pi ) + + IF( 2.*beta - grossism.LE. 0.) THEN + + WRITE(6,*) ' ** Attention ! La valeur beta calculee dans la rou + ,tine fyhyp est mauvaise ! ' + WRITE(6,*)'Modifier les valeurs de grossismy ,tauy ou dzoomy', + , ' et relancer ! *** ' + CALL ABORT + + ENDIF +c +c ..... calcul de Ytprim ..... +c + + DO i = 0, nmax2 + Ytprim(i) = beta + ( grossism - beta ) * fhyp(i) + ENDDO + +c ..... Calcul de Yf ........ + + Yf(0) = - pis2 + DO i = 1, nmax2 + yypr(i) = beta + ( grossism - beta ) * fxm(i) + ENDDO + + DO i=1,nmax2 + Yf(i) = Yf(i-1) + yypr(i) * ( yt(i) - yt(i-1) ) + ENDDO + +c **************************************************************** +c +c ..... yuv = 0. si calcul des latitudes aux pts. U ..... +c ..... yuv = 0.5 si calcul des latitudes aux pts. V ..... +c + WRITE(6,18) +c + DO 5000 ik = 1,4 + + IF( ik.EQ.1 ) THEN + yuv = 0. + jlat = jjm + 1 + ELSE IF ( ik.EQ.2 ) THEN + yuv = 0.5 + jlat = jjm + ELSE IF ( ik.EQ.3 ) THEN + yuv = 0.25 + jlat = jjm + ELSE IF ( ik.EQ.4 ) THEN + yuv = 0.75 + jlat = jjm + ENDIF +c + yo1 = 0. + DO 1500 j = 1,jlat + yo1 = 0. + ylon2 = - pis2 + pisjm * ( FLOAT(j) + yuv -1.) + yfi = ylon2 +c + DO 250 it = nmax2,0,-1 + IF( yfi.GE.Yf(it)) GO TO 350 +250 CONTINUE + it = 0 +350 CONTINUE + + yi = yt(it) + IF(it.EQ.nmax2) THEN + it = nmax2 -1 + Yf(it+1) = pis2 + ENDIF +c ................................................................. +c .... Interpolation entre yi(it) et yi(it+1) pour avoir Y(yi) +c ..... et Y'(yi) ..... +c ................................................................. + + CALL coefpoly ( Yf(it),Yf(it+1),Ytprim(it), Ytprim(it+1), + , yt(it),yt(it+1) , a0,a1,a2,a3 ) + + Yf1 = Yf(it) + Yprimin = a1 + 2.* a2 * yi + 3.*a3 * yi *yi + + DO 500 iter = 1,300 + yi = yi - ( Yf1 - yfi )/ Yprimin + + IF( ABS(yi-yo1).LE.epsilon) GO TO 550 + yo1 = yi + yi2 = yi * yi + Yf1 = a0 + a1 * yi + a2 * yi2 + a3 * yi2 * yi + Yprimin = a1 + 2.* a2 * yi + 3.* a3 * yi2 +500 CONTINUE + WRITE(6,*) ' Pas de solution ***** ',j,ylon2,iter + STOP 2 +550 CONTINUE +c + Yprimin = a1 + 2.* a2 * yi + 3.* a3 * yi* yi + yprim(j) = pi / ( jjm * Yprimin ) + yvrai(j) = yi + +1500 CONTINUE + + DO j = 1, jlat -1 + IF( yvrai(j+1). LT. yvrai(j) ) THEN + WRITE(6,*) ' PBS. avec rlat(',j+1,') plus petit que rlat(',j, + , ')' + STOP 3 + ENDIF + ENDDO + + WRITE(6,*) 'Reorganisation des latitudes pour avoir entre - pi/2' + , ,' et pi/2 ' +c + IF( ik.EQ.1 ) THEN + ypn = pis2 + DO j = jlat,1,-1 + IF( yvrai(j).LE. ypn ) GO TO 1502 + ENDDO +1502 CONTINUE + + jpn = j + y00 = yvrai(jpn) + deply = pis2 - y00 + ENDIF + + DO j = 1, jjm +1 - jpn + ylatt (j) = -pis2 - y00 + yvrai(jpn+j-1) + yprimm(j) = yprim(jpn+j-1) + ENDDO + + jjpn = jpn + IF( jlat.EQ. jjm ) jjpn = jpn -1 + + DO j = 1,jjpn + ylatt (j + jjm+1 -jpn) = yvrai(j) + deply + yprimm(j + jjm+1 -jpn) = yprim(j) + ENDDO + +c *********** Fin de la reorganisation ************* +c + 1600 CONTINUE + + DO j = 1, jlat + ylat(j) = ylatt( jlat +1 -j ) + yprim(j) = yprimm( jlat +1 -j ) + ENDDO + + DO j = 1, jlat + yvrai(j) = ylat(j)*180./pi + ENDDO + + IF( ik.EQ.1 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en U apres ( en deg. ) ' +c WRITE(6,68) (yvrai(j),j=1,jlat) +cc WRITE(6,*) ' YPRIM ' +cc WRITE(6,445) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rrlatu(j) = ylat( j ) + yyprimu(j) = yprim( j ) + ENDDO + + ELSE IF ( ik.EQ. 2 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en V apres ( en deg. ) ' +c WRITE(6,68) (yvrai(j),j=1,jlat) +cc WRITE(6,*)' YPRIM ' +cc WRITE(6,445) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rrlatv(j) = ylat( j ) + yyprimv(j) = yprim( j ) + ENDDO + + ELSE IF ( ik.EQ. 3 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en U + 0.75 apres ( en deg. ) ' +c WRITE(6,68) (yvrai(j),j=1,jlat) +cc WRITE(6,*) ' YPRIM ' +cc WRITE(6,445) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rlatu2(j) = ylat( j ) + yprimu2(j) = yprim( j ) + ENDDO + + ELSE IF ( ik.EQ. 4 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en U + 0.25 apres ( en deg. ) ' +c WRITE(6,68)(yvrai(j),j=1,jlat) +cc WRITE(6,*) ' YPRIM ' +cc WRITE(6,68) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rlatu1(j) = ylat( j ) + yprimu1(j) = yprim( j ) + ENDDO + + ENDIF + +5000 CONTINUE +c + WRITE(6,18) +c +c ..... fin de la boucle do 5000 ..... + + DO j = 1, jjm + ylat(j) = rrlatu(j) - rrlatu(j+1) + ENDDO + champmin = 1.e12 + champmax = -1.e12 + DO j = 1, jjm + champmin = MIN( champmin, ylat(j) ) + champmax = MAX( champmax, ylat(j) ) + ENDDO + champmin = champmin * 180./pi + champmax = champmax * 180./pi + +24 FORMAT(2x,'Parametres yzoom,gross,tau ,dzoom pour fyhyp ',4f8.3) +18 FORMAT(/) +68 FORMAT(1x,7f9.2) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gcm.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gcm.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gcm.F (revision 1280) @@ -0,0 +1,483 @@ +! +! $Id$ +! +c +c + PROGRAM gcm + +#ifdef CPP_IOIPSL + USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + USE ioipsl_getincom +#endif + + USE filtreg_mod + USE infotrac + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +! A nettoyer. On ne veut qu'une ou deux routines d'interface +! dynamique -> physique pour l'initialisation +! Ehouarn: for now these only apply to Earth: +#ifdef CPP_EARTH + USE dimphy + USE comgeomphy + USE mod_phys_lmdz_para, ONLY : klon_mpi_para_nb +#endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + IMPLICIT NONE + +c ...... Version du 10/01/98 .......... + +c avec coordonnees verticales hybrides +c avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 ) + +c======================================================================= +c +c Auteur: P. Le Van /L. Fairhead/F.Hourdin +c ------- +c +c Objet: +c ------ +c +c GCM LMD nouvelle grille +c +c======================================================================= +c +c ... Dans inigeom , nouveaux calculs pour les elongations cu , cv +c et possibilite d'appeler une fonction f(y) a derivee tangente +c hyperbolique a la place de la fonction a derivee sinusoidale. +c ... Possibilite de choisir le schema pour l'advection de +c q , en modifiant iadv dans traceur.def (MAF,10/02) . +c +c Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99) +c Pour Van-Leer iadv=10 +c +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissnew.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "temps.h" +#include "control.h" +#include "ener.h" +#include "description.h" +#include "serre.h" +#include "com_io_dyn.h" +#include "iniprint.h" +#include "tracstoke.h" + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + SAVE clesphy0 + + + + REAL zdtvr + INTEGER nbetatmoy, nbetatdem,nbetat + +c variables dynamiques + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL, ALLOCATABLE, DIMENSION(:,:,:):: q! champs advectes + REAL ps(ip1jmp1) ! pression au sol + REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL pks(ip1jmp1) ! exner au sol + REAL pk(ip1jmp1,llm) ! exner au milieu des couches + REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches + REAL masse(ip1jmp1,llm) ! masse d'air + REAL phis(ip1jmp1) ! geopotentiel au sol + REAL phi(ip1jmp1,llm) ! geopotentiel + REAL w(ip1jmp1,llm) ! vitesse verticale + +c variables dynamiques intermediaire pour le transport + +c variables pour le fichier histoire + REAL dtav ! intervalle de temps elementaire + + REAL time_0 + + LOGICAL lafin + INTEGER ij,iq,l,i,j + + + real time_step, t_wrt, t_ops + + LOGICAL first + + LOGICAL call_iniphys + data call_iniphys/.true./ + + REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm) +c+jld variables test conservation energie +c REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm) +C Tendance de la temp. potentiel d (theta)/ d t due a la +C tansformation d'energie cinetique en energie thermique +C cree par la dissipation + REAL dhecdt(ip1jmp1,llm) +c REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) +c REAL d_h_vcol, d_qt, d_qw, d_ql, d_ec + CHARACTER (len=15) :: ztit +c-jld + + + character (len=80) :: dynhist_file, dynhistave_file + character (len=20) :: modname + character (len=80) :: abort_message +! locales pour gestion du temps + INTEGER :: an, mois, jour + REAL :: heure + + +c----------------------------------------------------------------------- +c variables pour l'initialisation de la physique : +c ------------------------------------------------ + INTEGER ngridmx + PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm ) + REAL zcufi(ngridmx),zcvfi(ngridmx) + REAL latfi(ngridmx),lonfi(ngridmx) + REAL airefi(ngridmx) + SAVE latfi, lonfi, airefi + +c----------------------------------------------------------------------- +c Initialisations: +c ---------------- + + abort_message = 'last timestep reached' + modname = 'gcm' + descript = 'Run GCM LMDZ' + lafin = .FALSE. + dynhist_file = 'dyn_hist.nc' + dynhistave_file = 'dyn_hist_ave.nc' + + + +c---------------------------------------------------------------------- +c lecture des fichiers gcm.def ou run.def +c --------------------------------------- +c +! Ehouarn: dump possibility of using defrun +!#ifdef CPP_IOIPSL + CALL conf_gcm( 99, .TRUE. , clesphy0 ) +!#else +! CALL defrun( 99, .TRUE. , clesphy0 ) +!#endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH 2008/05/02 +! A nettoyer. On ne veut qu'une ou deux routines d'interface +! dynamique -> physique pour l'initialisation +! Ehouarn : temporarily (?) keep this only for Earth + if (planet_type.eq."earth") then +#ifdef CPP_EARTH + CALL Init_Phys_lmdz(iim,jjp1,llm,1,(jjm-1)*iim+2) + call InitComgeomphy +#endif + endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c----------------------------------------------------------------------- +c Choix du calendrier +c ------------------- + +c calend = 'earth_365d' + +#ifdef CPP_IOIPSL + if (calend == 'earth_360d') then + call ioconf_calendar('360d') + write(lunout,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an' + else if (calend == 'earth_365d') then + call ioconf_calendar('noleap') + write(lunout,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an' + else if (calend == 'earth_366d') then + call ioconf_calendar('gregorian') + write(lunout,*)'CALENDRIER CHOISI: Terrestre bissextile' + else + abort_message = 'Mauvais choix de calendrier' + call abort_gcm(modname,abort_message,1) + endif +#endif +c----------------------------------------------------------------------- + + IF (config_inca /= 'none') THEN +#ifdef INCA + call init_const_lmdz(nbtr,anneeref,dayref,iphysiq,day_step,nday) + call init_inca_para(iim,jjm+1,klon,1,klon_mpi_para_nb,0) +#endif + END IF +c +c +c------------------------------------ +c Initialisation partie parallele +c------------------------------------ + +c +c +c----------------------------------------------------------------------- +c Initialisation des traceurs +c --------------------------- +c Choix du nombre de traceurs et du schema pour l'advection +c dans fichier traceur.def, par default ou via INCA + call infotrac_init + +c Allocation de la tableau q : champs advectes + allocate(q(ip1jmp1,llm,nqtot)) + +c----------------------------------------------------------------------- +c Lecture de l'etat initial : +c --------------------------- + +c lecture du fichier start.nc + if (read_start) then + ! we still need to run iniacademic to initialize some + ! constants & fields, if we run the 'newtonian' case: + if (iflag_phys.eq.2) then + CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0) + endif +!#ifdef CPP_IOIPSL + if (planet_type.eq."earth") then +#ifdef CPP_EARTH +! Load an Earth-format start file + CALL dynetat0("start.nc",vcov,ucov, + . teta,q,masse,ps,phis, time_0) +#endif + endif ! of if (planet_type.eq."earth") +c write(73,*) 'ucov',ucov +c write(74,*) 'vcov',vcov +c write(75,*) 'teta',teta +c write(76,*) 'ps',ps +c write(77,*) 'q',q + + endif ! of if (read_start) + + IF (config_inca /= 'none') THEN +#ifdef INCA + call init_inca_dim(klon,llm,iim,jjm, + $ rlonu,rlatu,rlonv,rlatv) +#endif + END IF + + +c le cas echeant, creation d un etat initial + IF (prt_level > 9) WRITE(lunout,*) + . 'GCM: AVANT iniacademic AVANT AVANT AVANT AVANT' + if (.not.read_start) then + CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0) + endif + + +c----------------------------------------------------------------------- +c Lecture des parametres de controle pour la simulation : +c ------------------------------------------------------- +c on recalcule eventuellement le pas de temps + + IF(MOD(day_step,iperiod).NE.0) THEN + abort_message = + . 'Il faut choisir un nb de pas par jour multiple de iperiod' + call abort_gcm(modname,abort_message,1) + ENDIF + + IF(MOD(day_step,iphysiq).NE.0) THEN + abort_message = + * 'Il faut choisir un nb de pas par jour multiple de iphysiq' + call abort_gcm(modname,abort_message,1) + ENDIF + + zdtvr = daysec/FLOAT(day_step) + IF(dtvr.NE.zdtvr) THEN + WRITE(lunout,*) + . 'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr + ENDIF + +C +C on remet le calendrier à zero si demande +c + if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then + write(lunout,*) + . 'GCM: Attention les dates initiales lues dans le fichier' + write(lunout,*) + . ' restart ne correspondent pas a celles lues dans ' + write(lunout,*)' gcm.def' + write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref + write(lunout,*)' day_ref=',day_ref," dayref=",dayref + if (raz_date .ne. 1) then + write(lunout,*) + . 'GCM: On garde les dates du fichier restart' + else + annee_ref = anneeref + day_ref = dayref + day_ini = dayref + itau_dyn = 0 + itau_phy = 0 + time_0 = 0. + write(lunout,*) + . 'GCM: On reinitialise a la date lue dans gcm.def' + endif + ELSE + raz_date = 0 + endif + +#ifdef CPP_IOIPSL + mois = 1 + heure = 0. + call ymds2ju(annee_ref, mois, day_ref, heure, jD_ref) + jH_ref = jD_ref - int(jD_ref) + jD_ref = int(jD_ref) + + call ioconf_startdate(INT(jD_ref), jH_ref) + + write(lunout,*)'DEBUG' + write(lunout,*)'annee_ref, mois, day_ref, heure, jD_ref' + write(lunout,*)annee_ref, mois, day_ref, heure, jD_ref + call ju2ymds(jD_ref+jH_ref,an, mois, jour, heure) + write(lunout,*)'jD_ref+jH_ref,an, mois, jour, heure' + write(lunout,*)jD_ref+jH_ref,an, mois, jour, heure +#else +! Ehouarn: we still need to define JD_ref and JH_ref +! and since we don't know how many days there are in a year +! we set JD_ref to 0 (this should be improved ...) + jD_ref=0 + jH_ref=0 +#endif + +c nombre d'etats dans les fichiers demarrage et histoire + nbetatdem = nday / iecri + nbetatmoy = nday / periodav + 1 + +c----------------------------------------------------------------------- +c Initialisation des constantes dynamiques : +c ------------------------------------------ + dtvr = zdtvr + CALL iniconst + +c----------------------------------------------------------------------- +c Initialisation de la geometrie : +c -------------------------------- + CALL inigeom + +c----------------------------------------------------------------------- +c Initialisation du filtre : +c -------------------------- + CALL inifilr +c +c----------------------------------------------------------------------- +c Initialisation de la dissipation : +c ---------------------------------- + + CALL inidissip( lstardis, nitergdiv, nitergrot, niterh , + * tetagdiv, tetagrot , tetatemp ) + +c----------------------------------------------------------------------- +c Initialisation de la physique : +c ------------------------------- + + IF (call_iniphys.and.(iflag_phys.eq.1)) THEN + latfi(1)=rlatu(1) + lonfi(1)=0. + zcufi(1) = cu(1) + zcvfi(1) = cv(1) + DO j=2,jjm + DO i=1,iim + latfi((j-2)*iim+1+i)= rlatu(j) + lonfi((j-2)*iim+1+i)= rlonv(i) + zcufi((j-2)*iim+1+i) = cu((j-1)*iip1+i) + zcvfi((j-2)*iim+1+i) = cv((j-1)*iip1+i) + ENDDO + ENDDO + latfi(ngridmx)= rlatu(jjp1) + lonfi(ngridmx)= 0. + zcufi(ngridmx) = cu(ip1jm+1) + zcvfi(ngridmx) = cv(ip1jm-iim) + CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi) + WRITE(lunout,*) + . 'GCM: WARNING!!! vitesse verticale nulle dans la physique' +! Earth: + if (planet_type.eq."earth") then +#ifdef CPP_EARTH + CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys , + , latfi,lonfi,airefi,zcufi,zcvfi,rad,g,r,cpp ) +#endif + endif ! of if (planet_type.eq."earth") + call_iniphys=.false. + ENDIF ! of IF (call_iniphys.and.(iflag_phys.eq.1)) +!#endif + +c numero de stockage pour les fichiers de redemarrage: + +c----------------------------------------------------------------------- +c Initialisation des I/O : +c ------------------------ + + + day_end = day_ini + nday + WRITE(lunout,300)day_ini,day_end + 300 FORMAT('1'/,15x,'run du jour',i7,2x,'au jour',i7//) + +#ifdef CPP_IOIPSL + call ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure) + write (lunout,301)jour, mois, an + call ju2ymds(jD_ref + day_end - day_ref, an, mois, jour, heure) + write (lunout,302)jour, mois, an + 301 FORMAT('1'/,15x,'run du ', i2,'/',i2,'/',i4) + 302 FORMAT('1'/,15x,' au ', i2,'/',i2,'/',i4) +#endif + + if (planet_type.eq."earth") then + CALL dynredem0("restart.nc", day_end, phis) + endif + + ecripar = .TRUE. + +#ifdef CPP_IOIPSL + if ( 1.eq.1) then + time_step = zdtvr + t_ops = iecri * daysec + t_wrt = iecri * daysec +! CALL inithist(dynhist_file,day_ref,annee_ref,time_step, +! . t_ops, t_wrt, histid, histvid) + +! IF (ok_dynzon) THEN +! t_ops = iperiod * time_step +! t_wrt = periodav * daysec +! CALL initdynav(dynhistave_file,day_ref,annee_ref,time_step, +! . t_ops, t_wrt, histaveid) +! END IF + dtav = iperiod*dtvr/daysec + endif + + +#endif +! #endif of #ifdef CPP_IOIPSL + +c Choix des frequences de stokage pour le offline +c istdyn=day_step/4 ! stockage toutes les 6h=1jour/4 +c istdyn=day_step/12 ! stockage toutes les 2h=1jour/12 + istdyn=day_step/4 ! stockage toutes les 6h=1jour/12 + istphy=istdyn/iphysiq + + +c +c----------------------------------------------------------------------- +c Integration temporelle du modele : +c ---------------------------------- + +c write(78,*) 'ucov',ucov +c write(78,*) 'vcov',vcov +c write(78,*) 'teta',teta +c write(78,*) 'ps',ps +c write(78,*) 'q',q + + + CALL leapfrog(ucov,vcov,teta,ps,masse,phis,q,clesphy0, + . time_0) + + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/geopot.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/geopot.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/geopot.F (revision 1280) @@ -0,0 +1,64 @@ +! +! $Header$ +! + SUBROUTINE geopot (ngrid, teta, pk, pks, phis, phi ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c .... calcul du geopotentiel aux milieux des couches ..... +c ******************************************************************* +c +c .... l'integration se fait de bas en haut .... +c +c .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg .. +c phi est un argum. de sortie pour le s-pg . +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + +c Arguments: +c ---------- + + INTEGER ngrid + REAL teta(ngrid,llm),pks(ngrid),phis(ngrid),pk(ngrid,llm) , + * phi(ngrid,llm) + + +c Local: +c ------ + + INTEGER l, ij + + +c----------------------------------------------------------------------- +c calcul de phi au niveau 1 pres du sol ..... + + DO 1 ij = 1, ngrid + phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) ) + 1 CONTINUE + +c calcul de phi aux niveaux superieurs ....... + + DO l = 2,llm + DO ij = 1,ngrid + phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l) + teta(ij,l-1) ) + * * ( pk(ij,l-1) - pk(ij,l) ) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/getparam.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/getparam.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/getparam.F90 (revision 1280) @@ -0,0 +1,106 @@ +! +! $Id$ +! +MODULE getparam +#ifdef CPP_IOIPSL + USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + USE ioipsl_getincom +#endif + + INTERFACE getpar + MODULE PROCEDURE ini_getparam,fin_getparam,getparamr,getparami,getparaml + END INTERFACE + + INTEGER, PARAMETER :: out_eff=99 + +CONTAINS + SUBROUTINE ini_getparam(fichier) + ! + IMPLICIT NONE + ! + CHARACTER*(*) :: fichier + open(out_eff,file=fichier,status='unknown',form='formatted') + END SUBROUTINE ini_getparam + + SUBROUTINE fin_getparam + ! + IMPLICIT NONE + ! + close(out_eff) + + END SUBROUTINE fin_getparam + + SUBROUTINE getparamr(TARGET,def_val,ret_val,comment) + ! + IMPLICIT NONE + ! + ! Get a real scalar. We first check if we find it + ! in the database and if not we get it from the run.def + ! + ! getinr1d and getinr2d are written on the same pattern + ! + CHARACTER*(*) :: TARGET + REAL :: def_val + REAL :: ret_val + CHARACTER*(*) :: comment + + ret_val=def_val + call getin(TARGET,ret_val) + + write(out_eff,*) '######################################' + write(out_eff,*) '#### ',comment,' #####' + write(out_eff,*) TARGET,'=',ret_val + + END SUBROUTINE getparamr + + SUBROUTINE getparami(TARGET,def_val,ret_val,comment) + ! + IMPLICIT NONE + ! + ! Get a real scalar. We first check if we find it + ! in the database and if not we get it from the run.def + ! + ! getinr1d and getinr2d are written on the same pattern + ! + CHARACTER*(*) :: TARGET + INTEGER :: def_val + INTEGER :: ret_val + CHARACTER*(*) :: comment + + ret_val=def_val + call getin(TARGET,ret_val) + + write(out_eff,*) '######################################' + write(out_eff,*) '#### ',comment,' #####' + write(out_eff,*) comment + write(out_eff,*) TARGET,'=',ret_val + + END SUBROUTINE getparami + + SUBROUTINE getparaml(TARGET,def_val,ret_val,comment) + ! + IMPLICIT NONE + ! + ! Get a real scalar. We first check if we find it + ! in the database and if not we get it from the run.def + ! + ! getinr1d and getinr2d are written on the same pattern + ! + CHARACTER*(*) :: TARGET + LOGICAL :: def_val + LOGICAL :: ret_val + CHARACTER*(*) :: comment + + ret_val=def_val + call getin(TARGET,ret_val) + + write(out_eff,*) '######################################' + write(out_eff,*) '#### ',comment,' #####' + write(out_eff,*) TARGET,'=',ret_val + + END SUBROUTINE getparaml + + +END MODULE getparam Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_dyn_fi.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_dyn_fi.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_dyn_fi.F (revision 1280) @@ -0,0 +1,38 @@ +! +! $Header$ +! + SUBROUTINE gr_dyn_fi(nfield,im,jm,ngrid,pdyn,pfi) + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER j,ifield,ig + +c----------------------------------------------------------------------- +c calcul: +c ------- + + IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim' +c traitement des poles + CALL SCOPY(nfield,pdyn,im*jm,pfi,ngrid) + CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(ngrid,1),ngrid) + +c traitement des point normaux + DO ifield=1,nfield + DO j=2,jm-1 + ig=2+(j-2)*(im-1) + CALL SCOPY(im-1,pdyn(1,j,ifield),1,pfi(ig,ifield),1) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_ecrit_fi.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_ecrit_fi.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_ecrit_fi.F (revision 1280) @@ -0,0 +1,32 @@ +! +! $Header$ +! + SUBROUTINE gr_ecrit_fi(nfield,nlon,iim,jjmp1,ecrit,fi) + + IMPLICIT none + +c Transformer une variable de la grille d'ecriture a la grille physique + + INTEGER nfield,nlon,iim,jjmp1, jjm + REAL fi(nlon,nfield), ecrit(iim,jjmp1,nfield) +c + INTEGER i, j, n, ig +c +c print*,'iim jjm ',iim,jjm + +c modif par abd 21 02 01 + + jjm = jjmp1 - 1 + do n = 1, nfield + fi(1,n) = ecrit(1,1,n) + fi(nlon,n) = ecrit(1,jjm+1,n) + DO j = 2, jjm + ig = 2+(j-2)*iim + DO i = 1, iim + fi(ig-1+i,n) = ecrit(i,j,n) + ENDDO + ENDDO + ENDDO + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_fi_dyn.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_fi_dyn.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_fi_dyn.F (revision 1280) @@ -0,0 +1,40 @@ +! +! $Header$ +! + SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn) + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER i,j,ifield,ig + +c----------------------------------------------------------------------- +c calcul: +c ------- + + DO ifield=1,nfield +c traitement des poles + DO i=1,im + pdyn(i,1,ifield)=pfi(1,ifield) + pdyn(i,jm,ifield)=pfi(ngrid,ifield) + ENDDO + +c traitement des point normaux + DO j=2,jm-1 + ig=2+(j-2)*(im-1) + CALL SCOPY(im-1,pfi(ig,ifield),1,pdyn(1,j,ifield),1) + pdyn(im,j,ifield)=pdyn(1,j,ifield) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_int_dyn.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_int_dyn.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_int_dyn.F (revision 1280) @@ -0,0 +1,49 @@ +! +! $Header$ +! + subroutine gr_int_dyn(champin,champdyn,iim,jp1) + implicit none +c======================================================================= +c passage d'un champ interpole a un champ sur grille scalaire +c======================================================================= +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER iim + integer ip1, jp1 + REAL champin(iim, jp1) + REAL champdyn(iim+1, jp1) + + INTEGER i, j + real polenord, polesud + +c----------------------------------------------------------------------- +c calcul: +c ------- + + ip1 = iim + 1 + polenord = 0. + polesud = 0. + do i = 1, iim + polenord = polenord + champin (i, 1) + polesud = polesud + champin (i, jp1) + enddo + polenord = polenord / iim + polesud = polesud / iim + do j = 1, jp1 + do i = 1, iim + if (j .eq. 1) then + champdyn(i, j) = polenord + else if (j .eq. jp1) then + champdyn(i, j) = polesud + else + champdyn(i, j) = champin (i, j) + endif + enddo + champdyn(ip1, j) = champdyn(1, j) + enddo + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_u_scal.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_u_scal.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_u_scal.F (revision 1280) @@ -0,0 +1,60 @@ +! +! $Header$ +! + SUBROUTINE gr_u_scal(nx,x_u,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx) + +c Local: +c ------ + + INTEGER l,ij + +c----------------------------------------------------------------------- + + DO l=1,nx + DO ij=ip1jmp1,2,-1 + x_scal(ij,l)= + s (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l)) + s /(aireu(ij)+aireu(ij-1)) + ENDDO + ENDDO + + CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_v_scal.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_v_scal.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gr_v_scal.F (revision 1280) @@ -0,0 +1,64 @@ +! +! $Header$ +! + SUBROUTINE gr_v_scal(nx,x_v,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_v(ip1jm,nx),x_scal(ip1jmp1,nx) + +c Local: +c ------ + + INTEGER l,ij + +c----------------------------------------------------------------------- + + DO l=1,nx + DO ij=iip2,ip1jm + x_scal(ij,l)= + s (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l)) + s /(airev(ij-iip1)+airev(ij)) + ENDDO + DO ij=1,iip1 + x_scal(ij,l)=0. + ENDDO + DO ij=ip1jm+1,ip1jmp1 + x_scal(ij,l)=0. + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/grad.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/grad.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/grad.F (revision 1280) @@ -0,0 +1,44 @@ +! +! $Header$ +! + SUBROUTINE grad(klevel, pg,pgx,pgy ) +c +c P. Le Van +c +c ****************************************************************** +c .. calcul des composantes covariantes en x et y du gradient de g +c +c ****************************************************************** +c pg est un argument d'entree pour le s-prog +c pgx et pgy sont des arguments de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + INTEGER klevel + REAL pg( ip1jmp1,klevel ) + REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel ) + INTEGER l,ij +c +c + DO 6 l = 1,klevel +c + DO 2 ij = 1, ip1jmp1 - 1 + pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l ) + 2 CONTINUE +c +c .... correction pour pgx(ip1,j,l) .... +c ... pgx(iip1,j,l)= pgx(1,j,l) .... +CDIR$ IVDEP + DO 3 ij = iip1, ip1jmp1, iip1 + pgx( ij,l ) = pgx( ij -iim,l ) + 3 CONTINUE +c + DO 4 ij = 1,ip1jm + pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l ) + 4 CONTINUE +c + 6 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gradiv.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gradiv.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gradiv.F (revision 1280) @@ -0,0 +1,57 @@ +! +! $Header$ +! + SUBROUTINE gradiv(klevel, xcov, ycov, ld, gdx, gdy ) +c +c Auteur : P. Le Van +c +c *************************************************************** +c +c ld +c calcul de (grad (div) ) du vect. v .... +c +c xcov et ycov etant les composant.covariantes de v +c **************************************************************** +c xcov , ycov et ld sont des arguments d'entree pour le s-prog +c gdx et gdy sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "logic.h" + + INTEGER klevel +c + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL gdx( ip1jmp1,klevel ), gdy( ip1jm,klevel ) + + REAL div(ip1jmp1,llm) + + INTEGER l,ij,iter,ld +c +c +c + CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 ) + CALL SCOPY( ip1jm*klevel, ycov,1,gdy,1 ) +c + DO 10 iter = 1,ld +c + CALL diverg( klevel, gdx , gdy, div ) + CALL filtreg( div, jjp1, klevel, 2,1, .true.,2 ) + CALL grad( klevel, div, gdx, gdy ) +c + DO 5 l = 1, klevel + DO 3 ij = 1, ip1jmp1 + gdx( ij,l ) = - gdx( ij,l ) * cdivu + 3 CONTINUE + DO 4 ij = 1, ip1jm + gdy( ij,l ) = - gdy( ij,l ) * cdivu + 4 CONTINUE + 5 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gradiv2.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gradiv2.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gradiv2.F (revision 1280) @@ -0,0 +1,79 @@ +! +! $Header$ +! + SUBROUTINE gradiv2(klevel, xcov, ycov, ld, gdx, gdy ) +c +c P. Le Van +c +c ********************************************************** +c ld +c calcul de (grad (div) ) du vect. v .... +c +c xcov et ycov etant les composant.covariantes de v +c ********************************************************** +c xcont , ycont et ld sont des arguments d'entree pour le s-prog +c gdx et gdy sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comdissipn.h" +c +c ........ variables en arguments ........ + + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL gdx( ip1jmp1,klevel ), gdy( ip1jm,klevel ) +c +c ........ variables locales ......... +c + REAL div(ip1jmp1,llm) + REAL signe, nugrads + INTEGER l,ij,iter,ld + +c ........................................................ +c +c + CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 ) + CALL SCOPY( ip1jm * klevel, ycov, 1, gdy, 1 ) +c +c + signe = (-1.)**ld + nugrads = signe * cdivu +c + + + CALL divergf( klevel, gdx, gdy , div ) + + IF( ld.GT.1 ) THEN + + CALL laplacien ( klevel, div, div ) + +c ...... Iteration de l'operateur laplacien_gam ....... + + DO iter = 1, ld -2 + CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1, + * unsapolnga1, unsapolsga1, div, div ) + ENDDO + + ENDIF + + + CALL filtreg( div , jjp1, klevel, 2, 1, .TRUE., 1 ) + CALL grad ( klevel, div, gdx, gdy ) + +c + DO l = 1, klevel + DO ij = 1, ip1jmp1 + gdx( ij,l ) = gdx( ij,l ) * nugrads + ENDDO + DO ij = 1, ip1jm + gdy( ij,l ) = gdy( ij,l ) * nugrads + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gradsdef.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gradsdef.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/gradsdef.h (revision 1280) @@ -0,0 +1,23 @@ +! +! $Header$ +! + integer nfmx,imx,jmx,lmx,nvarmx + parameter(nfmx=10,imx=200,jmx=150,lmx=200,nvarmx=1000) + + real xd(imx,nfmx),yd(jmx,nfmx),zd(lmx,nfmx),dtime(nfmx) + + integer imd(imx),jmd(jmx),lmd(lmx) + integer iid(imx),jid(jmx) + integer ifd(imx),jfd(jmx) + integer unit(nfmx),irec(nfmx),itime(nfmx),nld(nvarmx,nfmx) + + integer nvar(nfmx),ivar(nfmx) + logical firsttime(nfmx) + + character*10 var(nvarmx,nfmx),fichier(nfmx) + character*40 title(nfmx),tvar(nvarmx,nfmx) + + common/gradsdef/xd,yd,zd,dtime, + s imd,jmd,lmd,iid,jid,ifd,jfd, + s unit,irec,nvar,ivar,itime,nld,firsttime, + s var,fichier,title,tvar Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/grid_atob.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/grid_atob.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/grid_atob.F (revision 1280) @@ -0,0 +1,971 @@ +! +! $Header$ +! + SUBROUTINE grille_m(imdep, jmdep, xdata, ydata, entree, + . imar, jmar, x, y, sortie) +c======================================================================= +c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead) +c +c Methode naive pour transformer un champ d'une grille fine a une +c grille grossiere. Je considere que les nouveaux points occupent +c une zone adjacente qui comprend un ou plusieurs anciens points +c +c Aucune ponderation est consideree (voir grille_p) +c +c (c) +c ----d----- +c | . . . .| +c | | +c (b)a . * . .b(a) +c | | +c | . . . .| +c ----c----- +c (d) +C======================================================================= +c INPUT: +c imdep, jmdep: dimensions X et Y pour depart +c xdata, ydata: coordonnees X et Y pour depart +c entree: champ d'entree a transformer +c OUTPUT: +c imar, jmar: dimensions X et Y d'arrivee +c x, y: coordonnees X et Y d'arrivee +c sortie: champ de sortie deja transforme +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL entree(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL sortie(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(2200),b(2200),c(1100),d(1100) + REAL number(2200,1100) + REAL distans(2200*1100) + INTEGER i_proche, j_proche, ij_proche +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + IF (imar.GT.2200 .OR. jmar.GT.1100) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c +c Calculer les limites des zones des nouveaux points +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + number(i,j) = 0.0 + sortie(i,j) = 0.0 + ENDDO + ENDDO +c +c Determiner la zone sur laquelle chaque ancien point se trouve +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + number(ii,jj) = number(ii,jj) + 1.0 + sortie(ii,jj) = sortie(ii,jj) + entree(i,j) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c Si aucun ancien point tombe sur une zone, c'est un probleme +c + + DO i = 1, imar + DO j = 1, jmar + IF (number(i,j) .GT. 0.001) THEN + sortie(i,j) = sortie(i,j) / number(i,j) + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans) +#ifdef CRAY + ij_proche = ISMIN(imdep*jmdep,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imdep*jmdep + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imdep + 1 + i_proche = ij_proche - (j_proche-1)*imdep + PRINT*, "solution:", ij_proche, i_proche, j_proche + sortie(i,j) = entree(i_proche,j_proche) + ENDIF + ENDDO + ENDDO + + RETURN + END + + + SUBROUTINE grille_p(imdep, jmdep, xdata, ydata, entree, + . imar, jmar, x, y, sortie) +c======================================================================= +c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead) +c +c Methode naive pour transformer un champ d'une grille fine a une +c grille grossiere. Je considere que les nouveaux points occupent +c une zone adjacente qui comprend un ou plusieurs anciens points +c +c Consideration de la distance des points (voir grille_m) +c +c (c) +c ----d----- +c | . . . .| +c | | +c (b)a . * . .b(a) +c | | +c | . . . .| +c ----c----- +c (d) +C======================================================================= +c INPUT: +c imdep, jmdep: dimensions X et Y pour depart +c xdata, ydata: coordonnees X et Y pour depart +c entree: champ d'entree a transformer +c OUTPUT: +c imar, jmar: dimensions X et Y d'arrivee +c x, y: coordonnees X et Y d'arrivee +c sortie: champ de sortie deja transforme +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL entree(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL sortie(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(400),b(400),c(200),d(200) + REAL number(400,200) + INTEGER indx(400,200), indy(400,200) + REAL dist(400,200), distsom(400,200) +c + IF (imar.GT.400 .OR. jmar.GT.200) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + IF (imdep.GT.400 .OR. jmdep.GT.200) THEN + PRINT*, 'imdep ou jmdep trop grand', imdep, jmdep + CALL ABORT + ENDIF +c +c calculer les bords a et b de la nouvelle grille +c + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + +c +c calculer les bords c et d de la nouvelle grille +c + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + +c +c trouver les indices (indx,indy) de la nouvelle grille sur laquelle +c un point de l'ancienne grille est tombe. +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + indx(i,j) = ii + indy(i,j) = jj + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c faire une verification +c + + DO i = 1, imdep + DO j = 1, jmdep + IF (indx(i,j).GT.imar .OR. indy(i,j).GT.jmar) THEN + PRINT*, 'Probleme grave,i,j,indx,indy=', + . i,j,indx(i,j),indy(i,j) + CALL abort + ENDIF + ENDDO + ENDDO + +c +c calculer la distance des anciens points avec le nouveau point, +c on prend ensuite une sorte d'inverse pour ponderation. +c + + DO i = 1, imar + DO j = 1, jmar + number(i,j) = 0.0 + distsom(i,j) = 0.0 + ENDDO + ENDDO + DO i = 1, imdep + DO j = 1, jmdep + dist(i,j) = SQRT ( (xdata(i)-x(indx(i,j)))**2 + . +(ydata(j)-y(indy(i,j)))**2 ) + distsom(indx(i,j),indy(i,j)) = distsom(indx(i,j),indy(i,j)) + . + dist(i,j) + number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j)) +1. + ENDDO + ENDDO + DO i = 1, imdep + DO j = 1, jmdep + dist(i,j) = 1.0 - dist(i,j)/distsom(indx(i,j),indy(i,j)) + ENDDO + ENDDO + + DO i = 1, imar + DO j = 1, jmar + number(i,j) = 0.0 + sortie(i,j) = 0.0 + ENDDO + ENDDO + DO i = 1, imdep + DO j = 1, jmdep + sortie(indx(i,j),indy(i,j)) = sortie(indx(i,j),indy(i,j)) + . + entree(i,j) * dist(i,j) + number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j)) + . + dist(i,j) + ENDDO + ENDDO + DO i = 1, imar + DO j = 1, jmar + IF (number(i,j) .GT. 0.001) THEN + sortie(i,j) = sortie(i,j) / number(i,j) + ELSE + PRINT*, 'probleme,i,j=', i,j + CALL ABORT + ENDIF + ENDDO + ENDDO + + RETURN + END + + + + + SUBROUTINE mask_c_o(imdep, jmdep, xdata, ydata, relief, + . imar, jmar, x, y, mask) +c======================================================================= +c z.x.li (le 1 avril 1994): A partir du champ de relief, on fabrique +c un champ indicateur (masque) terre/ocean +c terre:1; ocean:0 +c +c Methode naive (voir grille_m) +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL relief(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL mask(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(2200),b(2200),c(1100),d(1100) + REAL num_tot(2200,1100), num_oce(2200,1100) +c + IF (imar.GT.2200 .OR. jmar.GT.1100) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + num_oce(i,j) = 0.0 + num_tot(i,j) = 0.0 + ENDDO + ENDDO + +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + num_tot(ii,jj) = num_tot(ii,jj) + 1.0 + IF (.NOT. ( relief(i,j) - 0.9. GE. 1.e-5 ) ) + . num_oce(ii,jj) = num_oce(ii,jj) + 1.0 + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c +c + DO i = 1, imar + DO j = 1, jmar + IF (num_tot(i,j) .GT. 0.001) THEN + IF ( num_oce(i,j)/num_tot(i,j) - 0.5 .GE. 1.e-5 ) THEN + mask(i,j) = 0. + ELSE + mask(i,j) = 1. + ENDIF + ELSE + PRINT*, 'probleme,i,j=', i,j + CALL ABORT + ENDIF + ENDDO + ENDDO + + RETURN + END +c +c + + + SUBROUTINE rugosite(imdep, jmdep, xdata, ydata, entree, + . imar, jmar, x, y, sortie, mask) +c======================================================================= +c z.x.li (le 1 avril 1994): Transformer la longueur de rugosite d'une +c grille fine a une grille grossiere. Sur l'ocean, on impose une valeur +c fixe (0.001m). +c +c Methode naive (voir grille_m) +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL entree(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL sortie(imar,jmar), mask(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(400),b(400),c(400),d(400) + REAL num_tot(400,400) + REAL distans(400*400) + INTEGER i_proche, j_proche, ij_proche +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + IF (imar.GT.400 .OR. jmar.GT.400) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + num_tot(i,j) = 0.0 + sortie(i,j) = 0.0 + ENDDO + ENDDO + +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + sortie(ii,jj) = sortie(ii,jj) + LOG(entree(i,j)) + num_tot(ii,jj) = num_tot(ii,jj) + 1.0 + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c + + DO i = 1, imar + DO j = 1, jmar + IF (NINT(mask(i,j)).EQ.1) THEN + IF (num_tot(i,j) .GT. 0.0) THEN + sortie(i,j) = sortie(i,j) / num_tot(i,j) + sortie(i,j) = EXP(sortie(i,j)) + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans) +#ifdef CRAY + ij_proche = ISMIN(imdep*jmdep,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imdep*jmdep + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imdep + 1 + i_proche = ij_proche - (j_proche-1)*imdep + PRINT*, "solution:", ij_proche, i_proche, j_proche + sortie(i,j) = entree(i_proche,j_proche) + ENDIF + ELSE + sortie(i,j) = 0.001 + ENDIF + ENDDO + ENDDO + + RETURN + END + + + + + + SUBROUTINE sea_ice(imdep, jmdep, xdata, ydata, glace01, + . imar, jmar, x, y, frac_ice) +c======================================================================= +c z.x.li (le 1 avril 1994): Transformer un champ d'indicateur de la +c glace (1, sinon 0) d'une grille fine a un champ de fraction de glace +c (entre 0 et 1) dans une grille plus grossiere. +c +c Methode naive (voir grille_m) +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL glace01(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL frac_ice(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(400),b(400),c(400),d(400) + REAL num_tot(400,400), num_ice(400,400) + REAL distans(400*400) + INTEGER i_proche, j_proche, ij_proche +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + IF (imar.GT.400 .OR. jmar.GT.400) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + num_ice(i,j) = 0.0 + num_tot(i,j) = 0.0 + ENDDO + ENDDO + +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + num_tot(ii,jj) = num_tot(ii,jj) + 1.0 + IF (NINT(glace01(i,j)).EQ.1 ) + . num_ice(ii,jj) = num_ice(ii,jj) + 1.0 + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c + + DO i = 1, imar + DO j = 1, jmar + IF (num_tot(i,j) .GT. 0.001) THEN + IF (num_ice(i,j).GT.0.001) THEN + frac_ice(i,j) = num_ice(i,j) / num_tot(i,j) + ELSE + frac_ice(i,j) = 0.0 + ENDIF + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans) +#ifdef CRAY + ij_proche = ISMIN(imdep*jmdep,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imdep*jmdep + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imdep + 1 + i_proche = ij_proche - (j_proche-1)*imdep + PRINT*, "solution:", ij_proche, i_proche, j_proche + IF (NINT(glace01(i_proche,j_proche)).EQ.1 ) THEN + frac_ice(i,j) = 1.0 + ELSE + frac_ice(i,j) = 0.0 + ENDIF + ENDIF + ENDDO + ENDDO + + RETURN + END + + + + SUBROUTINE rugsoro(imrel, jmrel, xrel, yrel, relief, + . immod, jmmod, xmod, ymod, rugs) +c======================================================================= +c Calculer la longueur de rugosite liee au relief en utilisant +c l'ecart-type dans une maille de 1x1 +C======================================================================= + IMPLICIT none +c +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + REAL amin, AMAX +c + INTEGER imrel, jmrel + REAL xrel(imrel),yrel(jmrel) + REAL relief(imrel,jmrel) +c + INTEGER immod, jmmod + REAL xmod(immod),ymod(jmmod) + REAL rugs(immod,jmmod) +c + INTEGER imtmp, jmtmp + PARAMETER (imtmp=360,jmtmp=180) + REAL xtmp(imtmp), ytmp(jmtmp) + REAL(KIND=8) cham1tmp(imtmp,jmtmp), cham2tmp(imtmp,jmtmp) + REAL zzzz +c + INTEGER i, j, ii, jj + REAL a(2200),b(2200),c(1100),d(1100) + REAL number(2200,1100) +c + REAL distans(400*400) + INTEGER i_proche, j_proche, ij_proche +c + IF (immod.GT.2200 .OR. jmmod.GT.1100) THEN + PRINT*, 'immod ou jmmod trop grand', immod, jmmod + CALL ABORT + ENDIF +c +c Calculs intermediares: +c + xtmp(1) = -180.0 + 360.0/FLOAT(imtmp) / 2.0 + DO i = 2, imtmp + xtmp(i) = xtmp(i-1) + 360.0/FLOAT(imtmp) + ENDDO + DO i = 1, imtmp + xtmp(i) = xtmp(i) /180.0 * 4.0*ATAN(1.0) + ENDDO + ytmp(1) = -90.0 + 180.0/FLOAT(jmtmp) / 2.0 + DO j = 2, jmtmp + ytmp(j) = ytmp(j-1) + 180.0/FLOAT(jmtmp) + ENDDO + DO j = 1, jmtmp + ytmp(j) = ytmp(j) /180.0 * 4.0*ATAN(1.0) + ENDDO +c + a(1) = xtmp(1) - (xtmp(2)-xtmp(1))/2.0 + b(1) = (xtmp(1)+xtmp(2))/2.0 + DO i = 2, imtmp-1 + a(i) = b(i-1) + b(i) = (xtmp(i)+xtmp(i+1))/2.0 + ENDDO + a(imtmp) = b(imtmp-1) + b(imtmp) = xtmp(imtmp) + (xtmp(imtmp)-xtmp(imtmp-1))/2.0 + + c(1) = ytmp(1) - (ytmp(2)-ytmp(1))/2.0 + d(1) = (ytmp(1)+ytmp(2))/2.0 + DO j = 2, jmtmp-1 + c(j) = d(j-1) + d(j) = (ytmp(j)+ytmp(j+1))/2.0 + ENDDO + c(jmtmp) = d(jmtmp-1) + d(jmtmp) = ytmp(jmtmp) + (ytmp(jmtmp)-ytmp(jmtmp-1))/2.0 + + DO i = 1, imtmp + DO j = 1, jmtmp + number(i,j) = 0.0 + cham1tmp(i,j) = 0.0 + cham2tmp(i,j) = 0.0 + ENDDO + ENDDO +c +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imtmp + DO jj = 1, jmtmp + DO i = 1, imrel + IF( ( xrel(i)-a(ii).GE.1.e-5.AND.xrel(i)-b(ii).LE.1.e-5 ).OR. + . ( xrel(i)-a(ii).LE.1.e-5.AND.xrel(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmrel + IF( (yrel(j)-c(jj).GE.1.e-5.AND.yrel(j)-d(jj).LE.1.e-5 ).OR. + . ( yrel(j)-c(jj).LE.1.e-5.AND.yrel(j)-d(jj).GE.1.e-5 ) ) + . THEN + number(ii,jj) = number(ii,jj) + 1.0 + cham1tmp(ii,jj) = cham1tmp(ii,jj) + relief(i,j) + cham2tmp(ii,jj) = cham2tmp(ii,jj) + . + relief(i,j)*relief(i,j) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c + DO i = 1, imtmp + DO j = 1, jmtmp + IF (number(i,j) .GT. 0.001) THEN + cham1tmp(i,j) = cham1tmp(i,j) / number(i,j) + cham2tmp(i,j) = cham2tmp(i,j) / number(i,j) + zzzz=cham2tmp(i,j)-cham1tmp(i,j)**2 + if (zzzz .lt. 0.0) then + if (zzzz .gt. -7.5) then + zzzz = 0.0 + print*,'Pb rugsoro, -7.5 < zzzz < 0, => zzz = 0.0' + else + stop 'Pb rugsoro, zzzz <-7.5' + endif + endif + cham2tmp(i,j) = SQRT(zzzz) + ELSE + PRINT*, 'probleme,i,j=', i,j + CALL ABORT + ENDIF + ENDDO + ENDDO +c + amin = cham2tmp(1,1) + AMAX = cham2tmp(1,1) + DO j = 1, jmtmp + DO i = 1, imtmp + IF (cham2tmp(i,j).GT.AMAX) AMAX = cham2tmp(i,j) + IF (cham2tmp(i,j).LT.amin) amin = cham2tmp(i,j) + ENDDO + ENDDO + PRINT*, 'Ecart-type 1x1:', amin, AMAX +c +c +c + a(1) = xmod(1) - (xmod(2)-xmod(1))/2.0 + b(1) = (xmod(1)+xmod(2))/2.0 + DO i = 2, immod-1 + a(i) = b(i-1) + b(i) = (xmod(i)+xmod(i+1))/2.0 + ENDDO + a(immod) = b(immod-1) + b(immod) = xmod(immod) + (xmod(immod)-xmod(immod-1))/2.0 + + c(1) = ymod(1) - (ymod(2)-ymod(1))/2.0 + d(1) = (ymod(1)+ymod(2))/2.0 + DO j = 2, jmmod-1 + c(j) = d(j-1) + d(j) = (ymod(j)+ymod(j+1))/2.0 + ENDDO + c(jmmod) = d(jmmod-1) + d(jmmod) = ymod(jmmod) + (ymod(jmmod)-ymod(jmmod-1))/2.0 +c + DO i = 1, immod + DO j = 1, jmmod + number(i,j) = 0.0 + rugs(i,j) = 0.0 + ENDDO + ENDDO +c +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, immod + DO jj = 1, jmmod + DO i = 1, imtmp + IF( ( xtmp(i)-a(ii).GE.1.e-5.AND.xtmp(i)-b(ii).LE.1.e-5 ).OR. + . ( xtmp(i)-a(ii).LE.1.e-5.AND.xtmp(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmtmp + IF( (ytmp(j)-c(jj).GE.1.e-5.AND.ytmp(j)-d(jj).LE.1.e-5 ).OR. + . ( ytmp(j)-c(jj).LE.1.e-5.AND.ytmp(j)-d(jj).GE.1.e-5 ) ) + . THEN + number(ii,jj) = number(ii,jj) + 1.0 + rugs(ii,jj) = rugs(ii,jj) + . + LOG(MAX(0.001_8,cham2tmp(i,j))) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c + DO i = 1, immod + DO j = 1, jmmod + IF (number(i,j) .GT. 0.001) THEN + rugs(i,j) = rugs(i,j) / number(i,j) + rugs(i,j) = EXP(rugs(i,j)) + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(xmod(i),ymod(j),xtmp,ytmp,imtmp,jmtmp,distans) +#ifdef CRAY + ij_proche = ISMIN(imtmp*jmtmp,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imtmp*jmtmp + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imtmp + 1 + i_proche = ij_proche - (j_proche-1)*imtmp + PRINT*, "solution:", ij_proche, i_proche, j_proche + rugs(i,j) = LOG(MAX(0.001_8,cham2tmp(i_proche,j_proche))) + ENDIF + ENDDO + ENDDO +c + amin = rugs(1,1) + AMAX = rugs(1,1) + DO j = 1, jmmod + DO i = 1, immod + IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j) + IF (rugs(i,j).LT.amin) amin = rugs(i,j) + ENDDO + ENDDO + PRINT*, 'Ecart-type du modele:', amin, AMAX +c + DO j = 1, jmmod + DO i = 1, immod + rugs(i,j) = rugs(i,j) / AMAX * 20.0 + ENDDO + ENDDO +c + amin = rugs(1,1) + AMAX = rugs(1,1) + DO j = 1, jmmod + DO i = 1, immod + IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j) + IF (rugs(i,j).LT.amin) amin = rugs(i,j) + ENDDO + ENDDO + PRINT*, 'Longueur de rugosite du modele:', amin, AMAX +c + RETURN + END +c + SUBROUTINE dist_sphe(rf_lon,rf_lat,rlon,rlat,im,jm,distance) +c +c Auteur: Laurent Li (le 30 decembre 1996) +c +c Ce programme calcule la distance minimale (selon le grand cercle) +c entre deux points sur la terre +c +c Input: + INTEGER im, jm ! dimensions + REAL rf_lon ! longitude du point de reference (degres) + REAL rf_lat ! latitude du point de reference (degres) + REAL rlon(im), rlat(jm) ! longitude et latitude des points +c +c Output: + REAL distance(im,jm) ! distances en metre +c + REAL rlon1, rlat1 + REAL rlon2, rlat2 + REAL dist + REAL pa, pb, p, pi +c + REAL radius + PARAMETER (radius=6371229.) +c + pi = 4.0 * ATAN(1.0) +c + DO 9999 j = 1, jm + DO 9999 i = 1, im +c + rlon1=rf_lon + rlat1=rf_lat + rlon2=rlon(i) + rlat2=rlat(j) + pa = pi/2.0 - rlat1*pi/180.0 ! dist. entre pole n et point a + pb = pi/2.0 - rlat2*pi/180.0 ! dist. entre pole n et point b + p = (rlon1-rlon2)*pi/180.0 ! angle entre a et b (leurs meridiens) +c + dist = ACOS( COS(pa)*COS(pb) + SIN(pa)*SIN(pb)*COS(p)) + dist = radius * dist + distance(i,j) = dist +c + 9999 CONTINUE +c + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/grid_noro.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/grid_noro.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/grid_noro.F (revision 1280) @@ -0,0 +1,524 @@ +! +! $Header$ +! +c +c + SUBROUTINE grid_noro(imdep, jmdep, xdata, ydata, zdata, + . imar, jmar, x, y, + . zphi,zmea,zstd,zsig,zgam,zthe, + . zpic,zval,mask) +c======================================================================= +c (F. Lott) (voir aussi z.x. Li, A. Harzallah et L. Fairhead) +c +c Compute the Parameters of the SSO scheme as described in +c LOTT & MILLER (1997) and LOTT(1999). +c Target points are on a rectangular grid: +c iim+1 latitudes including North and South Poles; +c jjm+1 longitudes, with periodicity jjm+1=1. +c aux poles. At the poles the fields value is repeated +c jjm+1 time. +c The parameters a,b,c,d represent the limite of the target +c gridpoint region. The means over this region are calculated +c from USN data, ponderated by a weight proportional to the +c surface occupated by the data inside the model gridpoint area. +c In most circumstances, this weight is the ratio between the +c surface of the USN gridpoint area and the surface of the +c model gridpoint area. +c +c (c) +c ----d----- +c | . . . .| +c | | +c (b)a . * . .b(a) +c | | +c | . . . .| +c ----c----- +c (d) +C======================================================================= +c INPUT: +c imdep, jmdep: dimensions X and Y input field +c xdata, ydata: coordinates X and Y input field +c zdata: Input field +c In this version it is assumed that the entry data come from +c the USNavy dataset: imdep=iusn=2160, jmdep=jusn=1080. +c OUTPUT: +c imar, jmar: dimensions X and Y Output field +c x, y: ccordinates X and Y Output field. +c zmea: Mean orographie +c zstd: Standard deviation +c zsig: Slope +c zgam: Anisotropy +c zthe: Orientation of the small axis +c zpic: Maximum altitude +c zval: Minimum altitude +C======================================================================= + + IMPLICIT INTEGER (I,J) + IMPLICIT REAL(X,Z) + + parameter(iusn=2160,jusn=1080,iext=216, epsfra = 1.e-5) +#include "dimensions.h" + REAL xusn(iusn+2*iext),yusn(jusn+2) + REAL zusn(iusn+2*iext,jusn+2) + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL zdata(imdep,jmdep) +c + INTEGER imar, jmar + +C INTERMEDIATE FIELDS (CORRELATIONS OF OROGRAPHY GRADIENT) + + REAL ztz(iim+1,jjm+1),zxtzx(iim+1,jjm+1) + REAL zytzy(iim+1,jjm+1),zxtzy(iim+1,jjm+1) + REAL weight(iim+1,jjm+1) + +C CORRELATIONS OF USN OROGRAPHY GRADIENTS + + REAL zxtzxusn(iusn+2*iext,jusn+2),zytzyusn(iusn+2*iext,jusn+2) + REAL zxtzyusn(iusn+2*iext,jusn+2) + REAL x(imar+1),y(jmar),zphi(imar+1,jmar) + REAL zmea(imar+1,jmar),zstd(imar+1,jmar) + REAL zmea0(imar+1,jmar) ! GK211005 (CG) + REAL zsig(imar+1,jmar),zgam(imar+1,jmar),zthe(imar+1,jmar) + REAL zpic(imar+1,jmar),zval(imar+1,jmar) +cx$$ PB integer mask(imar+1,jmar) + real mask(imar+1,jmar), mask_tmp(imar+1,jmar) + real num_tot(2200,1100),num_lan(2200,1100) +c + REAL a(2200),b(2200),c(1100),d(1100) + logical masque_lu +c + print *,' parametres de l orographie a l echelle sous maille' + xpi=acos(-1.) + rad = 6 371 229. + zdeltay=2.*xpi/float(jusn)*rad +c +c utilise-t'on un masque lu? +c + masque_lu = .true. + if (maxval(mask) == -99999 .and. minval(mask) == -99999) then + masque_lu= .false. + masque = 0.0 + endif + write(*,*)'Masque lu', masque_lu +c +c quelques tests de dimensions: +c +c + if(iim.ne.imar) STOP 'Problem dim. x' + if(jjm.ne.jmar-1) STOP 'Problem dim. y' + IF (imar.GT.2200 .OR. jmar.GT.1100) THEN + PRINT*, 'imar or jmar too big', imar, jmar + CALL ABORT + ENDIF + + IF(imdep.ne.iusn.or.jmdep.ne.jusn)then + print *,' imdep or jmdep bad dimensions:',imdep,jmdep + call abort + ENDIF + + IF(imar+1.ne.iim+1.or.jmar.ne.jjm+1)THEN + print *,' imar or jmar bad dimensions:',imar,jmar + call abort + ENDIF + + +c print *,'xdata:',xdata +c print *,'ydata:',ydata +c print *,'x:',x +c print *,'y:',y +c +C EXTENSION OF THE USN DATABASE TO POCEED COMPUTATIONS AT +C BOUNDARIES: +c + DO j=1,jusn + yusn(j+1)=ydata(j) + DO i=1,iusn + zusn(i+iext,j+1)=zdata(i,j) + xusn(i+iext)=xdata(i) + ENDDO + DO i=1,iext + zusn(i,j+1)=zdata(iusn-iext+i,j) + xusn(i)=xdata(iusn-iext+i)-2.*xpi + zusn(iusn+iext+i,j+1)=zdata(i,j) + xusn(iusn+iext+i)=xdata(i)+2.*xpi + ENDDO + ENDDO + + yusn(1)=ydata(1)+(ydata(1)-ydata(2)) + yusn(jusn+2)=ydata(jusn)+(ydata(jusn)-ydata(jusn-1)) + DO i=1,iusn/2+iext + zusn(i,1)=zusn(i+iusn/2,2) + zusn(i+iusn/2+iext,1)=zusn(i,2) + zusn(i,jusn+2)=zusn(i+iusn/2,jusn+1) + zusn(i+iusn/2+iext,jusn+2)=zusn(i,jusn+1) + ENDDO +c +c COMPUTE LIMITS OF MODEL GRIDPOINT AREA +C ( REGULAR GRID) +c + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar+1) = b(imar) + b(imar+1) = x(imar+1) + (x(imar+1)-x(imar))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 +c +c initialisations: +c + DO i = 1, imar+1 + DO j = 1, jmar + weight(i,j) = 0.0 + zxtzx(i,j) = 0.0 + zytzy(i,j) = 0.0 + zxtzy(i,j) = 0.0 + ztz(i,j) = 0.0 + zmea(i,j) = 0.0 + zpic(i,j) =-1.E+10 + zval(i,j) = 1.E+10 + ENDDO + ENDDO +c +c COMPUTE SLOPES CORRELATIONS ON USN GRID +c + DO j = 1,jusn+2 + DO i = 1, iusn+2*iext + zytzyusn(i,j)=0.0 + zxtzxusn(i,j)=0.0 + zxtzyusn(i,j)=0.0 + ENDDO + ENDDO + + + DO j = 2,jusn+1 + zdeltax=zdeltay*cos(yusn(j)) + DO i = 2, iusn+2*iext-1 + zytzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))**2/zdeltay**2 + zxtzxusn(i,j)=(zusn(i+1,j)-zusn(i-1,j))**2/zdeltax**2 + zxtzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))/zdeltay + * *(zusn(i+1,j)-zusn(i-1,j))/zdeltax + ENDDO + ENDDO +c +c SUMMATION OVER GRIDPOINT AREA +c + zleny=xpi/float(jusn)*rad + xincr=xpi/2./float(jusn) + DO ii = 1, imar+1 + DO jj = 1, jmar + num_tot(ii,jj)=0. + num_lan(ii,jj)=0. +c PRINT *,' iteration ii jj:',ii,jj + DO j = 2,jusn+1 +c DO j = 3,jusn + zlenx=zleny*cos(yusn(j)) + zdeltax=zdeltay*cos(yusn(j)) + zbordnor=(c(jj)-yusn(j)+xincr)*rad + zbordsud=(yusn(j)-d(jj)+xincr)*rad + weighy=AMAX1(0., + * amin1(zbordnor,zbordsud,zleny)) + IF(weighy.ne.0)THEN + DO i = 2, iusn+2*iext-1 + zbordest=(xusn(i)-a(ii)+xincr)*rad*cos(yusn(j)) + zbordoue=(b(ii)+xincr-xusn(i))*rad*cos(yusn(j)) + weighx=AMAX1(0., + * amin1(zbordest,zbordoue,zlenx)) + IF(weighx.ne.0)THEN + num_tot(ii,jj)=num_tot(ii,jj)+1.0 + if(zusn(i,j).ge.1.)num_lan(ii,jj)=num_lan(ii,jj)+1.0 + weight(ii,jj)=weight(ii,jj)+weighx*weighy + zxtzx(ii,jj)=zxtzx(ii,jj)+zxtzxusn(i,j)*weighx*weighy + zytzy(ii,jj)=zytzy(ii,jj)+zytzyusn(i,j)*weighx*weighy + zxtzy(ii,jj)=zxtzy(ii,jj)+zxtzyusn(i,j)*weighx*weighy + ztz(ii,jj) =ztz(ii,jj) +zusn(i,j)*zusn(i,j)*weighx*weighy +c mean + zmea(ii,jj) =zmea(ii,jj)+zusn(i,j)*weighx*weighy +c peacks + zpic(ii,jj)=amax1(zpic(ii,jj),zusn(i,j)) +c valleys + zval(ii,jj)=amin1(zval(ii,jj),zusn(i,j)) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c COMPUTE PARAMETERS NEEDED BY THE LOTT & MILLER (1997) AND +C LOTT (1999) SSO SCHEME. +c + zllmmea=0. + zllmstd=0. + zllmsig=0. + zllmgam=0. + zllmpic=0. + zllmval=0. + zllmthe=0. + zminthe=0. +c print 100,' ' +c100 format(1X,A1,'II JJ',4X,'H',8X,'SD',8X,'SI',3X,'GA',3X,'TH') + DO ii = 1, imar+1 + DO jj = 1, jmar + IF (weight(ii,jj) .NE. 0.0) THEN +c Mask +cx$$ if(num_lan(ii,jj)/num_tot(ii,jj).ge.0.5)then +cx$$ mask(ii,jj)=1 +cx$$ else +cx$$ mask(ii,jj)=0 +cx$$ ENDIF + if (.not. masque_lu) then + mask(ii,jj) = num_lan(ii,jj)/num_tot(ii,jj) + endif +c Mean Orography: + zmea (ii,jj)=zmea (ii,jj)/weight(ii,jj) + zxtzx(ii,jj)=zxtzx(ii,jj)/weight(ii,jj) + zytzy(ii,jj)=zytzy(ii,jj)/weight(ii,jj) + zxtzy(ii,jj)=zxtzy(ii,jj)/weight(ii,jj) + ztz(ii,jj) =ztz(ii,jj)/weight(ii,jj) +c Standard deviation: + zstd(ii,jj)=sqrt(AMAX1(0.,ztz(ii,jj)-zmea(ii,jj)**2)) + ELSE + PRINT*, 'probleme,ii,jj=', ii,jj + ENDIF + ENDDO + ENDDO + +C CORRECT VALUES OF HORIZONTAL SLOPE NEAR THE POLES: + + DO ii = 1, imar+1 + zxtzx(ii,1)=zxtzx(ii,2) + zxtzx(ii,jmar)=zxtzx(ii,jmar-1) + zxtzy(ii,1)=zxtzy(ii,2) + zxtzy(ii,jmar)=zxtzy(ii,jmar-1) + zytzy(ii,1)=zytzy(ii,2) + zytzy(ii,jmar)=zytzy(ii,jmar-1) + ENDDO + +C FILTERS TO SMOOTH OUT FIELDS FOR INPUT INTO SSO SCHEME. + +C FIRST FILTER, MOVING AVERAGE OVER 9 POINTS. + + zmea0(:,:) = zmea(:,:) ! GK211005 (CG) on sauvegarde la topo non lissee + CALL MVA9(zmea,iim+1,jjm+1) + CALL MVA9(zstd,iim+1,jjm+1) + CALL MVA9(zpic,iim+1,jjm+1) + CALL MVA9(zval,iim+1,jjm+1) + CALL MVA9(zxtzx,iim+1,jjm+1) + CALL MVA9(zxtzy,iim+1,jjm+1) + CALL MVA9(zytzy,iim+1,jjm+1) +Cx$$ Masque prenant en compte maximum de terre +Cx$$ On seuil a 10% de terre de terre car en dessous les parametres de surface n'on +Cx$$ pas de sens (PB) + mask_tmp= 0.0 + WHERE(mask .GE. 0.1) mask_tmp = 1. + + DO ii = 1, imar + DO jj = 1, jmar + IF (weight(ii,jj) .NE. 0.0) THEN +c Coefficients K, L et M: + xk=(zxtzx(ii,jj)+zytzy(ii,jj))/2. + xl=(zxtzx(ii,jj)-zytzy(ii,jj))/2. + xm=zxtzy(ii,jj) + xp=xk-sqrt(xl**2+xm**2) + xq=xk+sqrt(xl**2+xm**2) + xw=1.e-8 + if(xp.le.xw) xp=0. + if(xq.le.xw) xq=xw + if(abs(xm).le.xw) xm=xw*sign(1.,xm) +c slope: +cx$$ zsig(ii,jj)=sqrt(xq)*mask(ii,jj) +cx$$c isotropy: +cx$$ zgam(ii,jj)=xp/xq*mask(ii,jj) +cx$$c angle theta: +cx$$ zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask(ii,jj) +cx$$ zphi(ii,jj)=zmea(ii,jj)*mask(ii,jj) +cx$$ zmea(ii,jj)=zmea(ii,jj)*mask(ii,jj) +cx$$ zpic(ii,jj)=zpic(ii,jj)*mask(ii,jj) +cx$$ zval(ii,jj)=zval(ii,jj)*mask(ii,jj) +cx$$ zstd(ii,jj)=zstd(ii,jj)*mask(ii,jj) +Cx$* PB modif pour maque de terre fractionnaire +c slope: + zsig(ii,jj)=sqrt(xq)*mask_tmp(ii,jj) +c isotropy: + zgam(ii,jj)=xp/xq*mask_tmp(ii,jj) +c angle theta: + zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask_tmp(ii,jj) + ! GK211005 (CG) ne pas forcement lisser la topo + ! zphi(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj) + zphi(ii,jj)=zmea0(ii,jj)*mask_tmp(ii,jj) + ! + zmea(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj) + zpic(ii,jj)=zpic(ii,jj)*mask_tmp(ii,jj) + zval(ii,jj)=zval(ii,jj)*mask_tmp(ii,jj) + zstd(ii,jj)=zstd(ii,jj)*mask_tmp(ii,jj) +c print 101,ii,jj, +c * zmea(ii,jj),zstd(ii,jj),zsig(ii,jj),zgam(ii,jj), +c * zthe(ii,jj) +c101 format(1x,2(1x,i2),2(1x,f7.1),1x,f7.4,2x,f4.2,1x,f5.1) + ELSE +c PRINT*, 'probleme,ii,jj=', ii,jj + ENDIF + zllmmea=AMAX1(zmea(ii,jj),zllmmea) + zllmstd=AMAX1(zstd(ii,jj),zllmstd) + zllmsig=AMAX1(zsig(ii,jj),zllmsig) + zllmgam=AMAX1(zgam(ii,jj),zllmgam) + zllmthe=AMAX1(zthe(ii,jj),zllmthe) + zminthe=amin1(zthe(ii,jj),zminthe) + zllmpic=AMAX1(zpic(ii,jj),zllmpic) + zllmval=AMAX1(zval(ii,jj),zllmval) + ENDDO + ENDDO + print *,' MEAN ORO:',zllmmea + print *,' ST. DEV.:',zllmstd + print *,' PENTE:',zllmsig + print *,' ANISOTROP:',zllmgam + print *,' ANGLE:',zminthe,zllmthe + print *,' pic:',zllmpic + print *,' val:',zllmval + +C +c gamma and theta a 1. and 0. at poles +c + DO jj=1,jmar + zmea(imar+1,jj)=zmea(1,jj) + zphi(imar+1,jj)=zphi(1,jj) + zpic(imar+1,jj)=zpic(1,jj) + zval(imar+1,jj)=zval(1,jj) + zstd(imar+1,jj)=zstd(1,jj) + zsig(imar+1,jj)=zsig(1,jj) + zgam(imar+1,jj)=zgam(1,jj) + zthe(imar+1,jj)=zthe(1,jj) + ENDDO + + + zmeanor=0.0 + zmeasud=0.0 + zstdnor=0.0 + zstdsud=0.0 + zsignor=0.0 + zsigsud=0.0 + zweinor=0.0 + zweisud=0.0 + zpicnor=0.0 + zpicsud=0.0 + zvalnor=0.0 + zvalsud=0.0 + + DO ii=1,imar + zweinor=zweinor+ weight(ii, 1) + zweisud=zweisud+ weight(ii,jmar) + zmeanor=zmeanor+zmea(ii, 1)*weight(ii, 1) + zmeasud=zmeasud+zmea(ii,jmar)*weight(ii,jmar) + zstdnor=zstdnor+zstd(ii, 1)*weight(ii, 1) + zstdsud=zstdsud+zstd(ii,jmar)*weight(ii,jmar) + zsignor=zsignor+zsig(ii, 1)*weight(ii, 1) + zsigsud=zsigsud+zsig(ii,jmar)*weight(ii,jmar) + zpicnor=zpicnor+zpic(ii, 1)*weight(ii, 1) + zpicsud=zpicsud+zpic(ii,jmar)*weight(ii,jmar) + zvalnor=zvalnor+zval(ii, 1)*weight(ii, 1) + zvalsud=zvalsud+zval(ii,jmar)*weight(ii,jmar) + ENDDO + + DO ii=1,imar+1 + zmea(ii, 1)=zmeanor/zweinor + zmea(ii,jmar)=zmeasud/zweisud + zphi(ii, 1)=zmeanor/zweinor + zphi(ii,jmar)=zmeasud/zweisud + zpic(ii, 1)=zpicnor/zweinor + zpic(ii,jmar)=zpicsud/zweisud + zval(ii, 1)=zvalnor/zweinor + zval(ii,jmar)=zvalsud/zweisud + zstd(ii, 1)=zstdnor/zweinor + zstd(ii,jmar)=zstdsud/zweisud + zsig(ii, 1)=zsignor/zweinor + zsig(ii,jmar)=zsigsud/zweisud + zgam(ii, 1)=1. + zgam(ii,jmar)=1. + zthe(ii, 1)=0. + zthe(ii,jmar)=0. + ENDDO + + RETURN + END + + SUBROUTINE MVA9(X,IMAR,JMAR) + +C MAKE A MOVING AVERAGE OVER 9 GRIDPOINTS OF THE X FIELDS + + PARAMETER (ISMo=400,JSMo=200) + REAL X(IMAR,JMAR),XF(ISMo,JSMo) + real WEIGHTpb(-1:1,-1:1) + + if(imar.gt.ismo) stop'surdimensionner ismo dans mva9 (grid_noro)' + if(jmar.gt.jsmo) stop'surdimensionner jsmo dans mva9 (grid_noro)' + + SUM=0. + DO IS=-1,1 + DO JS=-1,1 + WEIGHTpb(IS,JS)=1./FLOAT((1+IS**2)*(1+JS**2)) + SUM=SUM+WEIGHTpb(IS,JS) + ENDDO + ENDDO + +c WRITE(*,*) 'MVA9 ', IMAR, JMAR +c WRITE(*,*) 'MVA9 ', WEIGHTpb +c WRITE(*,*) 'MVA9 SUM ', SUM + DO IS=-1,1 + DO JS=-1,1 + WEIGHTpb(IS,JS)=WEIGHTpb(IS,JS)/SUM + ENDDO + ENDDO + + DO J=2,JMAR-1 + DO I=2,IMAR-1 + XF(I,J)=0. + DO IS=-1,1 + DO JS=-1,1 + XF(I,J)=XF(I,J)+X(I+IS,J+JS)*WEIGHTpb(IS,JS) + ENDDO + ENDDO + ENDDO + ENDDO + + DO J=2,JMAR-1 + XF(1,J)=0. + IS=IMAR-1 + DO JS=-1,1 + XF(1,J)=XF(1,J)+X(IS,J+JS)*WEIGHTpb(-1,JS) + ENDDO + DO IS=0,1 + DO JS=-1,1 + XF(1,J)=XF(1,J)+X(1+IS,J+JS)*WEIGHTpb(IS,JS) + ENDDO + ENDDO + XF(IMAR,J)=XF(1,J) + ENDDO + + DO I=1,IMAR + XF(I,1)=XF(I,2) + XF(I,JMAR)=XF(I,JMAR-1) + ENDDO + + DO I=1,IMAR + DO J=1,JMAR + X(I,J)=XF(I,J) + ENDDO + ENDDO + + RETURN + END + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/grilles_gcm_netcdf.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/grilles_gcm_netcdf.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/grilles_gcm_netcdf.F (revision 1280) @@ -0,0 +1,305 @@ +! +! $Header$ +! +c +c + + PROGRAM create_fausse_var +C + IMPLICIT NONE +C +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" + + real temp(iim+1,jjm+1) +#include "netcdf.inc" + +c Attributs netcdf sortie + character*64 fich_out + integer*4 ncid_out,rcode_out + integer*4 out_lonuid,out_lonvid,out_latuid,out_latvid + integer*4 out_varid + integer*4 out_lonudim,out_lonvdim + integer*4 out_latudim,out_latvdim,out_dim(3) + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + + integer start(4),count(4) + + integer status,i,j + real rlatudeg(jjp1),rlatvdeg(jjm) + real rlonudeg(iip1),rlonvdeg(iip1) + + real dlon1(iip1),dlon2(iip1),dlat1(jjp1),dlat2(jjp1) + real acoslat,dxkm,dykm,resol(iip1,jjp1) + +#include "serre.h" +#include "fxyprim.h" + + print*,'OK0' + + rad = 6400000 + omeg = 7.272205e-05 + g = 9.8 + kappa = 0.285716 + daysec = 86400 + cpp = 1004.70885 + + preff = 101325. + pa= 50000. + +c open(99,file='run.def',status='old',form='formatted') +c CALL defrun_new( 99, .TRUE.,clesphy0 ) +c close(99) + + CALL conf_gcm( 99, .TRUE. , clesphy0 ) + CALL iniconst + CALL inigeom + + + print*,'OK1' + do j=1,jjp1 + rlatudeg(j)=rlatu(j)*180./pi + enddo + do j=1,jjm + rlatvdeg(j)=rlatv(j)*180./pi + enddo + + do i=1,iip1 + rlonudeg(i)=rlonu(i)*180./pi + 360. + rlonvdeg(i)=rlonv(i)*180./pi + 360. + enddo + + + print*,'OK2' +c 2 ----- OUVERTURE DE LA SORTIE NETCDF +c --------------------------------------------------- +c CREATION OUTPUT +c ouverture fichier netcdf de sortie out + fich_out='grilles_gcm.nc' + + status=NF_CREATE(fich_out,NF_NOCLOBBER,ncid_out) + status=NF_DEF_DIM(ncid_out,'lonu',iim+1,out_lonudim) + status=NF_DEF_DIM(ncid_out,'lonv',iim+1,out_lonvdim) + status=NF_DEF_DIM(ncid_out,'latu',jjm+1,out_latudim) + status=NF_DEF_DIM(ncid_out,'latv',jjm,out_latvdim) + + + print*,'OK3' +c Longitudes en u + print *,'OUTID: ',ncid_out + status=NF_DEF_VAR(ncid_out,'lonu',NF_FLOAT,1,out_lonudim, + % out_lonuid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'units', + % 12,'degrees_east') + status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'long_name', + % 9,'Longitude en u') + +c Longitudes en v + print *,'OUTID: ',ncid_out + status=NF_DEF_VAR(ncid_out,'lonv',NF_FLOAT,1,out_lonvdim, + % out_lonvid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'units', + % 12,'degrees_east') + status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'long_name', + % 9,'Longitude en v') + +c Latitude en u + status=NF_DEF_VAR(ncid_out,'latu',NF_FLOAT,1,out_latudim, + % out_latuid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'units', + % 13,'degrees_north') + status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'long_name', + % 8,'Latitude en u') + +c Latitude en v + status=NF_DEF_VAR(ncid_out,'latv',NF_FLOAT,1,out_latvdim, + % out_latvid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'units', + % 13,'degrees_north') + status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'long_name', + % 8,'Latitude en v') + +c ecriture de la grille u + out_dim(1)=out_lonudim + out_dim(2)=out_latudim + status=NF_DEF_VAR(ncid_out,'grille_u',NF_FLOAT,2,out_dim, + % out_varid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', + % 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', + % 16,'Grille aux point u') + +c ecriture de la grille v + out_dim(1)=out_lonvdim + out_dim(2)=out_latvdim + status=NF_DEF_VAR(ncid_out,'grille_v',NF_FLOAT,2,out_dim, + % out_varid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', + % 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', + % 16,'Grille aux point v') + +c ecriture de la grille u + out_dim(1)=out_lonvdim + out_dim(2)=out_latudim + status=NF_DEF_VAR(ncid_out,'grille_s',NF_FLOAT,2,out_dim, + % out_varid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', + % 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', + % 16,'Grille aux point u') + + + print*,'OK4' + status=NF_ENDDEF(ncid_out) +c 5) ----- FERMETURE DES FICHIERS NETCDF------------------ +c -------------------------------------------------------- +c 3-b- Ecriture de la grille pour la sortie +c rajoute l'ecriture de la grille + +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonuid,1,iim+1,rlonudeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonvid,1,iim+1,rlonvdeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_latuid,1,jjm+1,rlatudeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_latvid,1,jjm,rlatvdeg) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_lonuid,1,iim+1,rlonudeg) + status=NF_PUT_VARA_REAL(ncid_out,out_lonvid,1,iim+1,rlonvdeg) + status=NF_PUT_VARA_REAL(ncid_out,out_latuid,1,jjm+1,rlatudeg) + status=NF_PUT_VARA_REAL(ncid_out,out_latvid,1,jjm,rlatvdeg) +#endif + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=1 + + count(1)=iim+1 + count(2)=jjm+1 + count(3)=1 + count(4)=1 + + do j=1,jjm+1 + do i=1,iim+1 + temp(i,j)=mod(i,2)+mod(j,2) + enddo + enddo + +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_varid,start, + s count,temp) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_varid,start, + s count,temp) +#endif + + +c fermeture du fichier netcdf + call ncclos(ncid_out,rcode_out) + write(*,*) 'Fermeture: ',fich_out + + + print*,'OK5' +c Ecriture grads + open (20,file='grille.dat',form='unformatted',access='direct' + s ,recl=4*ip1jmp1) + write(20,rec=1) ((float(mod(i,2)+mod(j,2)),i=1,iip1),j=1,jjp1) + write(20,rec=2) ((float(mod(i,2)*mod(j,2)),i=1,iip1),j=1,jjp1) + do j=2,jjm + dlat1(j)=180.*(rlatv(j)-rlatv(j-1))/pi +c dlat2(j)=180.*fyprim(float(j))/pi + enddo + do i=2,iip1 + dlon1(i)=180.*(rlonu(i)-rlonu(i-1))/pi +c dlon2(i)=180.*fxprim(float(i))/pi + enddo + do j=2,jjm + dykm=(rlatv(j)-rlatv(j-1))*6400. + acoslat=6400.*cos(rlatu(j)) + do i=2,iip1 + dxkm=acoslat*(rlonu(i)-rlonu(i-1)) + resol(i,j)=sqrt(dykm*dykm+dxkm*dxkm) + enddo + resol(1,j)=resol(iip1,j) + enddo + write(20,rec=3) resol + dlon1(1)=dlon1(iip1) + dlon2(1)=dlon2(iip1) + write(20,rec=4) ((dlon1(i),i=1,iip1),j=1,jjp1) + write(20,rec=5) ((dlon1(i)*pi/180.*0.001* + s cos(rlatu(j))*rad,i=1,iip1),j=1,jjp1) + write(20,rec=6) ((dlon2(i),i=1,iip1),j=1,jjp1) + write(20,rec=7) ((dlat1(j),i=1,iip1),j=1,jjp1) + write(20,rec=8) ((dlat1(j)*pi/180.*rad*0.001,i=1,iip1),j=1,jjp1) + write(20,rec=9) ((dlat2(j),i=1,iip1),j=1,jjp1) + + print*,'I, LON, DX (km)' + do i=1,iip1 + print*,i,rlonu(i)*180./pi,dlon1(i)*pi/180.*0.001* + s cos(clat*pi/180.)*rad + enddo + print*,'J, LAT, DY (km)' + do j=1,jjp1 + print*,j,rlatu(j)*180./pi,dlat1(j)*pi/180.*0.001*rad + enddo + + open (21,file='grille.ctl',form='formatted') + +c WARNING! on reecrase le fichier .ctl a chaque ecriture + write(21,'(a5,1x,a40)') + & 'DSET ','^grille.dat' + + write(21,'(a12)') 'UNDEF 1.0E30' + write(21,'(a5,1x,a40)') 'TITLE ','grille' + call formcoord(21,iip1,rlonv,180./pi,.false.,'XDEF') + call formcoord(21,jjp1,rlatu,180./pi,.true.,'YDEF') + call formcoord(21,1,0.,1.,.false.,'ZDEF') + write(21,'(a4,i10,a30)') + & 'TDEF ',1,' LINEAR 23OCT1994 3hr ' + write(21,'(a4,2x,i5)') 'VARS',9 + write(21,'(a18)') 'grille 0 99 grille' + write(21,'(a18)') 'gril 0 99 gril ' + write(21,'(a29)') 'resol 0 99 resolution (km) ' + write(21,'(a18)') 'dlon1 0 99 dlon1 ' + write(21,'(a20)') 'dx 0 99 dx (km) ' + write(21,'(a18)') 'dlon2 0 99 dlon2 ' + write(21,'(a18)') 'dlat1 0 99 dlat1 ' + write(21,'(a20)') 'dy 0 99 dy (km) ' + write(21,'(a18)') 'dlat2 0 99 dlat2 ' + write(21,'(a7)') 'ENDVARS' + + + + + + print*,'OK6' + end + + + + subroutine handle_err(status) +#include "netcdf.inc" + + + integer status + print *,'handle code err: ',NF_NOERR + IF (status.NE.nf_noerr) THEN + print *,NF_STRERROR(status) + stop 'stopped' + ENDIF + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/groupe.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/groupe.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/groupe.F (revision 1280) @@ -0,0 +1,97 @@ +! +! $Header$ +! + subroutine groupe(pext,pbaru,pbarv,pbarum,pbarvm,wm) + implicit none + +c sous-programme servant a fitlrer les champs de flux de masse aux +c poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur +c et a mesure qu'on se rapproche du pole. +c +c en entree: pext, pbaru et pbarv +c +c en sortie: pbarum,pbarvm et wm. +c +c remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc +c pas besoin de w en entree. + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" +#include "comvert.h" + + integer ngroup + parameter (ngroup=3) + + + real pbaru(iip1,jjp1,llm),pbarv(iip1,jjm,llm) + real pext(iip1,jjp1,llm) + + real pbarum(iip1,jjp1,llm),pbarvm(iip1,jjm,llm) + real wm(iip1,jjp1,llm) + + real zconvm(iip1,jjp1,llm),zconvmm(iip1,jjp1,llm) + + real uu + + integer i,j,l + + logical firstcall + save firstcall + + data firstcall/.true./ + + if (firstcall) then + if(mod(iim,2**ngroup).ne.0) stop'probleme du nombre ede point' + firstcall=.false. + endif + +c Champs 1D + + call convflu(pbaru,pbarv,llm,zconvm) + +c + call scopy(ijp1llm,zconvm,1,zconvmm,1) + call scopy(ijmllm,pbarv,1,pbarvm,1) + +c + call groupeun(jjp1,llm,zconvmm) + call groupeun(jjm,llm,pbarvm) + +c Champs 3D + + do l=1,llm + do j=2,jjm + uu=pbaru(iim,j,l) + do i=1,iim + uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l) + pbarum(i,j,l)=uu +c zconvm(i,j,l ) = xflu(i-1,j,l)-xflu(i,j,l)+ +c * yflu(i,j,l)-yflu(i,j-1,l) + enddo + pbarum(iip1,j,l)=pbarum(1,j,l) + enddo + enddo + +c integration de la convergence de masse de haut en bas ...... + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + zconvmm(i,j,l)=zconvmm(i,j,l) + enddo + enddo + enddo + do l = llm-1,1,-1 + do j=1,jjp1 + do i=1,iip1 + zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1) + enddo + enddo + enddo + + CALL vitvert(zconvmm,wm) + + return + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/groupeun.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/groupeun.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/groupeun.F (revision 1280) @@ -0,0 +1,200 @@ +! +! $Header$ +! + SUBROUTINE groupeun(jjmax,llmax,q) + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" + + INTEGER jjmax,llmax + REAL q(iip1,jjmax,llmax) + + INTEGER ngroup + PARAMETER (ngroup=3) + + REAL airecn,qn + REAL airecs,qs + + INTEGER i,j,l,ig,ig2,j1,j2,i0,jd + +c--------------------------------------------------------------------c +c Strategie d'optimisation c +c stocker les valeurs systematiquement recalculees c +c et identiques d'un pas de temps sur l'autre. Il s'agit des c +c aires des cellules qui sont sommees. S'il n'y a pas de changement c +c de grille au cours de la simulation tout devrait bien se passer. c +c Autre optimisation : determination des bornes entre lesquelles "j" c +c varie, au lieu de faire un test à chaque fois... +c--------------------------------------------------------------------c + + INTEGER j_start, j_finish + + REAL, SAVE :: airen_tab(iip1,jjp1,0:1) + REAL, SAVE :: aires_tab(iip1,jjp1,0:1) + + LOGICAL, SAVE :: first = .TRUE. + INTEGER,SAVE :: i_index(iim,ngroup) + INTEGER :: offset + REAL :: qsum(iim/ngroup) + + IF (first) THEN + CALL INIT_GROUPEUN(airen_tab, aires_tab) + first = .FALSE. + ENDIF + + +c Champs 3D + jd=jjp1-jjmax +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + j1=1+jd + j2=2 + DO ig=1,ngroup + +c Concerne le pole nord + j_start = j1-jd + j_finish = j2-jd + DO ig2=1,ngroup-ig+1 + offset=2**(ig2-1) + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i0=1,iim,2**ig2 + q(i0,j,l)=q(i0,j,l)+q(i0+offset,j,l) + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i=1,iim + q(i,j,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),j,l) + ENDDO + ENDDO + + DO j=j_start, j_finish +!CDIR ON_ADB(airen_tab) +!CDIR ON_ADB(q) + DO i=1,iim + q(i,j,l)=q(i,j,l)*airen_tab(i,j,jd) + ENDDO + q(iip1,j,l)=q(1,j,l) + ENDDO + +!c Concerne le pole sud + j_start = j1-jd + j_finish = j2-jd + DO ig2=1,ngroup-ig+1 + offset=2**(ig2-1) + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i0=1,iim,2**ig2 + q(i0,jjp1-j+1-jd,l)= q(i0,jjp1-j+1-jd,l) + & +q(i0+offset,jjp1-j+1-jd,l) + ENDDO + ENDDO + ENDDO + + + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i=1,iim + q(i,jjp1-j+1-jd,l)=q(i-MOD(i-1,2**(ngroup-ig+1)), + & jjp1-j+1-jd,l) + ENDDO + ENDDO + + DO j=j_start, j_finish +!CDIR ON_ADB(aires_tab) +!CDIR ON_ADB(q) + DO i=1,iim + q(i,jjp1-j+1-jd,l)=q(i,jjp1-j+1-jd,l)* + & aires_tab(i,jjp1-j+1,jd) + ENDDO + q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l) + ENDDO + + + j1=j2+1 + j2=j2+2**ig + ENDDO + ENDDO +!$OMP END DO NOWAIT + + RETURN + END + + + + + SUBROUTINE INIT_GROUPEUN(airen_tab, aires_tab) + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" + + INTEGER ngroup + PARAMETER (ngroup=3) + + REAL airen,airecn + REAL aires,airecs + + INTEGER i,j,l,ig,j1,j2,i0,jd + + INTEGER j_start, j_finish + + REAL :: airen_tab(iip1,jjp1,0:1) + REAL :: aires_tab(iip1,jjp1,0:1) + + DO jd=0, 1 + j1=1+jd + j2=2 + DO ig=1,ngroup + +! c Concerne le pole nord + j_start = j1-jd + j_finish = j2-jd + DO j=j_start, j_finish + DO i0=1,iim,2**(ngroup-ig+1) + airen=0. + DO i=i0,i0+2**(ngroup-ig+1)-1 + airen = airen+aire(i,j) + ENDDO + DO i=i0,i0+2**(ngroup-ig+1)-1 + airen_tab(i,j,jd) = + & aire(i,j) / airen + ENDDO + ENDDO + ENDDO + +! c Concerne le pole sud + j_start = j1-jd + j_finish = j2-jd + DO j=j_start, j_finish + DO i0=1,iim,2**(ngroup-ig+1) + aires=0. + DO i=i0,i0+2**(ngroup-ig+1)-1 + aires=aires+aire(i,jjp1-j+1) + ENDDO + DO i=i0,i0+2**(ngroup-ig+1)-1 + aires_tab(i,jjp1-j+1,jd) = + & aire(i,jjp1-j+1) / aires + ENDDO + ENDDO + ENDDO + + j1=j2+1 + j2=j2+2**ig + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/guide_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/guide_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/guide_mod.F90 (revision 1280) @@ -0,0 +1,1547 @@ +! +! $Id$ +! +MODULE guide_mod + +!======================================================================= +! Auteur: F.Hourdin +! F. Codron 01/09 +!======================================================================= + + USE getparam + USE Write_Field + use netcdf, only: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close + + IMPLICIT NONE + +! --------------------------------------------- +! Declarations des cles logiques et parametres +! --------------------------------------------- + INTEGER, PRIVATE, SAVE :: iguide_read,iguide_int,iguide_sav + INTEGER, PRIVATE, SAVE :: nlevnc + LOGICAL, PRIVATE, SAVE :: guide_u,guide_v,guide_T,guide_Q,guide_P + LOGICAL, PRIVATE, SAVE :: guide_hr,guide_teta + LOGICAL, PRIVATE, SAVE :: guide_BL,guide_reg,guide_add,gamma4,guide_zon + LOGICAL, PRIVATE, SAVE :: guide_modele,invert_p,invert_y,ini_anal + LOGICAL, PRIVATE, SAVE :: guide_2D,guide_sav + + REAL, PRIVATE, SAVE :: tau_min_u,tau_max_u + REAL, PRIVATE, SAVE :: tau_min_v,tau_max_v + REAL, PRIVATE, SAVE :: tau_min_T,tau_max_T + REAL, PRIVATE, SAVE :: tau_min_Q,tau_max_Q + REAL, PRIVATE, SAVE :: tau_min_P,tau_max_P + + REAL, PRIVATE, SAVE :: lat_min_g,lat_max_g + REAL, PRIVATE, SAVE :: lon_min_g,lon_max_g + REAL, PRIVATE, SAVE :: tau_lon,tau_lat + + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_u,alpha_v + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_T,alpha_Q + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_P,alpha_pcor + +! --------------------------------------------- +! Variables de guidage +! --------------------------------------------- +! Variables des fichiers de guidage + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: unat1,unat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: vnat1,vnat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: tnat1,tnat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: qnat1,qnat2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: psnat1,psnat2 + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: apnc,bpnc +! Variables aux dimensions du modele + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: ugui1,ugui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: vgui1,vgui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: tgui1,tgui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: qgui1,qgui2 + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: psgui1,psgui2 + +CONTAINS +!======================================================================= + + SUBROUTINE guide_init + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "netcdf.inc" + INCLUDE "control.h" + + INTEGER :: error,ncidpl,rid,rcod + CHARACTER (len = 80) :: abort_message + CHARACTER (len = 20) :: modname = 'guide_init' + +! --------------------------------------------- +! Lecture des parametres: +! --------------------------------------------- +! Variables guidees + CALL getpar('guide_u',.true.,guide_u,'guidage de u') + CALL getpar('guide_v',.true.,guide_v,'guidage de v') + CALL getpar('guide_T',.true.,guide_T,'guidage de T') + CALL getpar('guide_P',.true.,guide_P,'guidage de P') + CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q') + CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R') + CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta') + + CALL getpar('guide_add',.false.,guide_add,'for�age constant?') + CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale') + +! Constantes de rappel. Unite : fraction de jour + CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u') + CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u') + CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v') + CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v') + CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T') + CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T') + CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q') + CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q') + CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P') + CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P') + CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie') + CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim') + +! Sauvegarde du for�age + CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage') + CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage') + ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois. + IF (iguide_sav.GT.0) THEN + iguide_sav=day_step/iguide_sav + ELSE + iguide_sav=day_step*iguide_sav + ENDIF + +! Guidage regional seulement (sinon constant ou suivant le zoom) + CALL getpar('guide_reg',.false.,guide_reg,'guidage regional') + CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ') + CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ') + CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ') + CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ') + CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ') + CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ') + +! Parametres pour lecture des fichiers + CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage') + CALL getpar('iguide_int',4,iguide_int,'freq. lecture guidage') + IF (iguide_int.GT.0) THEN + iguide_int=day_step/iguide_int + ELSE + iguide_int=day_step*iguide_int + ENDIF + CALL getpar('guide_modele',.false.,guide_modele,'guidage niveaux modele') + CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse') + CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses') + CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S') + CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P') + +! --------------------------------------------- +! Determination du nombre de niveaux verticaux +! des fichiers guidage +! --------------------------------------------- + ncidpl=-99 + if (guide_modele) then + if (ncidpl.eq.-99) rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl) + else + if (guide_u) then + if (ncidpl.eq.-99) rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl) + elseif (guide_v) then + if (ncidpl.eq.-99) rcod=nf90_open('v.nc',nf90_nowrite,ncidpl) + elseif (guide_T) then + if (ncidpl.eq.-99) rcod=nf90_open('T.nc',nf90_nowrite,ncidpl) + elseif (guide_Q) then + if (ncidpl.eq.-99) rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl) + endif + endif + error=NF_INQ_DIMID(ncidpl,'LEVEL',rid) + IF (error.NE.NF_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid) + IF (error.NE.NF_NOERR) THEN + print *,'Guide: probleme lecture niveaux pression' + CALL abort_gcm(modname,abort_message,1) + ENDIF + error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc) + print *,'Guide: nombre niveaux vert. nlevnc', nlevnc + rcod = nf90_close(ncidpl) + +! --------------------------------------------- +! Allocation des variables +! --------------------------------------------- + abort_message='pb in allocation guide' + + ALLOCATE(apnc(nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(bpnc(nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + apnc=0.;bpnc=0. + + ALLOCATE(alpha_pcor(llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_u(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_v(ip1jm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_T(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_Q(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_P(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0 + + IF (guide_u) THEN + ALLOCATE(unat1(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(ugui1(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(unat2(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(ugui2(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + unat1=0.;unat2=0.;ugui1=0.;ugui2=0. + ENDIF + + IF (guide_T) THEN + ALLOCATE(tnat1(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tgui1(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tnat2(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tgui2(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0. + ENDIF + + IF (guide_Q) THEN + ALLOCATE(qnat1(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qgui1(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qnat2(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qgui2(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0. + ENDIF + + IF (guide_v) THEN + ALLOCATE(vnat1(iip1,jjm,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vgui1(ip1jm,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vnat2(iip1,jjm,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vgui2(ip1jm,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0. + ENDIF + + IF (guide_P.OR.guide_modele) THEN + ALLOCATE(psnat1(iip1,jjp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(psnat2(iip1,jjp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + psnat1=0.;psnat2=0.; + ENDIF + IF (guide_P) THEN + ALLOCATE(psgui2(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(psgui1(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + psgui1=0.;psgui2=0. + ENDIF + +! --------------------------------------------- +! Lecture du premier etat de guidage. +! --------------------------------------------- + IF (guide_2D) THEN + CALL guide_read2D(1) + ELSE + CALL guide_read(1) + ENDIF + IF (guide_v) vnat1=vnat2 + IF (guide_u) unat1=unat2 + IF (guide_T) tnat1=tnat2 + IF (guide_Q) qnat1=qnat2 + IF (guide_P.OR.guide_modele) psnat1=psnat2 + + END SUBROUTINE guide_init + +!======================================================================= + SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps) + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "control.h" + INCLUDE "comconst.h" + INCLUDE "comvert.h" + + ! Variables entree + INTEGER, INTENT(IN) :: itau !pas de temps + REAL, DIMENSION (ip1jmp1,llm), INTENT(INOUT) :: ucov,teta,q,masse + REAL, DIMENSION (ip1jm,llm), INTENT(INOUT) :: vcov + REAL, DIMENSION (ip1jmp1), INTENT(INOUT) :: ps + + ! Variables locales + LOGICAL, SAVE :: first=.TRUE. + LOGICAL :: f_out ! sortie guidage + REAL, DIMENSION (ip1jmp1,llm) :: f_add ! var aux: champ de guidage + REAL, DIMENSION (ip1jmp1,llm) :: p ! besoin si guide_P + ! Compteurs temps: + INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage + REAL :: ditau, dday_step + REAL :: tau,reste ! position entre 2 etats de guidage + REAL, SAVE :: factt ! pas de temps en fraction de jour + + INTEGER :: l + +!----------------------------------------------------------------------- +! Initialisations au premier passage +!----------------------------------------------------------------------- + IF (first) THEN + first=.FALSE. + CALL guide_init + itau_test=1001 + step_rea=1 + count_no_rea=0 +! Calcul des constantes de rappel + factt=dtvr*iperiod/daysec + call tau2alpha(3,iip1,jjm ,factt,tau_min_v,tau_max_v,alpha_v) + call tau2alpha(2,iip1,jjp1,factt,tau_min_u,tau_max_u,alpha_u) + call tau2alpha(1,iip1,jjp1,factt,tau_min_T,tau_max_T,alpha_T) + call tau2alpha(1,iip1,jjp1,factt,tau_min_P,tau_max_P,alpha_P) + call tau2alpha(1,iip1,jjp1,factt,tau_min_Q,tau_max_Q,alpha_Q) +! correction de rappel dans couche limite + if (guide_BL) then + alpha_pcor(:)=1. + else + do l=1,llm + alpha_pcor(l)=(1.+tanh((0.85-presnivs(l)/preff)/0.05))/2. + enddo + endif +! ini_anal: etat initial egal au guidage + IF (ini_anal) THEN + CALL guide_interp(ps,teta) + IF (guide_u) ucov=ugui2 + IF (guide_v) vcov=ugui2 + IF (guide_T) teta=tgui2 + IF (guide_Q) q=qgui2 + IF (guide_P) THEN + ps=psgui2 + CALL pression(ip1jmp1,ap,bp,ps,p) + CALL massdair(p,masse) + ENDIF + RETURN + ENDIF +! Verification structure guidage + IF (guide_u) THEN + CALL writefield('unat',unat1) + CALL writefield('ucov',RESHAPE(ucov,(/iip1,jjp1,llm/))) + ENDIF + IF (guide_T) THEN + CALL writefield('tnat',tnat1) + CALL writefield('teta',RESHAPE(teta,(/iip1,jjp1,llm/))) + ENDIF + + ENDIF !first + +!----------------------------------------------------------------------- +! Lecture des fichiers de guidage ? +!----------------------------------------------------------------------- + IF (iguide_read.NE.0) THEN + ditau=real(itau) + dday_step=real(day_step) + IF (iguide_read.LT.0) THEN + tau=ditau/dday_step/FLOAT(iguide_read) + ELSE + tau=FLOAT(iguide_read)*ditau/dday_step + ENDIF + reste=tau-AINT(tau) + IF (reste.EQ.0.) THEN + IF (itau_test.EQ.itau) THEN + write(*,*)'deuxieme passage de advreel a itau=',itau + stop + ELSE + IF (guide_v) vnat1=vnat2 + IF (guide_u) unat1=unat2 + IF (guide_T) tnat1=tnat2 + IF (guide_Q) qnat1=qnat2 + IF (guide_P.OR.guide_modele) psnat1=psnat2 + step_rea=step_rea+1 + itau_test=itau + print*,'Lecture fichiers guidage, pas ',step_rea, & + 'apres ',count_no_rea,' non lectures' + IF (guide_2D) THEN + CALL guide_read2D(step_rea) + ELSE + CALL guide_read(step_rea) + ENDIF + count_no_rea=0 + ENDIF + ELSE + count_no_rea=count_no_rea+1 + + ENDIF + ENDIF !iguide_read=0 + +!----------------------------------------------------------------------- +! Interpolation et conversion des champs de guidage +!----------------------------------------------------------------------- + IF (MOD(itau,iguide_int).EQ.0) THEN + CALL guide_interp(ps,teta) + ENDIF +! Repartition entre 2 etats de guidage + IF (iguide_read.NE.0) THEN + tau=reste + ELSE + tau=1. + ENDIF + +!----------------------------------------------------------------------- +! Ajout des champs de guidage +!----------------------------------------------------------------------- +! Sauvegarde du guidage? + f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav) + IF (f_out) CALL guide_out("S",jjp1,1,ps) + + if (guide_u) then + if (guide_add) then + f_add=(1.-tau)*ugui1+tau*ugui2 + else + f_add=(1.-tau)*ugui1+tau*ugui2-ucov + endif + if (guide_zon) CALL guide_zonave(1,jjp1,llm,f_add) + CALL guide_addfield(ip1jmp1,llm,f_add,alpha_u) + IF (f_out) CALL guide_out("U",jjp1,llm,f_add/factt) + ucov=ucov+f_add + endif + + if (guide_T) then + if (guide_add) then + f_add=(1.-tau)*tgui1+tau*tgui2 + else + f_add=(1.-tau)*tgui1+tau*tgui2-teta + endif + if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add) + CALL guide_addfield(ip1jmp1,llm,f_add,alpha_T) + IF (f_out) CALL guide_out("T",jjp1,llm,f_add/factt) + teta=teta+f_add + endif + + if (guide_P) then + if (guide_add) then + f_add(1:ip1jmp1,1)=(1.-tau)*psgui1+tau*psgui2 + else + f_add(1:ip1jmp1,1)=(1.-tau)*psgui1+tau*psgui2-ps + endif + if (guide_zon) CALL guide_zonave(2,jjp1,1,f_add(1:ip1jmp1,1)) + CALL guide_addfield(ip1jmp1,1,f_add(1:ip1jmp1,1),alpha_P) + IF (f_out) CALL guide_out("P",jjp1,1,f_add(1:ip1jmp1,1)/factt) + ps=ps+f_add(1:ip1jmp1,1) + CALL pression(ip1jmp1,ap,bp,ps,p) + CALL massdair(p,masse) + endif + + if (guide_Q) then + if (guide_add) then + f_add=(1.-tau)*qgui1+tau*qgui2 + else + f_add=(1.-tau)*qgui1+tau*qgui2-q + endif + if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add) + CALL guide_addfield(ip1jmp1,llm,f_add,alpha_Q) + IF (f_out) CALL guide_out("Q",jjp1,llm,f_add/factt) + q=q+f_add + endif + + if (guide_v) then + if (guide_add) then + f_add(1:ip1jm,:)=(1.-tau)*vgui1+tau*vgui2 + else + f_add(1:ip1jm,:)=(1.-tau)*vgui1+tau*vgui2-vcov + endif + if (guide_zon) CALL guide_zonave(2,jjm,llm,f_add(1:ip1jm,:)) + CALL guide_addfield(ip1jm,llm,f_add(1:ip1jm,:),alpha_v) + IF (f_out) CALL guide_out("V",jjm,llm,f_add(1:ip1jm,:)/factt) + vcov=vcov+f_add(1:ip1jm,:) + endif + END SUBROUTINE guide_main + +!======================================================================= + SUBROUTINE guide_addfield(hsize,vsize,field,alpha) +! field1=a*field1+alpha*field2 + + IMPLICIT NONE + + ! input variables + INTEGER, INTENT(IN) :: hsize + INTEGER, INTENT(IN) :: vsize + REAL, DIMENSION(hsize), INTENT(IN) :: alpha + REAL, DIMENSION(hsize,vsize), INTENT(INOUT) :: field + + ! Local variables + INTEGER :: l + + do l=1,vsize + field(:,l)=alpha*field(:,l)*alpha_pcor(l) + enddo + + END SUBROUTINE guide_addfield + +!======================================================================= + SUBROUTINE guide_zonave(typ,hsize,vsize,field) + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "comgeom.h" + INCLUDE "comconst.h" + + ! input/output variables + INTEGER, INTENT(IN) :: typ + INTEGER, INTENT(IN) :: vsize + INTEGER, INTENT(IN) :: hsize + REAL, DIMENSION(hsize*iip1,vsize), INTENT(INOUT) :: field + + ! Local variables + LOGICAL, SAVE :: first=.TRUE. + INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain + INTEGER :: i,j,l,ij + REAL, DIMENSION (iip1) :: lond ! longitude in Deg. + REAL, DIMENSION (hsize,vsize):: fieldm ! zon-averaged field + + IF (first) THEN + first=.FALSE. +!Compute domain for averaging + lond=rlonu*180./pi + imin(1)=1;imax(1)=iip1; + imin(2)=1;imax(2)=iip1; + IF (guide_reg) THEN + DO i=1,iim + IF (lond(i).LT.lon_min_g) imin(1)=i + IF (lond(i).LE.lon_max_g) imax(1)=i + ENDDO + lond=rlonv*180./pi + DO i=1,iim + IF (lond(i).LT.lon_min_g) imin(2)=i + IF (lond(i).LE.lon_max_g) imax(2)=i + ENDDO + ENDIF + ENDIF + + fieldm=0. + DO l=1,vsize + ! Compute zonal average + DO j=1,hsize + DO i=imin(typ),imax(typ) + ij=(j-1)*iip1+i + fieldm(j,l)=fieldm(j,l)+field(ij,l) + ENDDO + ENDDO + fieldm(:,l)=fieldm(:,l)/FLOAT(imax(typ)-imin(typ)+1) + ! Compute forcing + DO j=1,hsize + DO i=1,iip1 + ij=(j-1)*iip1+i + field(ij,l)=fieldm(j,l) + ENDDO + ENDDO + ENDDO + + END SUBROUTINE guide_zonave + +!======================================================================= + SUBROUTINE guide_interp(psi,teta) + + IMPLICIT NONE + + include "dimensions.h" + include "paramet.h" + include "comvert.h" + include "comgeom2.h" + include "comconst.h" + + REAL, DIMENSION (iip1,jjp1), INTENT(IN) :: psi ! Psol gcm + REAL, DIMENSION (iip1,jjp1,llm), INTENT(IN) :: teta ! Temp. Pot. gcm + + LOGICAL, SAVE :: first=.TRUE. + ! Variables pour niveaux pression: + REAL, DIMENSION (iip1,jjp1,nlevnc) :: plnc1,plnc2 !niveaux pression guidage + REAL, DIMENSION (iip1,jjp1,llm) :: plunc,plsnc !niveaux pression modele + REAL, DIMENSION (iip1,jjm,llm) :: plvnc !niveaux pression modele + REAL, DIMENSION (iip1,jjp1,llmp1) :: p ! pression intercouches + REAL, DIMENSION (iip1,jjp1,llm) :: pls, pext ! var intermediaire + REAL, DIMENSION (iip1,jjp1,llm) :: pbarx + REAL, DIMENSION (iip1,jjm,llm) :: pbary + ! Variables pour fonction Exner (P milieu couche) + REAL, DIMENSION (iip1,jjp1,llm) :: pk, pkf + REAL, DIMENSION (iip1,jjp1,llm) :: alpha, beta + REAL, DIMENSION (iip1,jjp1) :: pks + REAL :: prefkap,unskap + ! Pression de vapeur saturante + REAL, DIMENSION (ip1jmp1,llm) :: qsat + !Variables intermediaires interpolation + REAL, DIMENSION (iip1,jjp1,llm) :: zu1,zu2 + REAL, DIMENSION (iip1,jjm,llm) :: zv1,zv2 + + INTEGER :: i,j,l,ij + + print *,'Guide: conversion variables guidage' +! ----------------------------------------------------------------- +! Calcul des niveaux de pression champs guidage +! ----------------------------------------------------------------- +if (guide_modele) then + do i=1,iip1 + do j=1,jjp1 + do l=1,nlevnc + plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j) + plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j) + enddo + enddo + enddo +else + do i=1,iip1 + do j=1,jjp1 + do l=1,nlevnc + plnc2(i,j,l)=apnc(l) + plnc1(i,j,l)=apnc(l) + enddo + enddo + enddo + +endif + if (first) then + first=.FALSE. + print*,'Guide: verification ordre niveaux verticaux' + print*,'LMDZ :' + do l=1,llm + print*,'PL(',l,')=',(ap(l)+ap(l+1))/2. & + +psi(1,jjp1)*(bp(l)+bp(l+1))/2. + enddo + print*,'Fichiers guidage' + do l=1,nlevnc + print*,'PL(',l,')=',plnc2(1,1,l) + enddo + print *,'inversion de l''ordre: invert_p=',invert_p + if (guide_u) then + do l=1,nlevnc + print*,'U(',l,')=',unat2(1,1,l) + enddo + endif + if (guide_T) then + do l=1,nlevnc + print*,'T(',l,')=',tnat2(1,1,l) + enddo + endif + endif + +! ----------------------------------------------------------------- +! Calcul niveaux pression modele +! ----------------------------------------------------------------- + CALL pression( ip1jmp1, ap, bp, psi, p ) + CALL exner_hyb(ip1jmp1,psi,p,alpha,beta,pks,pk,pkf) + +! .... Calcul de pls , pression au milieu des couches ,en Pascals + unskap=1./kappa + prefkap = preff ** kappa + DO l = 1, llm + DO j=1,jjp1 + DO i =1, iip1 + pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap + ENDDO + ENDDO + ENDDO + +! calcul des pressions pour les grilles u et v + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + pext(i,j,l)=pls(i,j,l)*aire(i,j) + enddo + enddo + enddo + call massbar(pext, pbarx, pbary ) + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j) + plsnc(i,j,l)=pls(i,j,l) + enddo + enddo + enddo + do l=1,llm + do j=1,jjm + do i=1,iip1 + plvnc(i,j,l)=pbary(i,j,l)/airev(i,j) + enddo + enddo + enddo + +! ----------------------------------------------------------------- +! Interpolation champs guidage sur niveaux modele (+inversion N/S) +! Conversion en variables gcm (ucov, vcov...) +! ----------------------------------------------------------------- + if (guide_P) then + do j=1,jjp1 + do i=1,iim + ij=(j-1)*iip1+i + psgui1(ij)=psnat1(i,j) + psgui2(ij)=psnat2(i,j) + enddo + psgui1(iip1*j)=psnat1(1,j) + psgui2(iip1*j)=psnat2(1,j) + enddo + endif + + IF (guide_u) THEN + CALL pres2lev(unat1,zu1,nlevnc,llm,plnc1,plunc,iip1,jjp1,invert_p) + CALL pres2lev(unat2,zu2,nlevnc,llm,plnc2,plunc,iip1,jjp1,invert_p) + do l=1,llm + do j=1,jjp1 + do i=1,iim + ij=(j-1)*iip1+i + ugui1(ij,l)=zu1(i,j,l)*cu(i,j) + ugui2(ij,l)=zu2(i,j,l)*cu(i,j) + enddo + ugui1(j*iip1,l)=ugui1((j-1)*iip1+1,l) + ugui2(j*iip1,l)=ugui2((j-1)*iip1+1,l) + enddo + do i=1,iip1 + ugui1(i,l)=0. + ugui1(ip1jm+i,l)=0. + ugui2(i,l)=0. + ugui2(ip1jm+i,l)=0. + enddo + enddo + ENDIF + + IF (guide_T) THEN + CALL pres2lev(tnat1,zu1,nlevnc,llm,plnc1,plsnc,iip1,jjp1,invert_p) + CALL pres2lev(tnat2,zu2,nlevnc,llm,plnc2,plsnc,iip1,jjp1,invert_p) + do l=1,llm + do j=1,jjp1 + IF (guide_teta) THEN + do i=1,iim + ij=(j-1)*iip1+i + tgui1(ij,l)=zu1(i,j,l) + tgui2(ij,l)=zu2(i,j,l) + enddo + ELSE + do i=1,iim + ij=(j-1)*iip1+i + tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l) + tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l) + enddo + ENDIF + tgui1(j*iip1,l)=tgui1((j-1)*iip1+1,l) + tgui2(j*iip1,l)=tgui2((j-1)*iip1+1,l) + enddo + do i=1,iip1 + tgui1(i,l)=tgui1(1,l) + tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l) + tgui2(i,l)=tgui2(1,l) + tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l) + enddo + enddo + ENDIF + + IF (guide_v) THEN + + CALL pres2lev(vnat1,zv1,nlevnc,llm,plnc1(:,:jjm,:),plvnc,iip1,jjm,invert_p) + CALL pres2lev(vnat2,zv2,nlevnc,llm,plnc2(:,:jjm,:),plvnc,iip1,jjm,invert_p) + + do l=1,llm + do j=1,jjm + do i=1,iim + ij=(j-1)*iip1+i + vgui1(ij,l)=zv1(i,j,l)*cv(i,j) + vgui2(ij,l)=zv2(i,j,l)*cv(i,j) + enddo + vgui1(j*iip1,l)=vgui1((j-1)*iip1+1,l) + vgui2(j*iip1,l)=vgui2((j-1)*iip1+1,l) + enddo + enddo + ENDIF + + IF (guide_Q) THEN + ! On suppose qu'on a la bonne variable dans le fichier de guidage: + ! Hum.Rel si guide_hr, Hum.Spec. sinon. + CALL pres2lev(qnat1,zu1,nlevnc,llm,plnc1,plsnc,iip1,jjp1,invert_p) + CALL pres2lev(qnat2,zu2,nlevnc,llm,plnc2,plsnc,iip1,jjp1,invert_p) + do l=1,llm + do j=1,jjp1 + do i=1,iim + ij=(j-1)*iip1+i + qgui1(ij,l)=zu1(i,j,l) + qgui2(ij,l)=zu2(i,j,l) + enddo + qgui1(j*iip1,l)=qgui1((j-1)*iip1+1,l) + qgui2(j*iip1,l)=qgui2((j-1)*iip1+1,l) + enddo + do i=1,iip1 + qgui1(i,l)=qgui1(1,l) + qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l) + qgui2(i,l)=qgui2(1,l) + qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l) + enddo + enddo + IF (guide_hr) THEN + CALL q_sat(iip1*jjp1*llm,teta*pk/cpp,plsnc,qsat) + qgui1=qgui1*qsat*0.01 !hum. rel. en % + qgui2=qgui2*qsat*0.01 + ENDIF + ENDIF + + END SUBROUTINE guide_interp + +!======================================================================= + SUBROUTINE tau2alpha(typ,pim,pjm,factt,taumin,taumax,alpha) + +! Calcul des constantes de rappel alpha (=1/tau) + + implicit none + + include "dimensions.h" + include "paramet.h" + include "comconst.h" + include "comgeom2.h" + include "serre.h" + +! input arguments : + INTEGER, INTENT(IN) :: typ ! u(2),v(3), ou scalaire(1) + INTEGER, INTENT(IN) :: pim,pjm ! dimensions en lat, lon + REAL, INTENT(IN) :: factt ! pas de temps en fraction de jour + REAL, INTENT(IN) :: taumin,taumax +! output arguments: + REAL, DIMENSION(pim,pjm), INTENT(OUT) :: alpha + +! local variables: + LOGICAL, SAVE :: first=.TRUE. + REAL, SAVE :: gamma,dxdy_min,dxdy_max + REAL, DIMENSION (iip1,jjp1) :: zdx,zdy + REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu + REAL, DIMENSION (iip1,jjm) :: dxdyv + real dxdy_ + real zlat,zlon + real alphamin,alphamax,xi + integer i,j,ilon,ilat + + + alphamin=factt/taumax + alphamax=factt/taumin + IF (guide_reg.OR.guide_add) THEN + alpha=alphamax +!----------------------------------------------------------------------- +! guide_reg: alpha=alpha_min dans region, 0. sinon. +!----------------------------------------------------------------------- + IF (guide_reg) THEN + do j=1,pjm + do i=1,pim + if (typ.eq.2) then + zlat=rlatu(j)*180./pi + zlon=rlonu(i)*180./pi + elseif (typ.eq.1) then + zlat=rlatu(j)*180./pi + zlon=rlonv(i)*180./pi + elseif (typ.eq.3) then + zlat=rlatv(j)*180./pi + zlon=rlonv(i)*180./pi + endif + alpha(i,j)=alphamax/16.* & + (1.+tanh((zlat-lat_min_g)/tau_lat))* & + (1.+tanh((lat_max_g-zlat)/tau_lat))* & + (1.+tanh((zlon-lon_min_g)/tau_lon))* & + (1.+tanh((lon_max_g-zlon)/tau_lon)) + enddo + enddo + ENDIF + ELSE +!----------------------------------------------------------------------- +! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom. +!----------------------------------------------------------------------- +!Calcul de l'aire des mailles + do j=2,jjm + do i=2,iip1 + zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j)) + enddo + zdx(1,j)=zdx(iip1,j) + enddo + do j=2,jjm + do i=1,iip1 + zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j)) + enddo + enddo + do i=1,iip1 + zdx(i,1)=zdx(i,2) + zdx(i,jjp1)=zdx(i,jjm) + zdy(i,1)=zdy(i,2) + zdy(i,jjp1)=zdy(i,jjm) + enddo + do j=1,jjp1 + do i=1,iip1 + dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j)) + enddo + enddo + IF (typ.EQ.2) THEN + do j=1,jjp1 + do i=1,iim + dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j)) + enddo + dxdyu(iip1,j)=dxdyu(1,j) + enddo + ENDIF + IF (typ.EQ.3) THEN + do j=1,jjm + do i=1,iip1 + dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1)) + enddo + enddo + ENDIF +! Premier appel: calcul des aires min et max et de gamma. + IF (first) THEN + first=.FALSE. + ! coordonnees du centre du zoom + CALL coordij(clon,clat,ilon,ilat) + ! aire de la maille au centre du zoom + dxdy_min=dxdys(ilon,ilat) + ! dxdy maximale de la maille + dxdy_max=0. + do j=1,jjp1 + do i=1,iip1 + dxdy_max=max(dxdy_max,dxdys(i,j)) + enddo + enddo + ! Calcul de gamma + if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then + print*,'ATTENTION modele peu zoome' + print*,'ATTENTION on prend une constante de guidage cste' + gamma=0. + else + gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min) + print*,'gamma=',gamma + if (gamma.lt.1.e-5) then + print*,'gamma =',gamma,'<1e-5' + stop + endif + gamma=log(0.5)/log(gamma) + if (gamma4) then + gamma=min(gamma,4.) + endif + print*,'gamma=',gamma + endif + ENDIF !first + + do j=1,pjm + do i=1,pim + if (typ.eq.1) then + dxdy_=dxdys(i,j) + zlat=rlatu(j)*180./pi + elseif (typ.eq.2) then + dxdy_=dxdyu(i,j) + zlat=rlatu(j)*180./pi + elseif (typ.eq.3) then + dxdy_=dxdyv(i,j) + zlat=rlatv(j)*180./pi + endif + if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then + ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin + alpha(i,j)=alphamin + else + xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma + xi=min(xi,1.) + if(lat_min_g.le.zlat .and. zlat.le.lat_max_g) then + alpha(i,j)=xi*alphamin+(1.-xi)*alphamax + else + alpha(i,j)=0. + endif + endif + enddo + enddo + ENDIF ! guide_reg + + END SUBROUTINE tau2alpha + +!======================================================================= + SUBROUTINE guide_read(timestep) + + IMPLICIT NONE + +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" + + INTEGER, INTENT(IN) :: timestep + + LOGICAL, SAVE :: first=.TRUE. +! Identification fichiers et variables NetCDF: + INTEGER, SAVE :: ncidu,varidu,ncidv,varidv,ncidQ + INTEGER, SAVE :: varidQ,ncidt,varidt,ncidps,varidps + INTEGER :: ncidpl,varidpl,varidap,varidbp +! Variables auxiliaires NetCDF: + INTEGER, DIMENSION(4) :: start,count + INTEGER :: status,rcode + +! ----------------------------------------------------------------- +! Premier appel: initialisation de la lecture des fichiers +! ----------------------------------------------------------------- + if (first) then + ncidpl=-99 + print*,'Guide: ouverture des fichiers guidage ' +! Niveaux de pression si non constants + if (guide_modele) then + print *,'Lecture du guidage sur niveaux mod�le' + rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl) + rcode = nf90_inq_varid(ncidpl, 'AP', varidap) + rcode = nf90_inq_varid(ncidpl, 'BP', varidbp) + print*,'ncidpl,varidap',ncidpl,varidap + endif +! Vent zonal + if (guide_u) then + rcode = nf90_open('u.nc', nf90_nowrite, ncidu) + rcode = nf90_inq_varid(ncidu, 'UWND', varidu) + print*,'ncidu,varidu',ncidu,varidu + if (ncidpl.eq.-99) ncidpl=ncidu + endif +! Vent meridien + if (guide_v) then + rcode = nf90_open('v.nc', nf90_nowrite, ncidv) + rcode = nf90_inq_varid(ncidv, 'VWND', varidv) + print*,'ncidv,varidv',ncidv,varidv + if (ncidpl.eq.-99) ncidpl=ncidv + endif +! Temperature + if (guide_T) then + rcode = nf90_open('T.nc', nf90_nowrite, ncidt) + rcode = nf90_inq_varid(ncidt, 'AIR', varidt) + print*,'ncidT,varidT',ncidt,varidt + if (ncidpl.eq.-99) ncidpl=ncidt + endif +! Humidite + if (guide_Q) then + rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ) + rcode = nf90_inq_varid(ncidQ, 'RH', varidQ) + print*,'ncidQ,varidQ',ncidQ,varidQ + if (ncidpl.eq.-99) ncidpl=ncidQ + endif +! Pression de surface + if ((guide_P).OR.(guide_modele)) then + rcode = nf90_open('ps.nc', nf90_nowrite, ncidps) + rcode = nf90_inq_varid(ncidps, 'SP', varidps) + print*,'ncidps,varidps',ncidps,varidps + endif +! Coordonnee verticale + if (.not.guide_modele) then + rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl) + IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl) + print*,'ncidpl,varidpl',ncidpl,varidpl + endif +! Coefs ap, bp pour calcul de la pression aux differents niveaux + if (guide_modele) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc) +#endif + else +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc) +#endif + apnc=apnc*100.! conversion en Pascals + bpnc(:)=0. + endif + first=.FALSE. + endif ! (first) + +! ----------------------------------------------------------------- +! lecture des champs u, v, T, Q, ps +! ----------------------------------------------------------------- + +! dimensions pour les champs scalaires et le vent zonal + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=timestep + + count(1)=iip1 + count(2)=jjp1 + count(3)=nlevnc + count(4)=1 + +! Vent zonal + if (guide_u) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,unat2) +#else + status=NF_GET_VARA_REAL(ncidu,varidu,start,count,unat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,unat2) + ENDIF + endif + +! Temperature + if (guide_T) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,tnat2) +#else + status=NF_GET_VARA_REAL(ncidt,varidt,start,count,tnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,tnat2) + ENDIF + endif + +! Humidite + if (guide_Q) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,qnat2) +#else + status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,qnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,qnat2) + ENDIF + + endif + +! Vent meridien + if (guide_v) then + count(2)=jjm +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,vnat2) +#else + status=NF_GET_VARA_REAL(ncidv,varidv,start,count,vnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjm,llm,vnat2) + ENDIF + endif + +! Pression de surface + if ((guide_P).OR.(guide_modele)) then + start(3)=timestep + start(4)=0 + count(2)=jjp1 + count(3)=1 + count(4)=0 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,psnat2) +#else + status=NF_GET_VARA_REAL(ncidps,varidps,start,count,psnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,1,psnat2) + ENDIF + endif + + END SUBROUTINE guide_read + +!======================================================================= + SUBROUTINE guide_read2D(timestep) + + IMPLICIT NONE + +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" + + INTEGER, INTENT(IN) :: timestep + + LOGICAL, SAVE :: first=.TRUE. +! Identification fichiers et variables NetCDF: + INTEGER, SAVE :: ncidu,varidu,ncidv,varidv,ncidQ + INTEGER, SAVE :: varidQ,ncidt,varidt,ncidps,varidps + INTEGER :: ncidpl,varidpl,varidap,varidbp +! Variables auxiliaires NetCDF: + INTEGER, DIMENSION(4) :: start,count + INTEGER :: status,rcode +! Variables for 3D extension: + REAL, DIMENSION (jjp1,llm) :: zu + REAL, DIMENSION (jjm,llm) :: zv + INTEGER :: i + +! ----------------------------------------------------------------- +! Premier appel: initialisation de la lecture des fichiers +! ----------------------------------------------------------------- + if (first) then + ncidpl=-99 + print*,'Guide: ouverture des fichiers guidage ' +! Niveaux de pression si non constants + if (guide_modele) then + print *,'Lecture du guidage sur niveaux mod�le' + rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl) + rcode = nf90_inq_varid(ncidpl, 'AP', varidap) + rcode = nf90_inq_varid(ncidpl, 'BP', varidbp) + print*,'ncidpl,varidap',ncidpl,varidap + endif +! Vent zonal + if (guide_u) then + rcode = nf90_open('u.nc', nf90_nowrite, ncidu) + rcode = nf90_inq_varid(ncidu, 'UWND', varidu) + print*,'ncidu,varidu',ncidu,varidu + if (ncidpl.eq.-99) ncidpl=ncidu + endif +! Vent meridien + if (guide_v) then + rcode = nf90_open('v.nc', nf90_nowrite, ncidv) + rcode = nf90_inq_varid(ncidv, 'VWND', varidv) + print*,'ncidv,varidv',ncidv,varidv + if (ncidpl.eq.-99) ncidpl=ncidv + endif +! Temperature + if (guide_T) then + rcode = nf90_open('T.nc', nf90_nowrite, ncidt) + rcode = nf90_inq_varid(ncidt, 'AIR', varidt) + print*,'ncidT,varidT',ncidt,varidt + if (ncidpl.eq.-99) ncidpl=ncidt + endif +! Humidite + if (guide_Q) then + rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ) + rcode = nf90_inq_varid(ncidQ, 'RH', varidQ) + print*,'ncidQ,varidQ',ncidQ,varidQ + if (ncidpl.eq.-99) ncidpl=ncidQ + endif +! Pression de surface + if ((guide_P).OR.(guide_modele)) then + rcode = nf90_open('ps.nc', nf90_nowrite, ncidps) + rcode = nf90_inq_varid(ncidps, 'SP', varidps) + print*,'ncidps,varidps',ncidps,varidps + endif +! Coordonnee verticale + if (.not.guide_modele) then + rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl) + IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl) + print*,'ncidpl,varidpl',ncidpl,varidpl + endif +! Coefs ap, bp pour calcul de la pression aux differents niveaux + if (guide_modele) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc) +#endif + else +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc) +#endif + apnc=apnc*100.! conversion en Pascals + bpnc(:)=0. + endif + first=.FALSE. + endif ! (first) + +! ----------------------------------------------------------------- +! lecture des champs u, v, T, Q, ps +! ----------------------------------------------------------------- + +! dimensions pour les champs scalaires et le vent zonal + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=timestep + + count(1)=1 + count(2)=jjp1 + count(3)=nlevnc + count(4)=1 + +! Vent zonal + if (guide_u) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidu,varidu,start,count,zu) +#endif + DO i=1,iip1 + unat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,unat2) + ENDIF + + endif + +! Temperature + if (guide_T) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidt,varidt,start,count,zu) +#endif + DO i=1,iip1 + tnat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,tnat2) + ENDIF + + endif + +! Humidite + if (guide_Q) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,zu) +#endif + DO i=1,iip1 + qnat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,qnat2) + ENDIF + + endif + +! Vent meridien + if (guide_v) then + count(2)=jjm +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,zv) +#else + status=NF_GET_VARA_REAL(ncidv,varidv,start,count,zv) +#endif + DO i=1,iip1 + vnat2(i,:,:)=zv(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjm,llm,vnat2) + ENDIF + + endif + +! Pression de surface + if ((guide_P).OR.(guide_modele)) then + start(3)=timestep + start(4)=0 + count(2)=jjp1 + count(3)=1 + count(4)=0 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,zu(:,1)) +#else + status=NF_GET_VARA_REAL(ncidps,varidps,start,count,zu(:,1)) +#endif + DO i=1,iip1 + psnat2(i,:)=zu(:,1) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,1,psnat2) + ENDIF + + endif + + END SUBROUTINE guide_read2D + +!======================================================================= + SUBROUTINE guide_out(varname,hsize,vsize,field) + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "netcdf.inc" + INCLUDE "comgeom2.h" + INCLUDE "comconst.h" + INCLUDE "comvert.h" + + ! Variables entree + CHARACTER, INTENT(IN) :: varname + INTEGER, INTENT (IN) :: hsize,vsize + REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field + + ! Variables locales + INTEGER, SAVE :: timestep=0 + ! Identites fichier netcdf + INTEGER :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev + INTEGER :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev + INTEGER, DIMENSION (3) :: dim3 + INTEGER, DIMENSION (4) :: dim4,count,start + INTEGER :: ierr, varid + + print *,'Guide: output timestep',timestep,'var ',varname + IF (timestep.EQ.0) THEN +! ---------------------------------------------- +! initialisation fichier de sortie +! ---------------------------------------------- +! Ouverture du fichier + ierr=NF_CREATE("guide_ins.nc",NF_CLOBBER,nid) +! Definition des dimensions + ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu) + ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv) + ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu) + ierr=NF_DEF_DIM(nid,"LATV",jjm,id_latv) + ierr=NF_DEF_DIM(nid,"LEVEL",llm,id_lev) + ierr=NF_DEF_DIM(nid,"TIME",NF_UNLIMITED,id_tim) + +! Creation des variables dimensions + ierr=NF_DEF_VAR(nid,"LONU",NF_FLOAT,1,id_lonu,vid_lonu) + ierr=NF_DEF_VAR(nid,"LONV",NF_FLOAT,1,id_lonv,vid_lonv) + ierr=NF_DEF_VAR(nid,"LATU",NF_FLOAT,1,id_latu,vid_latu) + ierr=NF_DEF_VAR(nid,"LATV",NF_FLOAT,1,id_latv,vid_latv) + ierr=NF_DEF_VAR(nid,"LEVEL",NF_FLOAT,1,id_lev,vid_lev) + ierr=NF_DEF_VAR(nid,"cu",NF_FLOAT,2,(/id_lonu,id_latu/),vid_cu) + ierr=NF_DEF_VAR(nid,"cv",NF_FLOAT,2,(/id_lonv,id_latv/),vid_cv) + + ierr=NF_ENDDEF(nid) + +! Enregistrement des variables dimensions +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonu,rlonu*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonv,rlonv*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_latu,rlatu*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_latv,rlatv*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lev,presnivs) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_cu,cu) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_cv,cv) +#else + ierr = NF_PUT_VAR_REAL(nid,vid_lonu,rlonu*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_lonv,rlonv*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_latu,rlatu*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_latv,rlatv*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_lev,presnivs) + ierr = NF_PUT_VAR_REAL(nid,vid_cu,cu) + ierr = NF_PUT_VAR_REAL(nid,vid_cv,cv) +#endif +! -------------------------------------------------------------------- +! Cr�ation des variables sauvegard�es +! -------------------------------------------------------------------- + ierr = NF_REDEF(nid) +! Surface pressure (GCM) + dim3=(/id_lonv,id_latu,id_tim/) + ierr = NF_DEF_VAR(nid,"SP",NF_FLOAT,3,dim3,varid) +! Surface pressure (guidage) + IF (guide_P) THEN + dim3=(/id_lonv,id_latu,id_tim/) + ierr = NF_DEF_VAR(nid,"ps",NF_FLOAT,3,dim3,varid) + ENDIF +! Zonal wind + IF (guide_u) THEN + dim4=(/id_lonu,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"ucov",NF_FLOAT,4,dim4,varid) + ENDIF +! Merid. wind + IF (guide_v) THEN + dim4=(/id_lonv,id_latv,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"vcov",NF_FLOAT,4,dim4,varid) + ENDIF +! Pot. Temperature + IF (guide_T) THEN + dim4=(/id_lonv,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"teta",NF_FLOAT,4,dim4,varid) + ENDIF +! Specific Humidity + IF (guide_Q) THEN + dim4=(/id_lonv,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"q",NF_FLOAT,4,dim4,varid) + ENDIF + + ierr = NF_ENDDEF(nid) + ierr = NF_CLOSE(nid) + ENDIF ! timestep=0 + +! -------------------------------------------------------------------- +! Enregistrement du champ +! -------------------------------------------------------------------- + ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid) + + SELECT CASE (varname) + CASE ("S") + timestep=timestep+1 + ierr = NF_INQ_VARID(nid,"SP",varid) + start=(/1,1,timestep,0/) + count=(/iip1,jjp1,1,0/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("P") + ierr = NF_INQ_VARID(nid,"ps",varid) + start=(/1,1,timestep,0/) + count=(/iip1,jjp1,1,0/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("U") + ierr = NF_INQ_VARID(nid,"ucov",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("V") + ierr = NF_INQ_VARID(nid,"vcov",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjm,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("T") + ierr = NF_INQ_VARID(nid,"teta",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("Q") + ierr = NF_INQ_VARID(nid,"q",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + END SELECT + + ierr = NF_CLOSE(nid) + + END SUBROUTINE guide_out + + +!=========================================================================== + subroutine correctbid(iim,nl,x) + integer iim,nl + real x(iim+1,nl) + integer i,l + real zz + + do l=1,nl + do i=2,iim-1 + if(abs(x(i,l)).gt.1.e10) then + zz=0.5*(x(i-1,l)+x(i+1,l)) + print*,'correction ',i,l,x(i,l),zz + x(i,l)=zz + endif + enddo + enddo + return + end subroutine correctbid + +!=========================================================================== +END MODULE guide_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/heavyside.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/heavyside.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/heavyside.F (revision 1280) @@ -0,0 +1,23 @@ +! +! $Header$ +! +c +c + FUNCTION heavyside(a) + +c ... P. Le Van .... +c + IMPLICIT NONE + + REAL(KIND=8) heavyside , a + + IF ( a.LE.0. ) THEN + heavyside = 0. + ELSE + heavyside = 1. + ENDIF + + RETURN + END + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/infotrac.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/infotrac.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/infotrac.F90 (revision 1280) @@ -0,0 +1,335 @@ +! $Id$ +! +MODULE infotrac + +! nqtot : total number of tracers and higher order of moment, water vapor and liquid included + INTEGER, SAVE :: nqtot + +! nbtr : number of tracers not including higher order of moment or water vapor or liquid +! number of tracers used in the physics + INTEGER, SAVE :: nbtr + +! Name variables + CHARACTER(len=20), ALLOCATABLE, DIMENSION(:), SAVE :: tname ! tracer short name for restart and diagnostics + CHARACTER(len=23), ALLOCATABLE, DIMENSION(:), SAVE :: ttext ! tracer long name for diagnostics + +! iadv : index of trasport schema for each tracer + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: iadv + +! niadv : vector keeping the coorspondance between all tracers(nqtot) treated in the +! dynamic part of the code and the tracers (nbtr+2) used in the physics part of the code. + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: niadv ! equivalent dyn / physique + +! conv_flg(it)=0 : convection desactivated for tracer number it + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: conv_flg +! pbl_flg(it)=0 : boundary layer diffusion desactivaded for tracer number it + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: pbl_flg + + CHARACTER(len=4),SAVE :: type_trac + +CONTAINS + + SUBROUTINE infotrac_init + IMPLICIT NONE +!======================================================================= +! +! Auteur: P. Le Van /L. Fairhead/F.Hourdin +! ------- +! Modif special traceur F.Forget 05/94 +! Modif M-A Filiberti 02/02 lecture de traceur.def +! +! Objet: +! ------ +! GCM LMD nouvelle grille +! +!======================================================================= +! ... modification de l'integration de q ( 26/04/94 ) .... +!----------------------------------------------------------------------- +! Declarations + + INCLUDE "dimensions.h" + INCLUDE "control.h" + INCLUDE "iniprint.h" + +! Local variables + INTEGER, ALLOCATABLE, DIMENSION(:) :: hadv ! index of horizontal trasport schema + INTEGER, ALLOCATABLE, DIMENSION(:) :: vadv ! index of vertical trasport schema + + CHARACTER(len=15), ALLOCATABLE, DIMENSION(:) :: tnom_0 ! tracer short name + CHARACTER(len=8), ALLOCATABLE, DIMENSION(:) :: tracnam ! name from INCA + CHARACTER(len=3), DIMENSION(30) :: descrq + CHARACTER(len=1), DIMENSION(3) :: txts + CHARACTER(len=2), DIMENSION(9) :: txtp + CHARACTER(len=13) :: str1,str2 + + INTEGER :: nqtrue ! number of tracers read from tracer.def, without higer order of moment + INTEGER :: iq, new_iq, iiq, jq, ierr + INTEGER, EXTERNAL :: lnblnk + +!----------------------------------------------------------------------- +! Initialization : +! + txts=(/'x','y','z'/) + txtp=(/'x ','y ','z ','xx','xy','xz','yy','yz','zz'/) + + descrq(14)='VLH' + descrq(10)='VL1' + descrq(11)='VLP' + descrq(12)='FH1' + descrq(13)='FH2' + descrq(16)='PPM' + descrq(17)='PPS' + descrq(18)='PPP' + descrq(20)='SLP' + descrq(30)='PRA' + + + IF (config_inca=='none') THEN + type_trac='lmdz' + ELSE + type_trac='inca' + END IF + +!----------------------------------------------------------------------- +! +! 1) Get the true number of tracers + water vapor/liquid +! Here true tracers (nqtrue) means declared tracers (only first order) +! +!----------------------------------------------------------------------- + IF (type_trac == 'lmdz') THEN + OPEN(90,file='traceur.def',form='formatted',status='old', iostat=ierr) + IF(ierr.EQ.0) THEN + WRITE(lunout,*) 'Open traceur.def : ok' + READ(90,*) nqtrue + ELSE + WRITE(lunout,*) 'Problem in opening traceur.def' + WRITE(lunout,*) 'ATTENTION using defaut values' + nqtrue=4 ! Defaut value + END IF + ! Attention! Only for planet_type=='earth' + nbtr=nqtrue-2 + ELSE + ! nbtr has been read from INCA by init_cont_lmdz() in gcm.F + nqtrue=nbtr+2 + END IF + + IF (nqtrue < 2) THEN + WRITE(lunout,*) 'nqtrue=',nqtrue, ' is not allowded. 2 tracers is the minimum' + CALL abort_gcm('infotrac_init','Not enough tracers',1) + END IF +! +! Allocate variables depending on nqtrue and nbtr +! + ALLOCATE(tnom_0(nqtrue), hadv(nqtrue), vadv(nqtrue)) + ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), tracnam(nbtr)) + conv_flg(:) = 1 ! convection activated for all tracers + pbl_flg(:) = 1 ! boundary layer activated for all tracers + +!----------------------------------------------------------------------- +! 2) Choix des schemas d'advection pour l'eau et les traceurs +! +! iadv = 1 schema transport type "humidite specifique LMD" +! iadv = 2 schema amont +! iadv = 14 schema Van-leer + humidite specifique +! Modif F.Codron +! iadv = 10 schema Van-leer (retenu pour l'eau vapeur et liquide) +! iadv = 11 schema Van-Leer pour hadv et version PPM (Monotone) pour vadv +! iadv = 12 schema Frederic Hourdin I +! iadv = 13 schema Frederic Hourdin II +! iadv = 16 schema PPM Monotone(Collela & Woodward 1984) +! iadv = 17 schema PPM Semi Monotone (overshoots autorisés) +! iadv = 18 schema PPM Positif Defini (overshoots undershoots autorisés) +! iadv = 20 schema Slopes +! iadv = 30 schema Prather +! +! Dans le tableau q(ij,l,iq) : iq = 1 pour l'eau vapeur +! iq = 2 pour l'eau liquide +! Et eventuellement iq = 3,nqtot pour les autres traceurs +! +! iadv(1): choix pour l'eau vap. et iadv(2) : choix pour l'eau liq. +!------------------------------------------------------------------------ +! +! Get choice of advection schema from file tracer.def or from INCA +!--------------------------------------------------------------------- + IF (type_trac == 'lmdz') THEN + IF(ierr.EQ.0) THEN + ! Continue to read tracer.def + DO iq=1,nqtrue + READ(90,999) hadv(iq),vadv(iq),tnom_0(iq) + END DO + CLOSE(90) + ELSE ! Without tracer.def + hadv(1) = 14 + vadv(1) = 14 + tnom_0(1) = 'H2Ov' + hadv(2) = 10 + vadv(2) = 10 + tnom_0(2) = 'H2Ol' + hadv(3) = 10 + vadv(3) = 10 + tnom_0(3) = 'RN' + hadv(4) = 10 + vadv(4) = 10 + tnom_0(4) = 'PB' + END IF + + WRITE(lunout,*) 'Valeur de traceur.def :' + WRITE(lunout,*) 'nombre de traceurs ',nqtrue + DO iq=1,nqtrue + WRITE(lunout,*) hadv(iq),vadv(iq),tnom_0(iq) + END DO + + ELSE ! type_trac=inca : config_inca='aero' ou 'chem' +! le module de chimie fournit les noms des traceurs +! et les schemas d'advection associes. + +#ifdef INCA + CALL init_transport( & + hadv, & + vadv, & + conv_flg, & + pbl_flg, & + tracnam) +#endif + tnom_0(1)='H2Ov' + tnom_0(2)='H2Ol' + + DO iq =3,nqtrue + tnom_0(iq)=tracnam(iq-2) + END DO + + END IF ! type_trac + +!----------------------------------------------------------------------- +! +! 3) Verify if advection schema 20 or 30 choosen +! Calculate total number of tracers needed: nqtot +! Allocate variables depending on total number of tracers +!----------------------------------------------------------------------- + new_iq=0 + DO iq=1,nqtrue + ! Add tracers for certain advection schema + IF (hadv(iq)<20 .AND. vadv(iq)<20 ) THEN + new_iq=new_iq+1 ! no tracers added + ELSE IF (hadv(iq)==20 .AND. vadv(iq)==20 ) THEN + new_iq=new_iq+4 ! 3 tracers added + ELSE IF (hadv(iq)==30 .AND. vadv(iq)==30 ) THEN + new_iq=new_iq+10 ! 9 tracers added + ELSE + WRITE(lunout,*) 'This choice of advection schema is not available' + CALL abort_gcm('infotrac_init','Bad choice of advection schema - 1',1) + END IF + END DO + + IF (new_iq /= nqtrue) THEN + ! The choice of advection schema imposes more tracers + ! Assigne total number of tracers + nqtot = new_iq + + WRITE(lunout,*) 'The choice of advection schema for one or more tracers' + WRITE(lunout,*) 'makes it necessary to add tracers' + WRITE(lunout,*) nqtrue,' is the number of true tracers' + WRITE(lunout,*) nqtot, ' is the total number of tracers needed' + + ELSE + ! The true number of tracers is also the total number + nqtot = nqtrue + END IF + +! +! Allocate variables with total number of tracers, nqtot +! + ALLOCATE(tname(nqtot), ttext(nqtot)) + ALLOCATE(iadv(nqtot), niadv(nqtot)) + +!----------------------------------------------------------------------- +! +! 4) Determine iadv, long and short name +! +!----------------------------------------------------------------------- + new_iq=0 + DO iq=1,nqtrue + new_iq=new_iq+1 + + ! Verify choice of advection schema + IF (hadv(iq)==vadv(iq)) THEN + iadv(new_iq)=hadv(iq) + ELSE IF (hadv(iq)==10 .AND. vadv(iq)==16) THEN + iadv(new_iq)=11 + ELSE + WRITE(lunout,*)'This choice of advection schema is not available' + CALL abort_gcm('infotrac_init','Bad choice of advection schema - 2',1) + END IF + + str1=tnom_0(iq) + tname(new_iq)= tnom_0(iq) + IF (iadv(new_iq)==0) THEN + ttext(new_iq)=str1(1:lnblnk(str1)) + ELSE + ttext(new_iq)=str1(1:lnblnk(str1))//descrq(iadv(new_iq)) + END IF + + ! schemas tenant compte des moments d'ordre superieur + str2=ttext(new_iq) + IF (iadv(new_iq)==20) THEN + DO jq=1,3 + new_iq=new_iq+1 + iadv(new_iq)=-20 + ttext(new_iq)=str2(1:lnblnk(str2))//txts(jq) + tname(new_iq)=str1(1:lnblnk(str1))//txts(jq) + END DO + ELSE IF (iadv(new_iq)==30) THEN + DO jq=1,9 + new_iq=new_iq+1 + iadv(new_iq)=-30 + ttext(new_iq)=str2(1:lnblnk(str2))//txtp(jq) + tname(new_iq)=str1(1:lnblnk(str1))//txtp(jq) + END DO + END IF + END DO + +! +! Find vector keeping the correspodence between true and total tracers +! + niadv(:)=0 + iiq=0 + DO iq=1,nqtot + IF(iadv(iq).GE.0) THEN + ! True tracer + iiq=iiq+1 + niadv(iiq)=iq + ENDIF + END DO + + + WRITE(lunout,*) 'Information stored in infotrac :' + WRITE(lunout,*) 'iadv niadv tname ttext :' + DO iq=1,nqtot + WRITE(lunout,*) iadv(iq),niadv(iq), tname(iq), ttext(iq) + END DO + +! +! Test for advection schema. +! This version of LMDZ only garantees iadv=10 and iadv=14 (14 only for water vapour) . +! + DO iq=1,nqtot + IF (iadv(iq)/=10 .AND. iadv(iq)/=14 .AND. iadv(iq)/=0) THEN + WRITE(lunout,*)'STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ' + CALL abort_gcm('infotrac_init','In this version only iadv=10 and iadv=14 is tested!',1) + ELSE IF (iadv(iq)==14 .AND. iq/=1) THEN + WRITE(lunout,*)'STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ' + CALL abort_gcm('infotrac_init','In this version iadv=14 is only permitted for water vapour!',1) + END IF + END DO + +!----------------------------------------------------------------------- +! Finalize : +! + DEALLOCATE(tnom_0, hadv, vadv) + DEALLOCATE(tracnam) + +999 FORMAT (i2,1x,i2,1x,a15) + + END SUBROUTINE infotrac_init + +END MODULE infotrac Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ini_paramLMDZ_dyn.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ini_paramLMDZ_dyn.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ini_paramLMDZ_dyn.h (revision 1280) @@ -0,0 +1,214 @@ +c + dt_cum = dtvr*day_step + +! zan = annee_ref +! dayref = day_ref +! CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn +c + pi = 4.0 * ATAN(1.0) + degres = 180./pi + rlong = rlonu * degres + rlatg = rlatu * degres +c + CALL histbeg("paramLMDZ_dyn.nc", + . iip1,rlong, jjp1,rlatg, + . 1,1,1,1, + . tau0, jD_ref+jH_ref , dt_cum, + . thoriid, nid_ctesGCM) +c + CALL histdef(nid_ctesGCM, "prt_level", + . "Niveau impression debuggage dynamique", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "dayref", + . "Jour de l etat initial ( = 350 si 20 Decembre par ex.)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "anneeref", + . "Annee de l etat initial", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "anneelim", + . "Annee du fichier limitxxxx.nc si ok_limitvrai =y", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "raz_date", + . "Remise a zero (raz) date init.: 0 pas de raz;1=date gcm.def", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "nday", + . "Nombre de jours d integration", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "day_step", + . "nombre de pas par jour pour dt = 1 min", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "iperiod", + . "periode pour le pas Matsuno (en pas de temps)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "iapp_tracvl", + . "frequence du groupement des flux (en pas de temps)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "iconser", + . "periode de sortie des variables de controle (en pas de temps)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "iecri", + . "periode d ecriture du fichier histoire (en jour)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "periodav", + . "periode de stockage fichier histmoy (en jour)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "idissip", + . "periode de la dissipation (en pas) ... a completer", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "lstardis", + . "choix de l operateur de dissipation: 1= star,0=non-star ??", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "nitergdiv", + . "nombre d iterations de l operateur de dissipation gradiv", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "nitergrot", + . "nombre d iterations de l operateur de dissipation nxgradrot", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "niterh", + . "nombre d iterations de l operateur de dissipation divgrad", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "tetagdiv", + ."temps dissipation des + petites long. d ondes pour u,v (gradiv)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "tetagrot", + ."temps diss. des + petites long. d ondes pour u,v (nxgradrot)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "tetatemp", + ."temps diss. des + petites long. d ondes pour h (divgrad)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "coefdis", + ."coefficient pour gamdissip", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "purmats", + ."Choix schema integration temporel: 1=Matsuno,0=Matsuno-leapfrog", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "ok_guide", + ."Guidage: 1=true ,0=false", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "true_calendar", + ."Choix du calendrier", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "guide_calend", + ."Guidage calendrier gregorien: 1=oui ,0=non", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "iflag_phys", + ."Permet de faire tourner le modele sans physique: 1=avec ,0=sans", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "iphysiq", + ."Periode de la physique en pas de temps de la dynamique", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "clon", + ."longitude en degres du centre du zoom", + . "deg",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "clat", + ."latitude en degres du centre du zoom", + . "deg",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "grossismx", + ."facteur de grossissement du zoom, selon la longitude", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "grossismy", + ."facteur de grossissement du zoom, selon la latitude", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "fxyhypb", + ."Fonction f(y) hyperbolique si true=1, sinusoidale si false=0", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "dzoomx", + ."extension en longitude de la zone du zoom (fraction zone totale)" + . ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "dzoomy", + ."extension en latitude de la zone du zoom (fraction zone totale)" + . ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "taux", + ."raideur du zoom en X" + . ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "tauy", + ."raideur du zoom en Y" + . ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "ysinus", + ."ysinus=1: Ftion f(y) avec y=Sin(latit.)/ ysinus=0: y = latit" + . ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "ip_ebil_dyn", + ."PRINTlevel for energy conservation diag.; 0/1= pas de print, + . 2= print","-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c +c================================================================= +c + CALL histend(nid_ctesGCM) +c +c================================================================= Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/iniacademic.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/iniacademic.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/iniacademic.F (revision 1280) @@ -0,0 +1,201 @@ +! +! $Header$ +! +c +c + SUBROUTINE iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0) + + USE filtreg_mod + USE infotrac, ONLY : nqtot + +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 15/01/93 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +#include "academic.h" +#include "ener.h" +#include "temps.h" +#include "control.h" +#include "iniprint.h" + +c Arguments: +c ---------- + + real time_0 + +c variables dynamiques + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL q(ip1jmp1,llm,nqtot) ! champs advectes + REAL ps(ip1jmp1) ! pression au sol + REAL masse(ip1jmp1,llm) ! masse d'air + REAL phis(ip1jmp1) ! geopotentiel au sol + +c Local: +c ------ + + REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL pks(ip1jmp1) ! exner au sol + REAL pk(ip1jmp1,llm) ! exner au milieu des couches + REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches + REAL phi(ip1jmp1,llm) ! geopotentiel + REAL ddsin,tetarappelj,tetarappell,zsig + real tetajl(jjp1,llm) + INTEGER i,j,l,lsup,ij + + real zz,ran1 + integer idum + + REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm),zdtvr + +c----------------------------------------------------------------------- +! 1. Initializations for Earth-like case +! -------------------------------------- + if (planet_type=="earth") then +c + time_0=0. + day_ref=0 + annee_ref=0 + + im = iim + jm = jjm + day_ini = 0 + omeg = 4.*asin(1.)/86400. + rad = 6371229. + g = 9.8 + daysec = 86400. + dtvr = daysec/FLOAT(day_step) + zdtvr=dtvr + kappa = 0.2857143 + cpp = 1004.70885 + preff = 101325. + pa = 50000. + etot0 = 0. + ptot0 = 0. + ztot0 = 0. + stot0 = 0. + ang0 = 0. + + CALL iniconst + CALL inigeom + CALL inifilr + + ps=0. + phis=0. +c--------------------------------------------------------------------- + + taurappel=10.*daysec + +c--------------------------------------------------------------------- +c Calcul de la temperature potentielle : +c -------------------------------------- + + DO l=1,llm + zsig=ap(l)/preff+bp(l) + if (zsig.gt.0.3) then + lsup=l + tetarappell=1./8.*(-log(zsig)-.5) + DO j=1,jjp1 + ddsin=sin(rlatu(j))-sin(pi/20.) + tetajl(j,l)=300.*(1+1./18.*(1.-3.*ddsin*ddsin)+tetarappell) + ENDDO + else +c Choix isotherme au-dessus de 300 mbar + do j=1,jjp1 + tetajl(j,l)=tetajl(j,lsup)*(0.3/zsig)**kappa + enddo + endif ! of if (zsig.gt.0.3) + ENDDO ! of DO l=1,llm + + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + ij=(j-1)*iip1+i + tetarappel(ij,l)=tetajl(j,l) + enddo + enddo + enddo + +c call dump2d(jjp1,llm,tetajl,'TEQ ') + + ps=1.e5 + phis=0. + CALL pression ( ip1jmp1, ap, bp, ps, p ) + CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf ) + CALL massdair(p,masse) + +c intialisation du vent et de la temperature + teta(:,:)=tetarappel(:,:) + CALL geopot(ip1jmp1,teta,pk,pks,phis,phi) + call ugeostr(phi,ucov) + vcov=0. + q(:,:,1 )=1.e-10 + q(:,:,2 )=1.e-15 + q(:,:,3:nqtot)=0. + + +c perturbation aleatoire sur la temperature + idum = -1 + zz = ran1(idum) + idum = 0 + do l=1,llm + do ij=iip2,ip1jm + teta(ij,l)=teta(ij,l)*(1.+0.005*ran1(idum)) + enddo + enddo + + do l=1,llm + do ij=1,ip1jmp1,iip1 + teta(ij+iim,l)=teta(ij,l) + enddo + enddo + + + +c PRINT *,' Appel test_period avec tetarappel ' +c CALL test_period ( ucov,vcov,tetarappel,q,p,phis ) +c PRINT *,' Appel test_period avec teta ' +c CALL test_period ( ucov,vcov,teta,q,p,phis ) + +c initialisation d'un traceur sur une colonne + j=jjp1*3/4 + i=iip1/2 + ij=(j-1)*iip1+i + q(ij,:,3)=1. + + else + write(lunout,*)"iniacademic: planet types other than earth", + & " not implemented (yet)." + stop + endif ! of if (planet_type=="earth") + return + END +c----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/iniconst.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/iniconst.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/iniconst.F (revision 1280) @@ -0,0 +1,57 @@ +! +! $Header$ +! + SUBROUTINE iniconst + + IMPLICIT NONE +c +c P. Le Van +c +c----------------------------------------------------------------------- +c Declarations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "temps.h" +#include "control.h" +#include "comvert.h" + + +c +c +c +c----------------------------------------------------------------------- +c dimension des boucles: +c ---------------------- + + im = iim + jm = jjm + lllm = llm + imp1 = iim + jmp1 = jjm + 1 + lllmm1 = llm - 1 + lllmp1 = llm + 1 + +c----------------------------------------------------------------------- + + dtdiss = idissip * dtvr + dtphys = iphysiq * dtvr + unsim = 1./iim + pi = 2.*ASIN( 1. ) + +c----------------------------------------------------------------------- +c + + r = cpp * kappa + + PRINT*,' R CP Kappa ', r , cpp, kappa +c +c----------------------------------------------------------------------- + + CALL disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig) +c +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inidissip.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inidissip.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inidissip.F (revision 1280) @@ -0,0 +1,225 @@ +! +! $Id$ +! + SUBROUTINE inidissip ( lstardis,nitergdiv,nitergrot,niterh , + * tetagdiv,tetagrot,tetatemp ) +c======================================================================= +c initialisation de la dissipation horizontale +c======================================================================= +c----------------------------------------------------------------------- +c declarations: +c ------------- + + IMPLICIT NONE +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "comconst.h" +#include "comvert.h" +#include "control.h" +#include "logic.h" + + LOGICAL lstardis + INTEGER nitergdiv,nitergrot,niterh + REAL tetagdiv,tetagrot,tetatemp + REAL fact,zvert(llm),zz + REAL zh(ip1jmp1),zu(ip1jmp1),zv(ip1jm),deltap(ip1jmp1,llm) + REAL ullm,vllm,umin,vmin,zhmin,zhmax + REAL zllm,z1llm + + INTEGER l,ij,idum,ii + REAL tetamin + REAL pseudoz + + REAL ran1 + + +c----------------------------------------------------------------------- +c +c calcul des valeurs propres des operateurs par methode iterrative: +c ----------------------------------------------------------------- + + crot = -1. + cdivu = -1. + cdivh = -1. + +c calcul de la valeur propre de divgrad: +c -------------------------------------- + idum = 0 + DO l = 1, llm + DO ij = 1, ip1jmp1 + deltap(ij,l) = 1. + ENDDO + ENDDO + + idum = -1 + zh(1) = RAN1(idum)-.5 + idum = 0 + DO ij = 2, ip1jmp1 + zh(ij) = RAN1(idum) -.5 + ENDDO + + CALL filtreg (zh,jjp1,1,2,1,.TRUE.,1) + + CALL minmax(iip1*jjp1,zh,zhmin,zhmax ) + + IF ( zhmin .GE. zhmax ) THEN + PRINT*,' Inidissip zh min max ',zhmin,zhmax + STOP'probleme generateur alleatoire dans inidissip' + ENDIF + + zllm = ABS( zhmax ) + DO l = 1,50 + IF(lstardis) THEN + CALL divgrad2(1,zh,deltap,niterh,zh) + ELSE + CALL divgrad (1,zh,niterh,zh) + ENDIF + + CALL minmax(iip1*jjp1,zh,zhmin,zhmax ) + + zllm = ABS( zhmax ) + z1llm = 1./zllm + DO ij = 1,ip1jmp1 + zh(ij) = zh(ij)* z1llm + ENDDO + ENDDO + + IF(lstardis) THEN + cdivh = 1./ zllm + ELSE + cdivh = zllm ** ( -1./niterh ) + ENDIF + +c calcul des valeurs propres de gradiv (ii =1) et nxgrarot(ii=2) +c ----------------------------------------------------------------- + print*,'calcul des valeurs propres' + + DO 20 ii = 1, 2 +c + DO ij = 1, ip1jmp1 + zu(ij) = RAN1(idum) -.5 + ENDDO + CALL filtreg (zu,jjp1,1,2,1,.TRUE.,1) + DO ij = 1, ip1jm + zv(ij) = RAN1(idum) -.5 + ENDDO + CALL filtreg (zv,jjm,1,2,1,.FALSE.,1) + + CALL minmax(iip1*jjp1,zu,umin,ullm ) + CALL minmax(iip1*jjm, zv,vmin,vllm ) + + ullm = ABS ( ullm ) + vllm = ABS ( vllm ) + + DO 5 l = 1, 50 + IF(ii.EQ.1) THEN +ccccc CALL covcont( 1,zu,zv,zu,zv ) + IF(lstardis) THEN + CALL gradiv2( 1,zu,zv,nitergdiv,zu,zv ) + ELSE + CALL gradiv ( 1,zu,zv,nitergdiv,zu,zv ) + ENDIF + ELSE + IF(lstardis) THEN + CALL nxgraro2( 1,zu,zv,nitergrot,zu,zv ) + ELSE + CALL nxgrarot( 1,zu,zv,nitergrot,zu,zv ) + ENDIF + ENDIF + + CALL minmax(iip1*jjp1,zu,umin,ullm ) + CALL minmax(iip1*jjm, zv,vmin,vllm ) + + ullm = ABS ( ullm ) + vllm = ABS ( vllm ) + + zllm = MAX( ullm,vllm ) + z1llm = 1./ zllm + DO ij = 1, ip1jmp1 + zu(ij) = zu(ij)* z1llm + ENDDO + DO ij = 1, ip1jm + zv(ij) = zv(ij)* z1llm + ENDDO + 5 CONTINUE + + IF ( ii.EQ.1 ) THEN + IF(lstardis) THEN + cdivu = 1./zllm + ELSE + cdivu = zllm **( -1./nitergdiv ) + ENDIF + ELSE + IF(lstardis) THEN + crot = 1./ zllm + ELSE + crot = zllm **( -1./nitergrot ) + ENDIF + ENDIF + + 20 CONTINUE + +c petit test pour les operateurs non star: +c ---------------------------------------- + +c IF(.NOT.lstardis) THEN + fact = rad*24./float(jjm) + fact = fact*fact + PRINT*,'coef u ', fact/cdivu, 1./cdivu + PRINT*,'coef r ', fact/crot , 1./crot + PRINT*,'coef h ', fact/cdivh, 1./cdivh +c ENDIF + +c----------------------------------------------------------------------- +c variation verticale du coefficient de dissipation: +c -------------------------------------------------- + + if (ok_strato .and. llm==39) then + do l=1,llm + pseudoz=8.*log(preff/presnivs(l)) + zvert(l)=1+ + s (tanh((pseudoz-dissip_zref)/dissip_deltaz)+1.)/2. + s *(dissip_factz-1.) + enddo + else + DO l=1,llm + zvert(l)=1. + ENDDO + fact=2. + DO l = 1, llm + zz = 1. - preff/presnivs(l) + zvert(l)= fact -( fact-1.)/( 1.+zz*zz ) + ENDDO + endif + + + PRINT*,'Constantes de temps de la diffusion horizontale' + + tetamin = 1.e+6 + + DO l=1,llm + tetaudiv(l) = zvert(l)/tetagdiv + tetaurot(l) = zvert(l)/tetagrot + tetah(l) = zvert(l)/tetatemp + + IF( tetamin.GT. (1./tetaudiv(l)) ) tetamin = 1./ tetaudiv(l) + IF( tetamin.GT. (1./tetaurot(l)) ) tetamin = 1./ tetaurot(l) + IF( tetamin.GT. (1./ tetah(l)) ) tetamin = 1./ tetah(l) + ENDDO + + PRINT *,' INIDI tetamin dtvr ',tetamin,dtvr,iperiod + idissip = INT( tetamin/( 2.*dtvr*iperiod) ) * iperiod + PRINT *,' INIDI tetamin idissip ',tetamin,idissip + idissip = MAX(iperiod,idissip) + dtdiss = idissip * dtvr + PRINT *,' INIDI idissip dtdiss ',idissip,dtdiss + + DO l = 1,llm + PRINT*,zvert(l),dtdiss*tetaudiv(l),dtdiss*tetaurot(l), + * dtdiss*tetah(l) + ENDDO + +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inigeom.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inigeom.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inigeom.F (revision 1280) @@ -0,0 +1,699 @@ +! +! $Header$ +! +c +c + SUBROUTINE inigeom +c +c Auteur : P. Le Van +c +c ............ Version du 01/04/2001 ........................ +c +c Calcul des elongations cuij1,.cuij4 , cvij1,..cvij4 aux memes en- +c endroits que les aires aireij1,..aireij4 . + +c Choix entre f(y) a derivee sinusoid. ou a derivee tangente hyperbol. +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" +#include "serre.h" +#include "logic.h" +#include "comdissnew.h" + +c----------------------------------------------------------------------- +c .... Variables locales .... +c + INTEGER i,j,itmax,itmay,iter + REAL cvu(iip1,jjp1),cuv(iip1,jjm) + REAL ai14,ai23,airez,rlatp,rlatm,xprm,xprp,un4rad2,yprp,yprm + REAL eps,x1,xo1,f,df,xdm,y1,yo1,ydm + REAL coslatm,coslatp,radclatm,radclatp + REAL cuij1(iip1,jjp1),cuij2(iip1,jjp1),cuij3(iip1,jjp1), + * cuij4(iip1,jjp1) + REAL cvij1(iip1,jjp1),cvij2(iip1,jjp1),cvij3(iip1,jjp1), + * cvij4(iip1,jjp1) + REAL rlonvv(iip1),rlatuu(jjp1) + REAL rlatu1(jjm),yprimu1(jjm),rlatu2(jjm),yprimu2(jjm) , + * yprimv(jjm),yprimu(jjp1) + REAL gamdi_gdiv, gamdi_grot, gamdi_h + + REAL rlonm025(iip1),xprimm025(iip1), rlonp025(iip1), + , xprimp025(iip1) + SAVE rlatu1,yprimu1,rlatu2,yprimu2,yprimv,yprimu + SAVE rlonm025,xprimm025,rlonp025,xprimp025 + + REAL SSUM +c +c +c ------------------------------------------------------------------ +c - - +c - calcul des coeff. ( cu, cv , 1./cu**2, 1./cv**2 ) - +c - - +c ------------------------------------------------------------------ +c +c les coef. ( cu, cv ) permettent de passer des vitesses naturelles +c aux vitesses covariantes et contravariantes , ou vice-versa ... +c +c +c on a : u (covariant) = cu * u (naturel) , u(contrav)= u(nat)/cu +c v (covariant) = cv * v (naturel) , v(contrav)= v(nat)/cv +c +c on en tire : u(covariant) = cu * cu * u(contravariant) +c v(covariant) = cv * cv * v(contravariant) +c +c +c on a l'application ( x(X) , y(Y) ) avec - im/2 +1 < X < im/2 +c = = +c et - jm/2 < Y < jm/2 +c = = +c +c ................................................... +c ................................................... +c . x est la longitude du point en radians . +c . y est la latitude du point en radians . +c . . +c . on a : cu(i,j) = rad * COS(y) * dx/dX . +c . cv( j ) = rad * dy/dY . +c . aire(i,j) = cu(i,j) * cv(j) . +c . . +c . y, dx/dX, dy/dY calcules aux points concernes . +c . . +c ................................................... +c ................................................... +c +c +c +c , +c cv , bien que dependant de j uniquement,sera ici indice aussi en i +c pour un adressage plus facile en ij . +c +c +c +c ************** aux points u et v , ***************** +c xprimu et xprimv sont respectivement les valeurs de dx/dX +c yprimu et yprimv . . . . . . . . . . . dy/dY +c rlatu et rlatv . . . . . . . . . . .la latitude +c cvu et cv . . . . . . . . . . . cv +c +c ************** aux points u, v, scalaires, et z **************** +c cu, cuv, cuscal, cuz sont respectiv. les valeurs de cu +c +c +c +c Exemple de distribution de variables sur la grille dans le +c domaine de travail ( X,Y ) . +c ................................................................ +c DX=DY= 1 +c +c +c + represente un point scalaire ( p.exp la pression ) +c > represente la composante zonale du vent +c V represente la composante meridienne du vent +c o represente la vorticite +c +c ---- , car aux poles , les comp.zonales covariantes sont nulles +c +c +c +c i -> +c +c 1 2 3 4 5 6 7 8 +c j +c v 1 + ---- + ---- + ---- + ---- + ---- + ---- + ---- + -- +c +c V o V o V o V o V o V o V o V o +c +c 2 + > + > + > + > + > + > + > + > +c +c V o V o V o V o V o V o V o V o +c +c 3 + > + > + > + > + > + > + > + > +c +c V o V o V o V o V o V o V o V o +c +c 4 + > + > + > + > + > + > + > + > +c +c V o V o V o V o V o V o V o V o +c +c 5 + ---- + ---- + ---- + ---- + ---- + ---- + ---- + -- +c +c +c Ci-dessus, on voit que le nombre de pts.en longitude est egal +c a IM = 8 +c De meme , le nombre d'intervalles entre les 2 poles est egal +c a JM = 4 +c +c Les points scalaires ( + ) correspondent donc a des valeurs +c entieres de i ( 1 a IM ) et de j ( 1 a JM +1 ) . +c +c Les vents U ( > ) correspondent a des valeurs semi- +c entieres de i ( 1+ 0.5 a IM+ 0.5) et entieres de j ( 1 a JM+1) +c +c Les vents V ( V ) correspondent a des valeurs entieres +c de i ( 1 a IM ) et semi-entieres de j ( 1 +0.5 a JM +0.5) +c +c +c + WRITE(6,3) + 3 FORMAT( // 10x,' .... INIGEOM date du 01/06/98 ..... ', + * //5x,' Calcul des elongations cu et cv comme sommes des 4 ' / + * 5x,' elong. cuij1, .. 4 , cvij1,.. 4 qui les entourent , aux + * '/ 5x,' memes endroits que les aires aireij1,...j4 . ' / ) +c +c + IF( nitergdiv.NE.2 ) THEN + gamdi_gdiv = coefdis/ ( float(nitergdiv) -2. ) + ELSE + gamdi_gdiv = 0. + ENDIF + IF( nitergrot.NE.2 ) THEN + gamdi_grot = coefdis/ ( float(nitergrot) -2. ) + ELSE + gamdi_grot = 0. + ENDIF + IF( niterh.NE.2 ) THEN + gamdi_h = coefdis/ ( float(niterh) -2. ) + ELSE + gamdi_h = 0. + ENDIF + + WRITE(6,*) ' gamdi_gd ',gamdi_gdiv,gamdi_grot,gamdi_h,coefdis, + * nitergdiv,nitergrot,niterh +c + pi = 2.* ASIN(1.) +c + WRITE(6,990) + +c ---------------------------------------------------------------- +c + IF( .NOT.fxyhypb ) THEN +c +c + IF( ysinus ) THEN +c + WRITE(6,*) ' *** Inigeom , Y = Sinus ( Latitude ) *** ' +c +c .... utilisation de f(x,y ) avec y = sinus de la latitude ..... + + CALL fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + ELSE +c + WRITE(6,*) '*** Inigeom , Y = Latitude , der. sinusoid . ***' + +c .... utilisation de f(x,y) a tangente sinusoidale , y etant la latit. ... +c + + pxo = clon *pi /180. + pyo = 2.* clat* pi /180. +c +c .... determination de transx ( pour le zoom ) par Newton-Raphson ... +c + itmax = 10 + eps = .1e-7 +c + xo1 = 0. + DO 10 iter = 1, itmax + x1 = xo1 + f = x1+ alphax *SIN(x1-pxo) + df = 1.+ alphax *COS(x1-pxo) + x1 = x1 - f/df + xdm = ABS( x1- xo1 ) + IF( xdm.LE.eps )GO TO 11 + xo1 = x1 + 10 CONTINUE + 11 CONTINUE +c + transx = xo1 + + itmay = 10 + eps = .1e-7 +C + yo1 = 0. + DO 15 iter = 1,itmay + y1 = yo1 + f = y1 + alphay* SIN(y1-pyo) + df = 1. + alphay* COS(y1-pyo) + y1 = y1 -f/df + ydm = ABS(y1-yo1) + IF(ydm.LE.eps) GO TO 17 + yo1 = y1 + 15 CONTINUE +c + 17 CONTINUE + transy = yo1 + + CALL fxy ( rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + ENDIF +c + ELSE +c +c .... Utilisation de fxyhyper , f(x,y) a derivee tangente hyperbol. +c ..................................................................... + + WRITE(6,*)'*** Inigeom , Y = Latitude , der.tg. hyperbolique ***' + + CALL fxyhyper( clat, grossismy, dzoomy, tauy , + , clon, grossismx, dzoomx, taux , + , rlatu,yprimu,rlatv, yprimv,rlatu1, yprimu1,rlatu2,yprimu2 , + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025 ) + + + ENDIF +c +c ------------------------------------------------------------------- + +c + rlatu(1) = ASIN(1.) + rlatu(jjp1) = - rlatu(1) +c +c +c .... calcul aux poles .... +c + yprimu(1) = 0. + yprimu(jjp1) = 0. +c +c + un4rad2 = 0.25 * rad * rad +c +c -------------------------------------------------------------------- +c -------------------------------------------------------------------- +c - - +c - calcul des aires ( aire,aireu,airev, 1./aire, 1./airez ) - +c - et de fext , force de coriolis extensive . - +c - - +c -------------------------------------------------------------------- +c -------------------------------------------------------------------- +c +c +c +c A 1 point scalaire P (i,j) de la grille, reguliere en (X,Y) , sont +c affectees 4 aires entourant P , calculees respectivement aux points +c ( i + 1/4, j - 1/4 ) : aireij1 (i,j) +c ( i + 1/4, j + 1/4 ) : aireij2 (i,j) +c ( i - 1/4, j + 1/4 ) : aireij3 (i,j) +c ( i - 1/4, j - 1/4 ) : aireij4 (i,j) +c +c , +c Les cotes de chacun de ces 4 carres etant egaux a 1/2 suivant (X,Y). +c Chaque aire centree en 1 point scalaire P(i,j) est egale a la somme +c des 4 aires aireij1,aireij2,aireij3,aireij4 qui sont affectees au +c point (i,j) . +c On definit en outre les coefficients alpha comme etant egaux a +c (aireij / aire), c.a.d par exp. alpha1(i,j)=aireij1(i,j)/aire(i,j) +c +c De meme, toute aire centree en 1 point U est egale a la somme des +c 4 aires aireij1,aireij2,aireij3,aireij4 entourant le point U . +c Idem pour airev, airez . +c +c On a ,pour chaque maille : dX = dY = 1 +c +c +c . V +c +c aireij4 . . aireij1 +c +c U . . P . U +c +c aireij3 . . aireij2 +c +c . V +c +c +c +c +c +c .................................................................... +c +c Calcul des 4 aires elementaires aireij1,aireij2,aireij3,aireij4 +c qui entourent chaque aire(i,j) , ainsi que les 4 elongations elemen +c taires cuij et les 4 elongat. cvij qui sont calculees aux memes +c endroits que les aireij . +c +c .................................................................... +c +c ....... do 35 : boucle sur les jjm + 1 latitudes ..... +c +c + DO 35 j = 1, jjp1 +c + IF ( j. eq. 1 ) THEN +c + yprm = yprimu1(j) + rlatm = rlatu1(j) +c + coslatm = COS( rlatm ) + radclatm = 0.5* rad * coslatm +c + DO 30 i = 1, iim + xprp = xprimp025( i ) + xprm = xprimm025( i ) + aireij2( i,1 ) = un4rad2 * coslatm * xprp * yprm + aireij3( i,1 ) = un4rad2 * coslatm * xprm * yprm + cuij2 ( i,1 ) = radclatm * xprp + cuij3 ( i,1 ) = radclatm * xprm + cvij2 ( i,1 ) = 0.5* rad * yprm + cvij3 ( i,1 ) = cvij2(i,1) + 30 CONTINUE +c + DO i = 1, iim + aireij1( i,1 ) = 0. + aireij4( i,1 ) = 0. + cuij1 ( i,1 ) = 0. + cuij4 ( i,1 ) = 0. + cvij1 ( i,1 ) = 0. + cvij4 ( i,1 ) = 0. + ENDDO +c + END IF +c + IF ( j. eq. jjp1 ) THEN + yprp = yprimu2(j-1) + rlatp = rlatu2 (j-1) +ccc yprp = fyprim( FLOAT(j) - 0.25 ) +ccc rlatp = fy ( FLOAT(j) - 0.25 ) +c + coslatp = COS( rlatp ) + radclatp = 0.5* rad * coslatp +c + DO 31 i = 1,iim + xprp = xprimp025( i ) + xprm = xprimm025( i ) + aireij1( i,jjp1 ) = un4rad2 * coslatp * xprp * yprp + aireij4( i,jjp1 ) = un4rad2 * coslatp * xprm * yprp + cuij1(i,jjp1) = radclatp * xprp + cuij4(i,jjp1) = radclatp * xprm + cvij1(i,jjp1) = 0.5 * rad* yprp + cvij4(i,jjp1) = cvij1(i,jjp1) + 31 CONTINUE +c + DO i = 1, iim + aireij2( i,jjp1 ) = 0. + aireij3( i,jjp1 ) = 0. + cvij2 ( i,jjp1 ) = 0. + cvij3 ( i,jjp1 ) = 0. + cuij2 ( i,jjp1 ) = 0. + cuij3 ( i,jjp1 ) = 0. + ENDDO +c + END IF +c + + IF ( j .gt. 1 .AND. j .lt. jjp1 ) THEN +c + rlatp = rlatu2 ( j-1 ) + yprp = yprimu2( j-1 ) + rlatm = rlatu1 ( j ) + yprm = yprimu1( j ) +cc rlatp = fy ( FLOAT(j) - 0.25 ) +cc yprp = fyprim( FLOAT(j) - 0.25 ) +cc rlatm = fy ( FLOAT(j) + 0.25 ) +cc yprm = fyprim( FLOAT(j) + 0.25 ) + + coslatm = COS( rlatm ) + coslatp = COS( rlatp ) + radclatp = 0.5* rad * coslatp + radclatm = 0.5* rad * coslatm +c + DO 32 i = 1,iim + xprp = xprimp025( i ) + xprm = xprimm025( i ) + + ai14 = un4rad2 * coslatp * yprp + ai23 = un4rad2 * coslatm * yprm + aireij1 ( i,j ) = ai14 * xprp + aireij2 ( i,j ) = ai23 * xprp + aireij3 ( i,j ) = ai23 * xprm + aireij4 ( i,j ) = ai14 * xprm + cuij1 ( i,j ) = radclatp * xprp + cuij2 ( i,j ) = radclatm * xprp + cuij3 ( i,j ) = radclatm * xprm + cuij4 ( i,j ) = radclatp * xprm + cvij1 ( i,j ) = 0.5* rad * yprp + cvij2 ( i,j ) = 0.5* rad * yprm + cvij3 ( i,j ) = cvij2(i,j) + cvij4 ( i,j ) = cvij1(i,j) + 32 CONTINUE +c + END IF +c +c ........ periodicite ............ +c + cvij1 (iip1,j) = cvij1 (1,j) + cvij2 (iip1,j) = cvij2 (1,j) + cvij3 (iip1,j) = cvij3 (1,j) + cvij4 (iip1,j) = cvij4 (1,j) + cuij1 (iip1,j) = cuij1 (1,j) + cuij2 (iip1,j) = cuij2 (1,j) + cuij3 (iip1,j) = cuij3 (1,j) + cuij4 (iip1,j) = cuij4 (1,j) + aireij1 (iip1,j) = aireij1 (1,j ) + aireij2 (iip1,j) = aireij2 (1,j ) + aireij3 (iip1,j) = aireij3 (1,j ) + aireij4 (iip1,j) = aireij4 (1,j ) + + 35 CONTINUE +c +c .............................................................. +c + DO 37 j = 1, jjp1 + DO 36 i = 1, iim + aire ( i,j ) = aireij1(i,j) + aireij2(i,j) + aireij3(i,j) + + * aireij4(i,j) + alpha1 ( i,j ) = aireij1(i,j) / aire(i,j) + alpha2 ( i,j ) = aireij2(i,j) / aire(i,j) + alpha3 ( i,j ) = aireij3(i,j) / aire(i,j) + alpha4 ( i,j ) = aireij4(i,j) / aire(i,j) + alpha1p2( i,j ) = alpha1 (i,j) + alpha2 (i,j) + alpha1p4( i,j ) = alpha1 (i,j) + alpha4 (i,j) + alpha2p3( i,j ) = alpha2 (i,j) + alpha3 (i,j) + alpha3p4( i,j ) = alpha3 (i,j) + alpha4 (i,j) + 36 CONTINUE +c +c + aire (iip1,j) = aire (1,j) + alpha1 (iip1,j) = alpha1 (1,j) + alpha2 (iip1,j) = alpha2 (1,j) + alpha3 (iip1,j) = alpha3 (1,j) + alpha4 (iip1,j) = alpha4 (1,j) + alpha1p2(iip1,j) = alpha1p2(1,j) + alpha1p4(iip1,j) = alpha1p4(1,j) + alpha2p3(iip1,j) = alpha2p3(1,j) + alpha3p4(iip1,j) = alpha3p4(1,j) + 37 CONTINUE +c + + DO 42 j = 1,jjp1 + DO 41 i = 1,iim + aireu (i,j)= aireij1(i,j) + aireij2(i,j) + aireij4(i+1,j) + + * aireij3(i+1,j) + unsaire ( i,j)= 1./ aire(i,j) + unsair_gam1( i,j)= unsaire(i,j)** ( - gamdi_gdiv ) + unsair_gam2( i,j)= unsaire(i,j)** ( - gamdi_h ) + airesurg ( i,j)= aire(i,j)/ g + 41 CONTINUE + aireu (iip1,j) = aireu (1,j) + unsaire (iip1,j) = unsaire(1,j) + unsair_gam1(iip1,j) = unsair_gam1(1,j) + unsair_gam2(iip1,j) = unsair_gam2(1,j) + airesurg (iip1,j) = airesurg(1,j) + 42 CONTINUE +c +c + DO 48 j = 1,jjm +c + DO i=1,iim + airev (i,j) = aireij2(i,j)+ aireij3(i,j)+ aireij1(i,j+1) + + * aireij4(i,j+1) + ENDDO + DO i=1,iim + airez = aireij2(i,j)+aireij1(i,j+1)+aireij3(i+1,j) + + * aireij4(i+1,j+1) + unsairez(i,j) = 1./ airez + unsairz_gam(i,j)= unsairez(i,j)** ( - gamdi_grot ) + fext (i,j) = airez * SIN(rlatv(j))* 2.* omeg + ENDDO + airev (iip1,j) = airev(1,j) + unsairez (iip1,j) = unsairez(1,j) + fext (iip1,j) = fext(1,j) + unsairz_gam(iip1,j) = unsairz_gam(1,j) +c + 48 CONTINUE +c +c +c ..... Calcul des elongations cu,cv, cvu ......... +c + DO j = 1, jjm + DO i = 1, iim + cv(i,j) = 0.5 *( cvij2(i,j)+cvij3(i,j)+cvij1(i,j+1)+cvij4(i,j+1)) + cvu(i,j)= 0.5 *( cvij1(i,j)+cvij4(i,j)+cvij2(i,j) +cvij3(i,j) ) + cuv(i,j)= 0.5 *( cuij2(i,j)+cuij3(i,j)+cuij1(i,j+1)+cuij4(i,j+1)) + unscv2(i,j) = 1./ ( cv(i,j)*cv(i,j) ) + ENDDO + DO i = 1, iim + cuvsurcv (i,j) = airev(i,j) * unscv2(i,j) + cvsurcuv (i,j) = 1./cuvsurcv(i,j) + cuvscvgam1(i,j) = cuvsurcv (i,j) ** ( - gamdi_gdiv ) + cuvscvgam2(i,j) = cuvsurcv (i,j) ** ( - gamdi_h ) + cvscuvgam(i,j) = cvsurcuv (i,j) ** ( - gamdi_grot ) + ENDDO + cv (iip1,j) = cv (1,j) + cvu (iip1,j) = cvu (1,j) + unscv2 (iip1,j) = unscv2 (1,j) + cuv (iip1,j) = cuv (1,j) + cuvsurcv (iip1,j) = cuvsurcv (1,j) + cvsurcuv (iip1,j) = cvsurcuv (1,j) + cuvscvgam1(iip1,j) = cuvscvgam1(1,j) + cuvscvgam2(iip1,j) = cuvscvgam2(1,j) + cvscuvgam(iip1,j) = cvscuvgam(1,j) + ENDDO + + DO j = 2, jjm + DO i = 1, iim + cu(i,j) = 0.5*(cuij1(i,j)+cuij4(i+1,j)+cuij2(i,j)+cuij3(i+1,j)) + unscu2 (i,j) = 1./ ( cu(i,j) * cu(i,j) ) + cvusurcu (i,j) = aireu(i,j) * unscu2(i,j) + cusurcvu (i,j) = 1./ cvusurcu(i,j) + cvuscugam1 (i,j) = cvusurcu(i,j) ** ( - gamdi_gdiv ) + cvuscugam2 (i,j) = cvusurcu(i,j) ** ( - gamdi_h ) + cuscvugam (i,j) = cusurcvu(i,j) ** ( - gamdi_grot ) + ENDDO + cu (iip1,j) = cu(1,j) + unscu2 (iip1,j) = unscu2(1,j) + cvusurcu (iip1,j) = cvusurcu(1,j) + cusurcvu (iip1,j) = cusurcvu(1,j) + cvuscugam1(iip1,j) = cvuscugam1(1,j) + cvuscugam2(iip1,j) = cvuscugam2(1,j) + cuscvugam (iip1,j) = cuscvugam(1,j) + ENDDO + +c +c .... calcul aux poles .... +c + DO i = 1, iip1 + cu ( i, 1 ) = 0. + unscu2( i, 1 ) = 0. + cvu ( i, 1 ) = 0. +c + cu (i, jjp1) = 0. + unscu2(i, jjp1) = 0. + cvu (i, jjp1) = 0. + ENDDO +c +c .............................................................. +c + DO j = 1, jjm + DO i= 1, iim + airvscu2 (i,j) = airev(i,j)/ ( cuv(i,j) * cuv(i,j) ) + aivscu2gam(i,j) = airvscu2(i,j)** ( - gamdi_grot ) + ENDDO + airvscu2 (iip1,j) = airvscu2(1,j) + aivscu2gam(iip1,j) = aivscu2gam(1,j) + ENDDO + + DO j=2,jjm + DO i=1,iim + airuscv2 (i,j) = aireu(i,j)/ ( cvu(i,j) * cvu(i,j) ) + aiuscv2gam (i,j) = airuscv2(i,j)** ( - gamdi_grot ) + ENDDO + airuscv2 (iip1,j) = airuscv2 (1,j) + aiuscv2gam(iip1,j) = aiuscv2gam(1,j) + ENDDO + +c +c calcul des aires aux poles : +c ----------------------------- +c + apoln = SSUM(iim,aire(1,1),1) + apols = SSUM(iim,aire(1,jjp1),1) + unsapolnga1 = 1./ ( apoln ** ( - gamdi_gdiv ) ) + unsapolsga1 = 1./ ( apols ** ( - gamdi_gdiv ) ) + unsapolnga2 = 1./ ( apoln ** ( - gamdi_h ) ) + unsapolsga2 = 1./ ( apols ** ( - gamdi_h ) ) +c +c----------------------------------------------------------------------- +c gtitre='Coriolis version ancienne' +c gfichier='fext1' +c CALL writestd(fext,iip1*jjm) +c +c changement F. Hourdin calcul conservatif pour fext +c constang contient le produit a * cos ( latitude ) * omega +c + DO i=1,iim + constang(i,1) = 0. + ENDDO + DO j=1,jjm-1 + DO i=1,iim + constang(i,j+1) = rad*omeg*cu(i,j+1)*COS(rlatu(j+1)) + ENDDO + ENDDO + DO i=1,iim + constang(i,jjp1) = 0. + ENDDO +c +c periodicite en longitude +c + DO j=1,jjm + fext(iip1,j) = fext(1,j) + ENDDO + DO j=1,jjp1 + constang(iip1,j) = constang(1,j) + ENDDO + +c fin du changement + +c +c----------------------------------------------------------------------- +c + WRITE(6,*) ' *** Coordonnees de la grille *** ' + WRITE(6,995) +c + WRITE(6,*) ' LONGITUDES aux pts. V ( degres ) ' + WRITE(6,995) + DO i=1,iip1 + rlonvv(i) = rlonv(i)*180./pi + ENDDO + WRITE(6,400) rlonvv +c + WRITE(6,995) + WRITE(6,*) ' LATITUDES aux pts. V ( degres ) ' + WRITE(6,995) + DO i=1,jjm + rlatuu(i)=rlatv(i)*180./pi + ENDDO + WRITE(6,400) (rlatuu(i),i=1,jjm) +c + DO i=1,iip1 + rlonvv(i)=rlonu(i)*180./pi + ENDDO + WRITE(6,995) + WRITE(6,*) ' LONGITUDES aux pts. U ( degres ) ' + WRITE(6,995) + WRITE(6,400) rlonvv + WRITE(6,995) + + WRITE(6,*) ' LATITUDES aux pts. U ( degres ) ' + WRITE(6,995) + DO i=1,jjp1 + rlatuu(i)=rlatu(i)*180./pi + ENDDO + WRITE(6,400) (rlatuu(i),i=1,jjp1) + WRITE(6,995) +c +444 format(f10.3,f6.0) +400 FORMAT(1x,8f8.2) +990 FORMAT(//) +995 FORMAT(/) +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inigrads.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inigrads.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inigrads.F (revision 1280) @@ -0,0 +1,92 @@ +! +! $Header$ +! + subroutine inigrads(if,im + s ,x,fx,xmin,xmax,jm,y,ymin,ymax,fy,lm,z,fz + s ,dt,file,titlel) + + + implicit none + + integer if,im,jm,lm,i,j,l,lnblnk + real x(im),y(jm),z(lm),fx,fy,fz,dt + real xmin,xmax,ymin,ymax + + character file*10,titlel*40 + +#include "gradsdef.h" + +c data unit/66,32,34,36,38,40,42,44,46,48/ + integer nf + save nf + data nf/0/ + + unit(1)=66 + unit(2)=32 + unit(3)=34 + unit(4)=36 + unit(5)=38 + unit(6)=40 + unit(7)=42 + unit(8)=44 + unit(9)=46 + + if (if.le.nf) stop'verifier les appels a inigrads' + + print*,'Entree dans inigrads' + + nf=if + title(if)=titlel + ivar(if)=0 + + fichier(if)=file(1:lnblnk(file)) + + firsttime(if)=.true. + dtime(if)=dt + + iid(if)=1 + ifd(if)=im + imd(if)=im + do i=1,im + xd(i,if)=x(i)*fx + if(xd(i,if).lt.xmin) iid(if)=i+1 + if(xd(i,if).le.xmax) ifd(if)=i + enddo + print*,'On stoke du point ',iid(if),' a ',ifd(if),' en x' + + jid(if)=1 + jfd(if)=jm + jmd(if)=jm + do j=1,jm + yd(j,if)=y(j)*fy + if(yd(j,if).gt.ymax) jid(if)=j+1 + if(yd(j,if).ge.ymin) jfd(if)=j + enddo + print*,'On stoke du point ',jid(if),' a ',jfd(if),' en y' + + print*,'Open de dat' + print*,'file=',file + print*,'fichier(if)=',fichier(if) + + print*,4*(ifd(if)-iid(if))*(jfd(if)-jid(if)) + print*,file(1:lnblnk(file))//'.dat' + + OPEN (unit(if)+1,FILE=file(1:lnblnk(file))//'.dat' + s ,FORM='unformatted', + s ACCESS='direct' + s ,RECL=4*(ifd(if)-iid(if)+1)*(jfd(if)-jid(if)+1)) + + print*,'Open de dat ok' + + lmd(if)=lm + do l=1,lm + zd(l,if)=z(l)*fz + enddo + + irec(if)=0 + + print*,if,imd(if),jmd(if),lmd(if) + print*,'if,imd(if),jmd(if),lmd(if)' + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/iniinterp_horiz.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/iniinterp_horiz.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/iniinterp_horiz.F (revision 1280) @@ -0,0 +1,179 @@ +C +C $Header$ +C + subroutine iniinterp_horiz (imo,jmo,imn,jmn ,kllm, + & rlonuo,rlatvo,rlonun,rlatvn, + & ktotal,iik,jjk,jk,ik,intersec,airen) + + implicit none + + + +c --------------------------------------------------------- +c Prepare l' interpolation des variables d'une grille LMDZ +c dans une autre grille LMDZ en conservant la quantite +c totale pour les variables intensives (/m2) : ex : Pression au sol +c +c (Pour chaque case autour d'un point scalaire de la nouvelle +c grille, on calcule la surface (en m2)en intersection avec chaque +c case de l'ancienne grille , pour la future interpolation) +c +c on calcule aussi l' aire dans la nouvelle grille +c +c +c Auteur: F.Forget 01/1995 +c ------- +c +c --------------------------------------------------------- +c Declarations: +c ============== +c +c ARGUMENTS +c """"""""" +c INPUT + integer imo, jmo ! dimensions ancienne grille + integer imn,jmn ! dimensions nouvelle grille + integer kllm ! taille du tableau des intersections + real rlonuo(imo+1) ! Latitude et + real rlatvo(jmo) ! longitude des + real rlonun(imn+1) ! bord des + real rlatvn(jmn) ! cases "scalaires" (input) + +c OUTPUT + integer ktotal ! nombre totale d'intersections reperees + integer iik(kllm), jjk(kllm),jk(kllm),ik(kllm) + real intersec(kllm) ! surface des intersections (m2) + real airen (imn+1,jmn+1) ! aire dans la nouvelle grille + + + + +c Autres variables +c """""""""""""""" + integer i,j,ii,jj,k + real a(imo+1),b(imo+1),c(jmo+1),d(jmo+1) + real an(imn+1),bn(imn+1),cn(jmn+1),dn(jmn+1) + real aa, bb,cc,dd + real pi + + pi = 2.*ASIN( 1. ) + + + +c On repere les frontieres des cases : +c =================================== +c +c Attention, on ruse avec des latitudes = 90 deg au pole. + + +c ANcienne grile +c """""""""""""" + a(1) = - rlonuo(imo+1) + b(1) = rlonuo(1) + do i=2,imo+1 + a(i) = rlonuo(i-1) + b(i) = rlonuo(i) + end do + + d(1) = pi/2 + do j=1,jmo + c(j) = rlatvo(j) + d(j+1) = rlatvo(j) + end do + c(jmo+1) = -pi/2 + + +c Nouvelle grille +c """"""""""""""" + an(1) = - rlonun(imn+1) + bn(1) = rlonun(1) + do i=2,imn+1 + an(i) = rlonun(i-1) + bn(i) = rlonun(i) + end do + + dn(1) = pi/2 + do j=1,jmn + cn(j) = rlatvn(j) + dn(j+1) = rlatvn(j) + end do + cn(jmn+1) = -pi/2 + +c Calcul de la surface des cases scalaires de la nouvelle grille +c ============================================================== + do ii=1,imn + 1 + do jj = 1,jmn+1 + airen(ii,jj) = (bn(ii)-an(ii))*(sin(dn(jj))-sin(cn(jj))) + end do + end do + +c Calcul de la surface des intersections +c ====================================== + +c boucle sur la nouvelle grille +c """""""""""""""""""""""""""" + ktotal = 0 + do jj = 1,jmn+1 + do j=1, jmo+1 + if((cn(jj).lt.d(j)).and.(dn(jj).gt.c(j)))then + do ii=1,imn + 1 + do i=1, imo +1 + if ( ((an(ii).lt.b(i)).and.(bn(ii).gt.a(i))) + & .or. ((an(ii).lt.b(i)-2*pi).and.(bn(ii).gt.a(i)-2*pi) + & .and.(b(i)-2*pi.lt.-pi) ) + & .or. ((an(ii).lt.b(i)+2*pi).and.(bn(ii).gt.a(i)+2*pi) + & .and.(a(i)+2*pi.gt.pi) ) + & )then + ktotal = ktotal +1 + iik(ktotal) =ii + jjk(ktotal) =jj + ik(ktotal) =i + jk(ktotal) =j + + dd = min(d(j), dn(jj)) + cc = cn(jj) + if (cc.lt. c(j))cc=c(j) + if((an(ii).lt.b(i)-2*pi).and. + & (bn(ii).gt.a(i)-2*pi)) then + bb = min(b(i)-2*pi,bn(ii)) + aa = an(ii) + if (aa.lt.a(i)-2*pi) aa=a(i)-2*pi + else if((an(ii).lt.b(i)+2*pi).and. + & (bn(ii).gt.a(i)+2*pi)) then + bb = min(b(i)+2*pi,bn(ii)) + aa = an(ii) + if (aa.lt.a(i)+2*pi) aa=a(i)+2*pi + else + bb = min(b(i),bn(ii)) + aa = an(ii) + if (aa.lt.a(i)) aa=a(i) + end if + intersec(ktotal)=(bb-aa)*(sin(dd)-sin(cc)) + end if + end do + end do + end if + end do + end do + + + +c TEST INFO +c DO k=1,ktotal +c ii = iik(k) +c jj = jjk(k) +c i = ik(k) +c j = jk(k) +c if ((ii.eq.10).and.(jj.eq.10).and.(i.eq.10).and.(j.eq.10))then +c if (jj.eq.2.and.(ii.eq.1))then +c write(*,*) '**************** jj=',jj,'ii=',ii +c write(*,*) 'i,j =',i,j +c write(*,*) 'an,bn,cn,dn', an(ii), bn(ii), cn(jj),dn(jj) +c write(*,*) 'a,b,c,d', a(i), b(i), c(j),d(j) +c write(*,*) 'intersec(k)',intersec(k) +c write(*,*) 'airen(ii,jj)=',airen(ii,jj) +c end if +c END DO + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/iniprint.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/iniprint.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/iniprint.h (revision 1280) @@ -0,0 +1,11 @@ +! +! $Header$ +! +! +! gestion des impressions de sorties et de débogage +! lunout: unité du fichier dans lequel se font les sorties +! (par defaut 6, la sortie standard) +! prt_level: niveau d'impression souhaité (0 = minimum) +! + INTEGER lunout, prt_level + COMMON /comprint/ lunout, prt_level Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/initial0.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/initial0.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/initial0.F (revision 1280) @@ -0,0 +1,12 @@ +! +! $Header$ +! + SUBROUTINE initial0(n,x) + IMPLICIT NONE + INTEGER n,i + REAL x(n) + DO 10 i=1,n + x(i)=0. +10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/integrd.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/integrd.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/integrd.F (revision 1280) @@ -0,0 +1,236 @@ +! +! $Id$ +! + SUBROUTINE integrd + $ ( nq,vcovm1,ucovm1,tetam1,psm1,massem1, + $ dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis,finvmaold ) + + IMPLICIT NONE + + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c objet: +c ------ +c +c Incrementation des tendances dynamiques +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" +#include "logic.h" +#include "temps.h" +#include "serre.h" +#include "control.h" + +c Arguments: +c ---------- + + INTEGER nq + + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nq) + REAL ps(ip1jmp1),masse(ip1jmp1,llm),phis(ip1jmp1) + + REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm) + REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1),massem1(ip1jmp1,llm) + + REAL dv(ip1jm,llm),du(ip1jmp1,llm) + REAL dteta(ip1jmp1,llm),dp(ip1jmp1) + REAL dq(ip1jmp1,llm,nq), finvmaold(ip1jmp1,llm) + +c Local: +c ------ + + REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1) + REAL massescr( ip1jmp1,llm ), finvmasse(ip1jmp1,llm) + REAL p(ip1jmp1,llmp1) + REAL tpn,tps,tppn(iim),tpps(iim) + REAL qpn,qps,qppn(iim),qpps(iim) + REAL deltap( ip1jmp1,llm ) + + INTEGER l,ij,iq + + REAL SSUM + +c----------------------------------------------------------------------- + + DO l = 1,llm + DO ij = 1,iip1 + ucov( ij , l) = 0. + ucov( ij +ip1jm, l) = 0. + uscr( ij ) = 0. + uscr( ij +ip1jm ) = 0. + ENDDO + ENDDO + + +c ............ integration de ps .............. + + CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1) + + DO 2 ij = 1,ip1jmp1 + pscr (ij) = ps(ij) + ps (ij) = psm1(ij) + dt * dp(ij) + 2 CONTINUE +c + DO ij = 1,ip1jmp1 + IF( ps(ij).LT.0. ) THEN + PRINT*,' Au point ij = ',ij, ' , pression sol neg. ', ps(ij) + STOP' dans integrd' + ENDIF + ENDDO +c + DO ij = 1, iim + tppn(ij) = aire( ij ) * ps( ij ) + tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + tps = SSUM(iim,tpps,1)/apols + DO ij = 1, iip1 + ps( ij ) = tpn + ps(ij+ip1jm) = tps + ENDDO +c +c ... Calcul de la nouvelle masse d'air au dernier temps integre t+1 ... +c + CALL pression ( ip1jmp1, ap, bp, ps, p ) + CALL massdair ( p , masse ) + + CALL SCOPY( ijp1llm , masse, 1, finvmasse, 1 ) + CALL filtreg( finvmasse, jjp1, llm, -2, 2, .TRUE., 1 ) +c + +c ............ integration de ucov, vcov, h .............. + + DO 10 l = 1,llm + + DO 4 ij = iip2,ip1jm + uscr( ij ) = ucov( ij,l ) + ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l ) + 4 CONTINUE + + DO 5 ij = 1,ip1jm + vscr( ij ) = vcov( ij,l ) + vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l ) + 5 CONTINUE + + DO 6 ij = 1,ip1jmp1 + hscr( ij ) = teta(ij,l) + teta ( ij,l ) = tetam1(ij,l) * massem1(ij,l) / masse(ij,l) + $ + dt * dteta(ij,l) / masse(ij,l) + 6 CONTINUE + +c .... Calcul de la valeur moyenne, unique aux poles pour teta ...... +c +c + DO ij = 1, iim + tppn(ij) = aire( ij ) * teta( ij ,l) + tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + teta( ij ,l) = tpn + teta(ij+ip1jm,l) = tps + ENDDO +c + + IF(leapf) THEN + CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 ) + CALL SCOPY ( ip1jm, vscr(1), 1, vcovm1(1, l), 1 ) + CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 ) + END IF + + 10 CONTINUE + + +c +c ....... integration de q ...... +c +c$$$ IF( iadv(1).NE.3.AND.iadv(2).NE.3 ) THEN +c$$$c +c$$$ IF( forward. OR . leapf ) THEN +c$$$ DO iq = 1,2 +c$$$ DO l = 1,llm +c$$$ DO ij = 1,ip1jmp1 +c$$$ q(ij,l,iq) = ( q(ij,l,iq)*finvmaold(ij,l) + dtvr *dq(ij,l,iq) )/ +c$$$ $ finvmasse(ij,l) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$ ELSE +c$$$ DO iq = 1,2 +c$$$ DO l = 1,llm +c$$$ DO ij = 1,ip1jmp1 +c$$$ q( ij,l,iq ) = q( ij,l,iq ) * finvmaold(ij,l) / finvmasse(ij,l) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$ +c$$$ END IF +c$$$c +c$$$ ENDIF + + if (planet_type.eq."earth") then +! Earth-specific treatment of first 2 tracers (water) + DO l = 1, llm + DO ij = 1, ip1jmp1 + deltap(ij,l) = p(ij,l) - p(ij,l+1) + ENDDO + ENDDO + + CALL qminimum( q, nq, deltap ) + endif ! of if (planet_type.eq."earth") + +c +c ..... Calcul de la valeur moyenne, unique aux poles pour q ..... +c + + DO iq = 1, nq + DO l = 1, llm + + DO ij = 1, iim + qppn(ij) = aire( ij ) * q( ij ,l,iq) + qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq) + ENDDO + qpn = SSUM(iim,qppn,1)/apoln + qps = SSUM(iim,qpps,1)/apols + + DO ij = 1, iip1 + q( ij ,l,iq) = qpn + q(ij+ip1jm,l,iq) = qps + ENDDO + + ENDDO + ENDDO + + + CALL SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 ) +c +c +c ..... FIN de l'integration de q ....... + +15 continue + +c ................................................................. + + + IF( leapf ) THEN + CALL SCOPY ( ip1jmp1 , pscr , 1, psm1 , 1 ) + CALL SCOPY ( ip1jmp1*llm, massescr, 1, massem1, 1 ) + END IF + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inter_barx.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inter_barx.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inter_barx.F (revision 1280) @@ -0,0 +1,218 @@ +! +! $Header$ +! + SUBROUTINE inter_barx ( idatmax,xidat,fdat,imodmax,ximod,fmod ) + +c .... Auteurs : Robert Sadourny , P. Le Van ..... +c + IMPLICIT NONE +c ---------------------------------------------------------- +c INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES +c VERSION UNIDIMENSIONNELLE , EN LONGITUDE . +c ---------------------------------------------------------- +c +c idat : indice du champ de donnees, de 1 a idatmax +c imod : indice du champ du modele, de 1 a imodmax +c fdat(idat) : champ de donnees (entrees) +c fmod(imod) : champ du modele (sorties) +c xidat(idat): abscisses des interfaces des mailles donnees +c ximod(imod): abscisses des interfaces des mailles modele +c ( L'indice 1 correspond a l'interface mailLE 1 / maille 2) +c ( Les abscisses sont exprimes en degres) + + + INTEGER idatmax, imodmax + REAL xidat(idatmax),fdat(idatmax),ximod(imodmax),fmod(imodmax) + +c ... Variables locales ... + + REAL xxid(idatmax+1), xxd(idatmax+1), fdd(idatmax+1) + REAL fxd(idatmax+1), xchan(idatmax+1), fdchan(idatmax+1) + REAL xxim(imodmax) + + REAL x0,xim0,dx,dxm + REAL chmin,chmax,pi + + INTEGER imod,idat,i,ichang,id0,id1,nid,idatmax1 + + pi = 2. * ASIN(1.) + +c ----------------------------------------------------- +c REDEFINITION DE L'ORIGINE DES ABSCISSES +c A L'INTERFACE OUEST DE LA PREMIERE MAILLE DU MODELE +c ----------------------------------------------------- + DO imod = 1,imodmax + xxim(imod) = ximod(imod) + ENDDO + + CALL minmax( imodmax,xxim,chmin,chmax) + IF( chmax.LT.6.50 ) THEN +c PRINT 3 +c PRINT *,' conversion des longit. ximod (donnees en radians)' +c , ,' en degres .' +c PRINT 3 + DO imod = 1, imodmax + xxim(imod) = xxim(imod) * 180./pi + ENDDO + ENDIF + + xim0 = xxim(imodmax) - 360. + + DO imod = 1, imodmax + xxim(imod) = xxim(imod) - xim0 + ENDDO + + idatmax1 = idatmax +1 + + DO idat = 1, idatmax + xxd(idat) = xidat(idat) + ENDDO + + CALL minmax( idatmax,xxd,chmin,chmax) + IF( chmax.LT.6.50 ) THEN +c PRINT 3 +c PRINT *,' conversion des longit. ximod (donnees en radians)' +c , ,' en degres .' +c PRINT 3 + DO idat = 1, idatmax + xxd(idat) = xxd(idat) * 180./pi + ENDDO + ENDIF + + DO idat = 1, idatmax + xxd(idat) = MOD( xxd(idat) - xim0, 360. ) + fdd(idat) = fdat (idat) + ENDDO +c PRINT *,' xxd redef. origine abscisses ' +c PRINT 2,(xxd(i),i=1,idatmax) + + DO i = 2, idatmax + IF( ( xxd(i) - xxd(i-1)).LT.0. ) THEN + ichang = i + GO TO 5 + ENDIF + ENDDO + GO TO 6 +c +c *** reorganisation des longitudes entre 0. et 360. degres **** +c + 5 nid = idatmax - ichang +1 + DO i = 1, nid + xchan (i) = xxd(i+ichang -1 ) + fdchan(i) = fdd(i+ichang -1 ) + ENDDO + DO i=1,ichang -1 + xchan (i+ nid) = xxd(i) + fdchan(i+nid) = fdd(i) + ENDDO + DO i =1,idatmax + xxd(i) = xchan(i) + fdd(i) = fdchan(i) + ENDDO + + 6 continue + + +c ------------------------------------------------ +c translation des champs de donnees par rapport +c a la nouvelle origine, avec redondance de la +c maille a cheval sur les bords +c ----------------------------------------------- + + id0 = 0 + id1 = 0 + + DO idat = 1, idatmax + IF ( xxd( idatmax1- idat ).LT.360.) GO TO 10 + id1 = id1 + 1 + ENDDO + + 10 DO idat = 1, idatmax + IF (xxd(idat).GT.0.) GO TO 20 + id0 = id0 + 1 + END DO + + 20 IF( id1.EQ.0 ) GO TO 30 + DO idat = 1, id1 + xxid(idat) = xxd(idatmax - id1 + idat) - 360. + fxd (idat) = fdd(idatmax - id1 + idat) + END DO + DO idat = 1, idatmax - id1 + xxid(idat + id1) = xxd(idat) + fxd (idat + id1) = fdd(idat) + END DO + + 30 IF(id0.EQ.0) GO TO 40 + DO idat = 1, idatmax - id0 + xxid(idat) = xxd(idat + id0) + fxd (idat) = fdd(idat + id0) + END DO + + DO idat = 1, id0 + xxid (idatmax - id0 + idat) = xxd(idat) + 360. + fxd (idatmax - id0 + idat) = fdd(idat) + END DO + GO TO 50 + + 40 DO idat = 1, idatmax + xxid(idat) = xxd(idat) + fxd (idat) = fdd(idat) + ENDDO + + 50 xxid(idatmax1) = xxid(1) + 360. + fxd (idatmax1) = fxd(1) + +c ------------------------------------ +c initialisation du champ du modele + + DO imod = 1, imodmax + fmod(imod) = 0. + END DO + +c PRINT *,' id0 id1 ',id0,id1 +c PRINT *,' xxim apres translation ' +c PRINT 2,(xxim(i),i=1,imodmax) +c PRINT *,' xxid apres translation ' +c PRINT 2,(xxid(i),i=1,idatmax) +c --------------------------------------- +c iteration + + x0 = xim0 + dxm = 0. + imod = 1 + idat = 1 + + 100 IF (xxim(imod).LT.xxid(idat)) THEN + dx = xxim(imod) - x0 + dxm = dxm + dx + fmod(imod) = (fmod(imod) + dx * fxd(idat)) / dxm + x0 = xxim(imod) + dxm = 0. + imod = imod + 1 + IF (imod.LE.imodmax) GO TO 100 + + ELSE IF (xxim(imod).GT.xxid(idat)) THEN + dx = xxid(idat) - x0 + dxm = dxm + dx + fmod(imod) = fmod(imod) + dx * fxd(idat) + x0 = xxid(idat) + idat = idat + 1 + GO TO 100 + + ELSE + dx = xxim(imod) - x0 + dxm = dxm + dx + fmod(imod) = (fmod(imod) + dx * fxd(idat)) / dxm + x0 = xxim(imod) + dxm = 0. + imod = imod + 1 + idat = idat + 1 + IF (imod.LE.imodmax) GO TO 100 + END IF + + +3 FORMAT(1x,70("-")) +2 FORMAT(1x,8f8.2) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inter_barxy.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inter_barxy.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inter_barxy.F (revision 1280) @@ -0,0 +1,59 @@ +! +! $Header$ +! + SUBROUTINE inter_barxy ( interfd,jnterfd,dlonid,dlatid , + , champ,imod,jmod,rlonimod,rlatimod, jsort,champint ) + +c Auteur : P. Le Van +c + INTEGER interfd,jnterfd,imod,jmod + REAL champ(interfd,jnterfd +1 ),dlonid(interfd),dlatid(jnterfd), + , champint(imod,jsort) + REAL rlonimod(imod),rlatimod(jmod) + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" + + REAL champx(imod),champy(jnterfd +1,imod),chpn(imod),chps(imod) + REAL chhpn,chhps + REAL fmody(jjp1) +c + + DO j = 1, jnterfd + 1 + CALL inter_barx( interfd, dlonid, champ( 1,j ), + , imod, rlonimod , champx ) + DO i = 1,imod + champy(j,i) = champx(i) + ENDDO + ENDDO + + DO i = 1, imod + CALL inter_bary( jjm,jnterfd,dlatid,champy(1,i), + , jmod ,rlatimod, fmody ) + DO j = 1, jsort + champint(i,j) = fmody(j) + ENDDO + ENDDO + + IF( jsort.EQ.jjp1) THEN + +c .... Valeurs uniques aux poles .... +c + DO i = 1,imod + chpn(i) = aire( i, 1 ) * champint( i, 1 ) + chps(i) = aire( i, jjp1 ) * champint( i,jjp1 ) + ENDDO + chhpn = SSUM(imod,chpn,1)/apoln + chhps = SSUM(imod,chps,1)/apols + + DO i = 1, imod + champint( i, 1 ) = chhpn + champint( i, jjp1) = chhps + ENDDO +c + ENDIF + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inter_bary.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inter_bary.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/inter_bary.F (revision 1280) @@ -0,0 +1,135 @@ +! +! $Header$ +! + SUBROUTINE inter_bary( jjm, jdatmax, yjdatt, fdatt , + , jmodmax, yjmodd, fmod ) +c +c ... Auteurs : Robert Sadourny , P. Le Van ... +c + IMPLICIT NONE + +c ---------------------------------------------------------- +c INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES . +c VERSION UNIDIMENSIONNELLE , EN LATITUDE . +c ---------------------------------------------------------- +c +c jdat : indice du champ de donnees, de 1 a jdatmax +c jmod : indice du champ du modele, de 1 a jmodmax +c fdatt(jdatmax) : champ de donnees (entrees) +c yjdatt(jdatmax): ordonnees des interfaces des mailles donnees +c yjmodd(jmodmax): ordonnees des interfaces des mailles modele +c fmod(jmodmax) : champ du modele (sorties) +c +c ( L'indice 1 correspond a l'interface maille 1 / maille 2) +c ( Les ordonnees sont exprimees en degres) +c +c jdatmax = nb. d'interfaces donnees = nombre de donnees - 1 +c jmodmax = nb. d'interfaces modele + +c Si jmodmax = jjm , on veut interpoler sur les jjm+1 latitudes +c rlatu du modele ( lat. des scalaires et de U ) +c +c Si jmodmax = jjp1 , on veut interpoler sur les jjm latitudes +c rlatv du modele ( lat. de V ) + +c .... Arguments en entree ....... + + INTEGER jjm , jdatmax, jmodmax + REAL yjdatt( jdatmax ) , fdatt( jdatmax +1 ) + REAL yjmodd( jmodmax ) + +c .... Arguments en sortie ....... +c + REAL fmod( jmodmax + 1 ) +c +c ...... Variables locales ...... + + INTEGER jmods + + REAL yjdat ( jdatmax +1 ), fdat( jdatmax +1) + REAL fscrat( jdatmax +1 ) + REAL yjmod ( jmodmax +1 ) + LOGICAL decrois + SAVE decrois +c + REAL y0,dy,dym + INTEGER jdat, jmod,i +c + + DO i = 1, jdatmax +1 + fdat (i) = fdatt (i) + ENDDO + + CALL ord_coord ( jdatmax , yjdatt(1), yjdat(1), decrois ) + + IF( decrois ) THEN + DO i = 1,jdatmax + 1 + fscrat(i) = fdat(i) + ENDDO + DO i = 1, jdatmax + 1 + fdat(i) = fscrat( jdatmax + 2 -i ) + ENDDO + + ENDIF + + CALL ord_coordm (jmodmax,yjmodd(1),yjmod(1),jjm,jmods,decrois ) +c +c Initialisation des variables +c -------------------------------- + + DO jmod = 1, jmods + fmod(jmod) = 0. + END DO + + y0 = 0. + dym = 0. + jmod = 1 + jdat = 1 +c -------------------- +c Iteration +c -------------------- + +100 IF ( yjmod(jmod).LT.yjdat(jdat) ) THEN + dy = yjmod(jmod) - y0 + dym = dym + dy + fmod(jmod) = (fmod(jmod) + dy * fdat(jdat)) / dym + y0 = yjmod(jmod) + dym = 0. + jmod = jmod + 1 + GO TO 100 + + ELSE IF ( yjmod(jmod).GT.yjdat(jdat) ) THEN + dy = yjdat(jdat) - y0 + dym = dym + dy + fmod(jmod) = fmod(jmod) + dy * fdat(jdat) + y0 = yjdat(jdat) + jdat = jdat + 1 + + GO TO 100 + + ELSE + dy = yjmod(jmod) - y0 + dym = dym + dy + fmod(jmod) = (fmod(jmod) + dy * fdat(jdat)) / dym + y0 = yjmod(jmod) + dym = 0. + jmod = jmod + 1 + jdat = jdat + 1 + + IF ( jmod.LE.jmods ) GO TO 100 + END IF +c --------------------------------------------- +c Le test de fin suppose que l'interface 0 +c est commune aux deux grilles yjdat et yjmod. +c ---------------------------------------------- + IF( decrois ) THEN + DO i = 1,jmods + fscrat(i) = fmod(i) + ENDDO + DO i = 1, jmods + fmod(i) = fscrat( jmods + 1 -i ) + ENDDO + ENDIF + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/interp_horiz.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/interp_horiz.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/interp_horiz.F (revision 1280) @@ -0,0 +1,154 @@ +c +c $Header$ +c + subroutine interp_horiz (varo,varn,imo,jmo,imn,jmn,lm, + & rlonuo,rlatvo,rlonun,rlatvn) + +c=========================================================== +c Interpolation Horizontales des variables d'une grille LMDZ +c (des points SCALAIRES au point SCALAIRES) +c dans une autre grille LMDZ en conservant la quantite +c totale pour les variables intensives (/m2) : ex : Pression au sol +c +c Francois Forget (01/1995) +c=========================================================== + + IMPLICIT NONE + +c Declarations: +c ============== +c +c ARGUMENTS +c """"""""" + + integer imo, jmo ! dimensions ancienne grille (input) + integer imn,jmn ! dimensions nouvelle grille (input) + + real rlonuo(imo+1) ! Latitude et + real rlatvo(jmo) ! longitude des + real rlonun(imn+1) ! bord des + real rlatvn(jmn) ! cases "scalaires" (input) + + integer lm ! dimension verticale (input) + real varo (imo+1, jmo+1,lm) ! var dans l'ancienne grille (input) + real varn (imn+1,jmn+1,lm) ! var dans la nouvelle grille (output) + +c Autres variables +c """""""""""""""" + real airetest(imn+1,jmn+1) + integer ii,jj,l + + real airen (imn+1,jmn+1) ! aire dans la nouvelle grille +c Info sur les ktotal intersection entre les cases new/old grille + integer kllm, k, ktotal + parameter (kllm = 400*200*10) + integer iik(kllm), jjk(kllm),jk(kllm),ik(kllm) + real intersec(kllm) + real R + real totn, tots + + logical firstcall, firsttest, aire_ok + save firsttest + data firsttest /.true./ + data aire_ok /.true./ + + + + + +c initialisation +c -------------- +c Si c'est le premier appel, on prepare l'interpolation +c en calculant pour chaque case autour d'un point scalaire de la +c nouvelle grille, la surface de intersection avec chaque +c case de l'ancienne grille. + + + call iniinterp_horiz (imo,jmo,imn,jmn ,kllm, + & rlonuo,rlatvo,rlonun,rlatvn, + & ktotal,iik,jjk,jk,ik,intersec,airen) + + do l=1,lm + do jj =1 , jmn+1 + do ii=1, imn+1 + varn(ii,jj,l) =0. + end do + end do + end do + +c Interpolation horizontale +c ------------------------- +c boucle sur toute les ktotal intersections entre les cases +c de l'ancienne et la nouvelle grille +c + PRINT *, 'ktotal 1 = ', ktotal + + do k=1,ktotal + do l=1,lm + varn(iik(k),jjk(k),l) = varn(iik(k),jjk(k),l) + & + varo(ik(k), jk(k),l)*intersec(k)/airen(iik(k),jjk(k)) + end do + end do + +c Une seule valeur au pole pour les variables ! : +c ----------------------------------------------- + do l=1, lm + totn =0. + tots =0. + do ii =1, imn+1 + totn = totn + varn(ii,1,l) + tots = tots + varn (ii,jmn+1,l) + end do + do ii =1, imn+1 + varn(ii,1,l) = totn/float(imn+1) + varn(ii,jmn+1,l) = tots/float(imn+1) + end do + end do + + +c--------------------------------------------------------------- +c TEST TEST TEST TEST TEST TEST TEST TEST TEST TEST +!! if (.not.(firsttest)) goto 99 +!! firsttest = .false. +!! ! write (*,*) 'INTERP. HORIZ. : TEST SUR LES AIRES:' +!! do jj =1 , jmn+1 +!! do ii=1, imn+1 +!! airetest(ii,jj) =0. +!! end do +!! end do +!! PRINT *, 'ktotal = ', ktotal +!! PRINT *, 'jmn+1 =', jmn+1, 'imn+1', imn+1 +!! +!! do k=1,ktotal +!! airetest(iik(k),jjk(k))= airetest(iik(k),jjk(k)) +intersec(k) +!! end DO +!! +!! +!! PRINT *, 'fin boucle' +!! do jj =1 , jmn+1 +!! do ii=1, imn+1 +!! r = airen(ii,jj)/airetest(ii,jj) +!! if ((r.gt.1.001).or.(r.lt.0.999)) then +!! ! write (*,*) '********** PROBLEME D'' AIRES !!!', +!! ! & ' DANS L''INTERPOLATION HORIZONTALE' +!! ! write(*,*)'ii,jj,airen,airetest', +!! ! & ii,jj,airen(ii,jj),airetest(ii,jj) +!! aire_ok = .false. +!! end if +!! end do +!! end do +!! ! if (aire_ok) write(*,*) 'INTERP. HORIZ. : AIRES OK' +!! 99 continue + +c FIN TEST FIN TEST FIN TEST FIN TEST FIN TEST FIN TEST FIN TEST +c--------------------------------------------------------------- + + + + + + + + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/interpost.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/interpost.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/interpost.F (revision 1280) @@ -0,0 +1,45 @@ +! +! $Header$ +! + subroutine interpost(q,qppm) + + implicit none + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +c Arguments + real q(iip1,jjp1,llm) + real qppm(iim,jjp1,llm) +c Local + integer l,i,j + +c RE-INVERSION DES NIVEAUX +c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport +c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface +c On passe donc des niveaux de Lin à ceux du LMDZ + + do l=1,llm + do j=1,jjp1 + do i=1,iim + q(i,j,l)=qppm(i,j,llm-l+1) + enddo + enddo + enddo + +c BOUCLAGE EN LONGITUDE PAS EFFECTUE DANS PPM3D + + do l=1,llm + do j=1,jjp1 + q(iip1,j,l)=q(1,j,l) + enddo + enddo + + + return + + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/interpre.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/interpre.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/interpre.F (revision 1280) @@ -0,0 +1,132 @@ +! +! $Header$ +! + subroutine interpre(q,qppm,w,fluxwppm,masse, + s apppm,bpppm,massebx,masseby,pbaru,pbarv, + s unatppm,vnatppm,psppm) + + implicit none + +#include "dimensions.h" +c#include "paramr2.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissip.h" +#include "comvert.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "control.h" +#include "ener.h" +#include "description.h" + +c--------------------------------------------------- +c Arguments + real apppm(llm+1),bpppm(llm+1) + real q(iip1,jjp1,llm),qppm(iim,jjp1,llm) +c--------------------------------------------------- + real masse(iip1,jjp1,llm) + real massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm) + real w(iip1,jjp1,llm+1) + real fluxwppm(iim,jjp1,llm) + real pbaru(iip1,jjp1,llm ) + real pbarv(iip1,jjm,llm) + real unatppm(iim,jjp1,llm) + real vnatppm(iim,jjp1,llm) + real psppm(iim,jjp1) +c--------------------------------------------------- +c Local + real vnat(iip1,jjp1,llm) + real unat(iip1,jjp1,llm) + real fluxw(iip1,jjp1,llm) + real smass(iip1,jjp1) +c---------------------------------------------------- + integer l,ij,i,j + +c CALCUL DE LA PRESSION DE SURFACE +c Les coefficients ap et bp sont passés en common +c Calcul de la pression au sol en mb optimisée pour +c la vectorialisation + + do j=1,jjp1 + do i=1,iip1 + smass(i,j)=0. + enddo + enddo + + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + smass(i,j)=smass(i,j)+masse(i,j,l) + enddo + enddo + enddo + + do j=1,jjp1 + do i=1,iim + psppm(i,j)=smass(i,j)/aire(i,j)*g*0.01 + end do + end do + +c RECONSTRUCTION DES CHAMPS CONTRAVARIANTS +c Le programme ppm3d travaille avec les composantes +c de vitesse et pas les flux, on doit donc passer de l'un à l'autre +c Dans le même temps, on fait le changement d'orientation du vent en v + do l=1,llm + do j=1,jjm + do i=1,iip1 + vnat(i,j,l)=-pbarv(i,j,l)/masseby(i,j,l)*cv(i,j) + enddo + enddo + do i=1,iim + vnat(i,jjp1,l)=0. + enddo + do j=1,jjp1 + do i=1,iip1 + unat(i,j,l)=pbaru(i,j,l)/massebx(i,j,l)*cu(i,j) + enddo + enddo + enddo + +c CALCUL DU FLUX MASSIQUE VERTICAL +c Flux en l=1 (sol) nul + fluxw=0. + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + fluxw(i,j,l)=w(i,j,l)*g*0.01/aire(i,j) +C print*,i,j,l,'fluxw(i,j,l)=',fluxw(i,j,l), +C c 'w(i,j,l)=',w(i,j,l) + enddo + enddo + enddo + +c INVERSION DES NIVEAUX +c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport +c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface +c On passe donc des niveaux du LMDZ à ceux de Lin + + do l=1,llm+1 + apppm(l)=ap(llm+2-l) + bpppm(l)=bp(llm+2-l) + enddo + + do l=1,llm + do j=1,jjp1 + do i=1,iim + unatppm(i,j,l)=unat(i,j,llm-l+1) + vnatppm(i,j,l)=vnat(i,j,llm-l+1) + fluxwppm(i,j,l)=fluxw(i,j,llm-l+1) + qppm(i,j,l)=q(i,j,llm-l+1) + enddo + enddo + enddo + + return + end + + + + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/invert_lat.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/invert_lat.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/invert_lat.F90 (revision 1280) @@ -0,0 +1,21 @@ + +SUBROUTINE invert_lat(xsize,ysize,vsize,field) + + IMPLICIT NONE + +! Input variables + INTEGER, INTENT(IN) :: xsize,ysize,vsize + REAL, DIMENSION (xsize,ysize,vsize), INTENT(INOUT) :: field +! Local variables + REAL, DIMENSION (xsize,ysize,vsize) :: f_aux + INTEGER :: l,j + + DO l=1,vsize + DO j=1,ysize + f_aux(:,j,l)=field(:,ysize+1-j,l) + END DO + END DO + + field=f_aux + + END SUBROUTINE invert_lat Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ismax.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ismax.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ismax.F (revision 1280) @@ -0,0 +1,24 @@ +! +! $Header$ +! + function ismax(n,sx,incx) +c + IMPLICIT NONE +c + INTEGER n,i,incx,ismax,ix + real sx((n-1)*incx+1),sxmax +c + ix=1 + ismax=1 + sxmax=sx(1) + do 10 i=1,n-1 + ix=ix+incx + if(sx(ix).gt.sxmax) then + sxmax=sx(ix) + ismax=i+1 + endif +10 continue +c + return + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ismin.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ismin.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ismin.F (revision 1280) @@ -0,0 +1,24 @@ +! +! $Header$ +! + FUNCTION ismin(n,sx,incx) +c + IMPLICIT NONE +c + integer n,i,incx,ismin,ix + real sx((n-1)*incx+1),sxmin +c + ix=1 + ismin=1 + sxmin=sx(1) + DO i=1,n-1 + ix=ix+incx + if(sx(ix).lt.sxmin) then + sxmin=sx(ix) + ismin=i+1 + endif + ENDDO +c + return + end +C Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/juldate.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/juldate.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/juldate.F (revision 1280) @@ -0,0 +1,33 @@ +! +! $Header$ +! + subroutine juldate(ian,imoi,ijou,oh,om,os,tjd,tjdsec) +c Sous-routine de changement de date: +c gregorien>>>date julienne +c En entree:an,mois,jour,heure,min.,sec. +c En sortie:tjd + implicit real (a-h,o-z) + frac=((os/60.+om)/60.+oh)/24. + ojou=dfloat(ijou)+frac + year=dfloat(ian) + rmon=dfloat(imoi) + if (imoi .le. 2) then + year=year-1. + rmon=rmon+12. + endif + cf=year+(rmon/100.)+(ojou/10000.) + if (cf .ge. 1582.1015) then + a=int(year/100) + b=2-a+int(a/4) + else + b=0 + endif + tjd=int(365.25*year)+int(30.6001*(rmon+1))+int(ojou) + + +1720994.5+b + tjdsec=(ojou-int(ojou))+(tjd-int(tjd)) + tjd=int(tjd)+int(tjdsec) + tjdsec=tjdsec-int(tjdsec) + return + end + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/laplacien.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/laplacien.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/laplacien.F (revision 1280) @@ -0,0 +1,40 @@ +! +! $Header$ +! + SUBROUTINE laplacien ( klevel, teta, divgra ) +c +c P. Le Van +c +c ************************************************************ +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ......... variables en arguments .............. +c + INTEGER klevel + REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) +c +c ............ variables locales .............. +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ....................................................... + + +c + CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) + + CALL filtreg( divgra, jjp1, klevel, 2, 1, .TRUE., 1 ) + CALL grad ( klevel,divgra, ghx , ghy ) + CALL divergf ( klevel, ghx , ghy , divgra ) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/laplacien_gam.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/laplacien_gam.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/laplacien_gam.F (revision 1280) @@ -0,0 +1,53 @@ +! +! $Header$ +! + SUBROUTINE laplacien_gam ( klevel, cuvsga, cvusga, unsaigam , + * unsapolnga, unsapolsga, teta, divgra ) + +c P. Le Van +c +c ************************************************************ +c +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............ variables en arguments .......... +c + INTEGER klevel + REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) + REAL cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1), + * unsapolnga, unsapolsga +c +c ........... variables locales ................. +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ...................................................... + +c +c +c ... cvuscugam = ( cvu/ cu ) ** (- gamdissip ) +c ... cuvscvgam = ( cuv/ cv ) ** (- gamdissip ) calcules dans inigeom .. +c ... unsairegam = 1. / aire ** (- gamdissip ) +c + + CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) +c + CALL grad ( klevel, divgra, ghx, ghy ) +c + CALL diverg_gam ( klevel, cuvsga, cvusga, unsaigam , + * unsapolnga, unsapolsga, ghx , ghy , divgra ) + +c + + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/laplacien_rot.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/laplacien_rot.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/laplacien_rot.F (revision 1280) @@ -0,0 +1,39 @@ +! +! $Header$ +! + SUBROUTINE laplacien_rot ( klevel, rotin, rotout,ghx,ghy ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de ( rotat x nxgrad ) du rotationnel rotin . +c ************************************************************ +c +c klevel et rotin sont des arguments d'entree pour le s-prog +c rotout est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c .......... variables en arguments ............. +c + INTEGER klevel + REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) +c +c .......... variables locales ................ +c + REAL ghy(ip1jm,klevel), ghx(ip1jmp1,klevel) +c ........................................................ +c +c + CALL filtreg ( rotin , jjm, klevel, 2, 1, .FALSE., 1 ) + + CALL nxgrad ( klevel, rotin, ghx , ghy ) + CALL rotatf ( klevel, ghx , ghy , rotout ) +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/laplacien_rotgam.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/laplacien_rotgam.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/laplacien_rotgam.F (revision 1280) @@ -0,0 +1,44 @@ +! +! $Header$ +! + SUBROUTINE laplacien_rotgam ( klevel, rotin, rotout ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de (rotat x nxgrad)_gam du rotationnel rotin .. +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............. variables en arguments ........... +c + INTEGER klevel + REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) +c +c ............ variables locales ............... +c + INTEGER l, ij + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ........................................................ +c +c + + CALL nxgrad_gam ( klevel, rotin, ghx , ghy ) + CALL rotat_nfil ( klevel, ghx , ghy , rotout ) +c + DO l = 1, klevel + DO ij = 1, ip1jm + rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/leapfrog.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/leapfrog.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/leapfrog.F (revision 1280) @@ -0,0 +1,717 @@ +! +! $Id$ +! +c +c + SUBROUTINE leapfrog(ucov,vcov,teta,ps,masse,phis,q,clesphy0, + & time_0) + + +cIM : pour sortir les param. du modele dans un fis. netcdf 110106 +#ifdef CPP_IOIPSL + use IOIPSL +#endif + USE infotrac + USE guide_mod, ONLY : guide_main + USE write_field + IMPLICIT NONE + +c ...... Version du 10/01/98 .......... + +c avec coordonnees verticales hybrides +c avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 ) + +c======================================================================= +c +c Auteur: P. Le Van /L. Fairhead/F.Hourdin +c ------- +c +c Objet: +c ------ +c +c GCM LMD nouvelle grille +c +c======================================================================= +c +c ... Dans inigeom , nouveaux calculs pour les elongations cu , cv +c et possibilite d'appeler une fonction f(y) a derivee tangente +c hyperbolique a la place de la fonction a derivee sinusoidale. + +c ... Possibilite de choisir le shema pour l'advection de +c q , en modifiant iadv dans traceur.def (10/02) . +c +c Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99) +c Pour Van-Leer iadv=10 +c +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissnew.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "temps.h" +#include "control.h" +#include "ener.h" +#include "description.h" +#include "serre.h" +#include "com_io_dyn.h" +#include "iniprint.h" +#include "academic.h" + +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +! #include "clesphys.h" + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + + real zqmin,zqmax + INTEGER nbetatmoy, nbetatdem,nbetat + +c variables dynamiques + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL q(ip1jmp1,llm,nqtot) ! champs advectes + REAL ps(ip1jmp1) ! pression au sol + REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL pks(ip1jmp1) ! exner au sol + REAL pk(ip1jmp1,llm) ! exner au milieu des couches + REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches + REAL masse(ip1jmp1,llm) ! masse d'air + REAL phis(ip1jmp1) ! geopotentiel au sol + REAL phi(ip1jmp1,llm) ! geopotentiel + REAL w(ip1jmp1,llm) ! vitesse verticale + +c variables dynamiques intermediaire pour le transport + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse + +c variables dynamiques au pas -1 + REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm) + REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1) + REAL massem1(ip1jmp1,llm) + +c tendances dynamiques + REAL dv(ip1jm,llm),du(ip1jmp1,llm) + REAL dteta(ip1jmp1,llm),dq(ip1jmp1,llm,nqtot),dp(ip1jmp1) + +c tendances de la dissipation + REAL dvdis(ip1jm,llm),dudis(ip1jmp1,llm) + REAL dtetadis(ip1jmp1,llm) + +c tendances physiques + REAL dvfi(ip1jm,llm),dufi(ip1jmp1,llm) + REAL dtetafi(ip1jmp1,llm),dqfi(ip1jmp1,llm,nqtot),dpfi(ip1jmp1) + +c variables pour le fichier histoire + REAL dtav ! intervalle de temps elementaire + + REAL tppn(iim),tpps(iim),tpn,tps +c + INTEGER itau,itaufinp1,iav +! INTEGER iday ! jour julien + REAL time + + REAL SSUM + REAL time_0 , finvmaold(ip1jmp1,llm) + +cym LOGICAL lafin + LOGICAL :: lafin=.false. + INTEGER ij,iq,l + INTEGER ik + + real time_step, t_wrt, t_ops + +! REAL rdayvrai,rdaym_ini +! jD_cur: jour julien courant +! jH_cur: heure julienne courante + REAL :: jD_cur, jH_cur + INTEGER :: an, mois, jour + REAL :: secondes + + LOGICAL first,callinigrads +cIM : pour sortir les param. du modele dans un fis. netcdf 110106 + save first + data first/.true./ + real dt_cum + character*10 infile + integer zan, tau0, thoriid + integer nid_ctesGCM + save nid_ctesGCM + real degres + real rlong(iip1), rlatg(jjp1) + real zx_tmp_2d(iip1,jjp1) + integer ndex2d(iip1*jjp1) + logical ok_sync + parameter (ok_sync = .true.) + + data callinigrads/.true./ + character*10 string10 + + REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm) + REAL :: flxw(ip1jmp1,llm) ! flux de masse verticale + +c+jld variables test conservation energie + REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm) +C Tendance de la temp. potentiel d (theta)/ d t due a la +C tansformation d'energie cinetique en energie thermique +C cree par la dissipation + REAL dtetaecdt(ip1jmp1,llm) + REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL vnat(ip1jm,llm),unat(ip1jmp1,llm) + REAL d_h_vcol, d_qt, d_qw, d_ql, d_ec + CHARACTER*15 ztit +!IM INTEGER ip_ebil_dyn ! PRINT level for energy conserv. diag. +!IM SAVE ip_ebil_dyn +!IM DATA ip_ebil_dyn/0/ +c-jld + + character*80 dynhist_file, dynhistave_file + character(len=20) :: modname + character*80 abort_message + + logical dissip_conservative + save dissip_conservative + data dissip_conservative/.true./ + + LOGICAL prem + save prem + DATA prem/.true./ + INTEGER testita + PARAMETER (testita = 9) + + logical , parameter :: flag_verif = .false. + + + integer itau_w ! pas de temps ecriture = itap + itau_phy + + + itaufin = nday*day_step + itaufinp1 = itaufin +1 + modname="leapfrog" + + + itau = 0 +c$$$ iday = day_ini+itau/day_step +c$$$ time = FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0 +c$$$ IF(time.GT.1.) THEN +c$$$ time = time-1. +c$$$ iday = iday+1 +c$$$ ENDIF + + +c----------------------------------------------------------------------- +c On initialise la pression et la fonction d'Exner : +c -------------------------------------------------- + + dq=0. + CALL pression ( ip1jmp1, ap, bp, ps, p ) + CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf ) + +c----------------------------------------------------------------------- +c Debut de l'integration temporelle: +c ---------------------------------- + + 1 CONTINUE + + jD_cur = jD_ref + day_ini - day_ref + int (itau * dtvr / daysec) + jH_cur = jH_ref + & + & (itau * dtvr / daysec - int(itau * dtvr / daysec)) + + +#ifdef CPP_IOIPSL + if (ok_guide) then + call guide_main(itau,ucov,vcov,teta,q,masse,ps) + endif +#endif + + +c +c IF( MOD( itau, 10* day_step ).EQ.0 ) THEN +c CALL test_period ( ucov,vcov,teta,q,p,phis ) +c PRINT *,' ---- Test_period apres continue OK ! -----', itau +c ENDIF +c + +! Save fields obtained at previous time step as '...m1' + CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 ) + CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 ) + CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 ) + CALL SCOPY( ijp1llm,masse, 1, massem1, 1 ) + CALL SCOPY( ip1jmp1, ps , 1, psm1 , 1 ) + + forward = .TRUE. + leapf = .FALSE. + dt = dtvr + +c ... P.Le Van .26/04/94 .... + + CALL SCOPY ( ijp1llm, masse, 1, finvmaold, 1 ) + CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 ) + +! Ehouarn: what is this for? zqmin & zqmax are not used anyway ... +! call minmax(ijp1llm,q(:,:,3),zqmin,zqmax) + + 2 CONTINUE + +c----------------------------------------------------------------------- + +c date: +c ----- + + +c gestion des appels de la physique et des dissipations: +c ------------------------------------------------------ +c +c ... P.Le Van ( 6/02/95 ) .... + + apphys = .FALSE. + statcl = .FALSE. + conser = .FALSE. + apdiss = .FALSE. + + IF( purmats ) THEN + IF( MOD(itau,iconser) .EQ.0.AND. forward ) conser = .TRUE. + IF( MOD(itau,idissip ).EQ.0.AND..NOT.forward ) apdiss = .TRUE. + IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward + s .and. iflag_phys.EQ.1 ) apphys = .TRUE. + ELSE + IF( MOD(itau ,iconser) .EQ. 0 ) conser = .TRUE. + IF( MOD(itau+1,idissip) .EQ. 0 ) apdiss = .TRUE. + IF( MOD(itau+1,iphysiq).EQ.0.AND.iflag_phys.EQ.1) apphys=.TRUE. + END IF + +c----------------------------------------------------------------------- +c calcul des tendances dynamiques: +c -------------------------------- + + CALL geopot ( ip1jmp1, teta , pk , pks, phis , phi ) + + time = jD_cur + jH_cur + CALL caldyn + $ ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , + $ phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time ) + + +c----------------------------------------------------------------------- +c calcul des tendances advection des traceurs (dont l'humidite) +c ------------------------------------------------------------- + + IF( forward. OR . leapf ) THEN + + CALL caladvtrac(q,pbaru,pbarv, + * p, masse, dq, teta, + . flxw, pk) + + IF (offline) THEN +Cmaf stokage du flux de masse pour traceurs OFF-LINE + +#ifdef CPP_IOIPSL + CALL fluxstokenc(pbaru,pbarv,masse,teta,phi,phis, + . dtvr, itau) +#endif + + + ENDIF ! of IF (offline) +c + ENDIF ! of IF( forward. OR . leapf ) + + +c----------------------------------------------------------------------- +c integrations dynamique et traceurs: +c ---------------------------------- + + + CALL integrd ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 , + $ dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis , + $ finvmaold ) + + +c .P.Le Van (26/04/94 ajout de finvpold dans l'appel d'integrd) +c +c----------------------------------------------------------------------- +c calcul des tendances physiques: +c ------------------------------- +c ######## P.Le Van ( Modif le 6/02/95 ) ########### +c + IF( purmats ) THEN + IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE. + ELSE + IF( itau+1. EQ. itaufin ) lafin = .TRUE. + ENDIF +c +c + IF( apphys ) THEN +c +c ....... Ajout P.Le Van ( 17/04/96 ) ........... +c + + CALL pression ( ip1jmp1, ap, bp, ps, p ) + CALL exner_hyb( ip1jmp1, ps, p,alpha,beta,pks, pk, pkf ) + +! rdaym_ini = itau * dtvr / daysec +! rdayvrai = rdaym_ini + day_ini + jD_cur = jD_ref + day_ini - day_ref + $ + int (itau * dtvr / daysec) + jH_cur = jH_ref + & + & (itau * dtvr / daysec - int(itau * dtvr / daysec)) +! write(lunout,*)'itau, jD_cur = ', itau, jD_cur, jH_cur +! call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes) +! write(lunout,*)'current date = ',an, mois, jour, secondes + +c rajout debug +c lafin = .true. + + +c Inbterface avec les routines de phylmd (phymars ... ) +c ----------------------------------------------------- + +c+jld + +c Diagnostique de conservation de l'énergie : initialisation + IF (ip_ebil_dyn.ge.1 ) THEN + ztit='bil dyn' +! Ehouarn: be careful, diagedyn is Earth-specific (includes ../phylmd/..)! + IF (planet_type.eq."earth") THEN + CALL diagedyn(ztit,2,1,1,dtphys + & , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) + ENDIF + ENDIF ! of IF (ip_ebil_dyn.ge.1 ) +c-jld +#ifdef CPP_IOIPSL +cIM : pour sortir les param. du modele dans un fis. netcdf 110106 + IF (first) THEN + first=.false. +#include "ini_paramLMDZ_dyn.h" + ENDIF +c +#include "write_paramLMDZ_dyn.h" +c +#endif +! #endif of #ifdef CPP_IOIPSL + CALL calfis( lafin , jD_cur, jH_cur, + $ ucov,vcov,teta,q,masse,ps,p,pk,phis,phi , + $ du,dv,dteta,dq, + $ flxw, + $ clesphy0, dufi,dvfi,dtetafi,dqfi,dpfi ) + + IF (ok_strato) THEN + CALL top_bound( vcov,ucov,teta,masse,dufi,dvfi,dtetafi) + ENDIF + +c ajout des tendances physiques: +c ------------------------------ + CALL addfi( dtphys, leapf, forward , + $ ucov, vcov, teta , q ,ps , + $ dufi, dvfi, dtetafi , dqfi ,dpfi ) +c +c Diagnostique de conservation de l'énergie : difference + IF (ip_ebil_dyn.ge.1 ) THEN + ztit='bil phys' + IF (planet_type.eq."earth") THEN + CALL diagedyn(ztit,2,1,1,dtphys + & , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) + ENDIF + ENDIF ! of IF (ip_ebil_dyn.ge.1 ) + + ENDIF ! of IF( apphys ) + + IF(iflag_phys.EQ.2) THEN ! "Newtonian" case +c Calcul academique de la physique = Rappel Newtonien + friction +c -------------------------------------------------------------- + teta(:,:)=teta(:,:) + s -iphysiq*dtvr*(teta(:,:)-tetarappel(:,:))/taurappel + call friction(ucov,vcov,iphysiq*dtvr) + ENDIF + + +c-jld + + CALL pression ( ip1jmp1, ap, bp, ps, p ) + CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf ) + + +c----------------------------------------------------------------------- +c dissipation horizontale et verticale des petites echelles: +c ---------------------------------------------------------- + + IF(apdiss) THEN + + +c calcul de l'energie cinetique avant dissipation + call covcont(llm,ucov,vcov,ucont,vcont) + call enercin(vcov,ucov,vcont,ucont,ecin0) + +c dissipation + CALL dissip(vcov,ucov,teta,p,dvdis,dudis,dtetadis) + ucov=ucov+dudis + vcov=vcov+dvdis +c teta=teta+dtetadis + + +c------------------------------------------------------------------------ + if (dissip_conservative) then +C On rajoute la tendance due a la transform. Ec -> E therm. cree +C lors de la dissipation + call covcont(llm,ucov,vcov,ucont,vcont) + call enercin(vcov,ucov,vcont,ucont,ecin) + dtetaecdt= (ecin0-ecin)/ pk +c teta=teta+dtetaecdt + dtetadis=dtetadis+dtetaecdt + endif + teta=teta+dtetadis +c------------------------------------------------------------------------ + + +c ....... P. Le Van ( ajout le 17/04/96 ) ........... +c ... Calcul de la valeur moyenne, unique de h aux poles ..... +c + + DO l = 1, llm + DO ij = 1,iim + tppn(ij) = aire( ij ) * teta( ij ,l) + tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + teta( ij ,l) = tpn + teta(ij+ip1jm,l) = tps + ENDDO + ENDDO + + DO ij = 1,iim + tppn(ij) = aire( ij ) * ps ( ij ) + tpps(ij) = aire(ij+ip1jm) * ps (ij+ip1jm) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + ps( ij ) = tpn + ps(ij+ip1jm) = tps + ENDDO + + + END IF ! of IF(apdiss) + +c ajout debug +c IF( lafin ) then +c abort_message = 'Simulation finished' +c call abort_gcm(modname,abort_message,0) +c ENDIF + +c ******************************************************************** +c ******************************************************************** +c .... fin de l'integration dynamique et physique pour le pas itau .. +c ******************************************************************** +c ******************************************************************** + +c preparation du pas d'integration suivant ...... + + IF ( .NOT.purmats ) THEN +c ........................................................ +c .............. schema matsuno + leapfrog .............. +c ........................................................ + + IF(forward. OR. leapf) THEN + itau= itau + 1 +c$$$ iday= day_ini+itau/day_step +c$$$ time= FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0 +c$$$ IF(time.GT.1.) THEN +c$$$ time = time-1. +c$$$ iday = iday+1 +c$$$ ENDIF + ENDIF + + + IF( itau. EQ. itaufinp1 ) then + if (flag_verif) then + write(79,*) 'ucov',ucov + write(80,*) 'vcov',vcov + write(81,*) 'teta',teta + write(82,*) 'ps',ps + write(83,*) 'q',q + WRITE(85,*) 'q1 = ',q(:,:,1) + WRITE(86,*) 'q3 = ',q(:,:,3) + endif + + abort_message = 'Simulation finished' + + call abort_gcm(modname,abort_message,0) + ENDIF +c----------------------------------------------------------------------- +c ecriture du fichier histoire moyenne: +c ------------------------------------- + + IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN + IF(itau.EQ.itaufin) THEN + iav=1 + ELSE + iav=0 + ENDIF + + IF (ok_dynzon) THEN +#ifdef CPP_IOIPSL +! CALL writedynav(histaveid, itau,vcov , +! , ucov,teta,pk,phi,q,masse,ps,phis) + CALL bilan_dyn (2,dtvr*iperiod,dtvr*day_step*periodav, + , ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) +#endif + END IF + + ENDIF + +c----------------------------------------------------------------------- +c ecriture de la bande histoire: +c ------------------------------ + + IF( MOD(itau,iecri ).EQ.0) THEN +c IF( MOD(itau,iecri*day_step).EQ.0) THEN + + nbetat = nbetatdem + CALL geopot(ip1jmp1,teta,pk,pks,phis,phi) + unat=0. + do l=1,llm + unat(iip2:ip1jm,l)=ucov(iip2:ip1jm,l)/cu(iip2:ip1jm) + vnat(:,l)=vcov(:,l)/cv(:) + enddo +#ifdef CPP_IOIPSL +c CALL writehist(histid,histvid,itau,vcov, +c & ucov,teta,phi,q,masse,ps,phis) +#endif +! For some Grads outputs of fields + if (output_grads_dyn) then +#include "write_grads_dyn.h" + endif + + ENDIF ! of IF(MOD(itau,iecri).EQ.0) + + IF(itau.EQ.itaufin) THEN + + + if (planet_type.eq."earth") then +! Write an Earth-format restart file + CALL dynredem1("restart.nc",0.0, + & vcov,ucov,teta,q,masse,ps) + endif ! of if (planet_type.eq."earth") + + CLOSE(99) + ENDIF ! of IF (itau.EQ.itaufin) + +c----------------------------------------------------------------------- +c gestion de l'integration temporelle: +c ------------------------------------ + + IF( MOD(itau,iperiod).EQ.0 ) THEN + GO TO 1 + ELSE IF ( MOD(itau-1,iperiod). EQ. 0 ) THEN + + IF( forward ) THEN +c fin du pas forward et debut du pas backward + + forward = .FALSE. + leapf = .FALSE. + GO TO 2 + + ELSE +c fin du pas backward et debut du premier pas leapfrog + + leapf = .TRUE. + dt = 2.*dtvr + GO TO 2 + END IF ! of IF (forward) + ELSE + +c ...... pas leapfrog ..... + + leapf = .TRUE. + dt = 2.*dtvr + GO TO 2 + END IF ! of IF (MOD(itau,iperiod).EQ.0) + ! ELSEIF (MOD(itau-1,iperiod).EQ.0) + + ELSE ! of IF (.not.purmats) + +c ........................................................ +c .............. schema matsuno ............... +c ........................................................ + IF( forward ) THEN + + itau = itau + 1 +c$$$ iday = day_ini+itau/day_step +c$$$ time = FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0 +c$$$ +c$$$ IF(time.GT.1.) THEN +c$$$ time = time-1. +c$$$ iday = iday+1 +c$$$ ENDIF + + forward = .FALSE. + IF( itau. EQ. itaufinp1 ) then + abort_message = 'Simulation finished' + call abort_gcm(modname,abort_message,0) + ENDIF + GO TO 2 + + ELSE ! of IF(forward) + + IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN + IF(itau.EQ.itaufin) THEN + iav=1 + ELSE + iav=0 + ENDIF + + IF (ok_dynzon) THEN +#ifdef CPP_IOIPSL +! CALL writedynav(histaveid, itau,vcov , +! , ucov,teta,pk,phi,q,masse,ps,phis) + CALL bilan_dyn (2,dtvr*iperiod,dtvr*day_step*periodav, + , ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) +#endif + END IF + + ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) + + IF(MOD(itau,iecri ).EQ.0) THEN +c IF(MOD(itau,iecri*day_step).EQ.0) THEN + nbetat = nbetatdem + CALL geopot(ip1jmp1,teta,pk,pks,phis,phi) + unat=0. + do l=1,llm + unat(iip2:ip1jm,l)=ucov(iip2:ip1jm,l)/cu(iip2:ip1jm) + vnat(:,l)=vcov(:,l)/cv(:) + enddo +#ifdef CPP_IOIPSL +c CALL writehist( histid, histvid, itau,vcov , +c & ucov,teta,phi,q,masse,ps,phis) +#endif +! For some Grads outputs + if (output_grads_dyn) then +#include "write_grads_dyn.h" + endif + + ENDIF ! of IF(MOD(itau,iecri ).EQ.0) + + IF(itau.EQ.itaufin) THEN + if (planet_type.eq."earth") then + CALL dynredem1("restart.nc",0.0, + & vcov,ucov,teta,q,masse,ps) + endif ! of if (planet_type.eq."earth") + ENDIF ! of IF(itau.EQ.itaufin) + + forward = .TRUE. + GO TO 1 + + ENDIF ! of IF (forward) + + END IF ! of IF(.not.purmats) + + STOP + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/limit_netcdf.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/limit_netcdf.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/limit_netcdf.F (revision 1280) @@ -0,0 +1,1334 @@ +! +! $Id$ +! +C +C + SUBROUTINE limit_netcdf(interbar, extrap, oldice, masque) +#ifdef CPP_EARTH +! This routine is designed to work for Earth + USE dimphy + use phys_state_var_mod , ONLY : pctsrf + IMPLICIT none +c +c------------------------------------------------------------- +C Author : L. Fairhead +C Date : 27/01/94 +C Objet : Construction des fichiers de conditions aux limites +C pour le nouveau +C modele a partir de fichiers de climatologie. Les deux +C grilles doivent etre regulieres +c +c Modifie par z.x.li (le23mars1994) +c Modifie par L. Fairhead (fairhead@lmd.jussieu.fr) septembre 1999 +c pour lecture netcdf dans LMDZ.3.3 +c Modifie par P;Le Van , juillet 2001 +c------------------------------------------------------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "control.h" +#include "logic.h" +#include "netcdf.inc" +#include "comvert.h" +#include "comgeom2.h" +#include "comconst.h" +cy#include "dimphy.h" +#include "indicesol.h" +#include "iniprint.h" +c +c----------------------------------------------------------------------- + LOGICAL interbar, extrap, oldice + + REAL phy_nat(klon,360), phy_nat0(klon) + REAL phy_alb(klon,360) + REAL phy_sst(klon,360) + REAL phy_bil(klon,360) + REAL phy_rug(klon,360) + REAL phy_ice(klon) +c + real pctsrf_t(klon,nbsrf,360) + + REAL verif + + REAL masque(iip1,jjp1) + REAL mask(iim,jjp1) +CPB +C newlmt indique l'utilisation de la sous-maille fractionnelle +C tandis que l'ancien codage utilise l'indicateur du sol (0,1,2,3) + LOGICAL newlmt, fracterre + PARAMETER(newlmt=.TRUE.) + PARAMETER(fracterre = .TRUE.) + +C Declarations pour le champ de depart + INTEGER imdep, jmdep,lmdep + INTEGER tbid + PARAMETER ( tbid = 60 ) ! >52 semaines + REAL timecoord(tbid) +c + REAL , ALLOCATABLE :: dlon_msk(:), dlat_msk(:) + REAL , ALLOCATABLE :: lonmsk_ini(:), latmsk_ini(:) + REAL , ALLOCATABLE :: dlon(:), dlat(:) + REAL , ALLOCATABLE :: dlon_ini(:), dlat_ini(:) + REAL , ALLOCATABLE :: champ_msk(:), champ(:) + REAL , ALLOCATABLE :: work(:,:) + + CHARACTER*25 title + +C Declarations pour le champ interpole 2D + REAL champint(iim,jjp1) + real chmin,chmax + +C Declarations pour le champ interpole 3D + REAL champtime(iim,jjp1,tbid) + REAL timeyear(tbid) + REAL champan(iip1,jjp1,366) + +C Declarations pour l'inteprolation verticale + REAL ax(tbid), ay(tbid) + REAL by + REAL yder(tbid) + + + INTEGER ierr + INTEGER dimfirst(3) + INTEGER dimlast(3) +c + INTEGER nid, ndim, ntim + INTEGER dims(2), debut(2), epais(2) + INTEGER id_tim + INTEGER id_NAT, id_SST, id_BILS, id_RUG, id_ALB +CPB + INTEGER id_FOCE, id_FSIC, id_FTER, id_FLIC + + INTEGER i, j, k, l, ji +c declarations pour lecture glace de mer + INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret + INTEGER :: itaul(1), fid + REAL :: lev(1), date, dt + REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic + REAL, ALLOCATABLE, DIMENSION(:) :: dlon_lic, dlat_lic + REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic + REAL :: flic_tmp(iip1, jjp1) + +c Diverses variables locales + REAL time +! pour la lecture du fichier masque ocean + integer :: nid_o2a + logical :: couple = .false. + INTEGER :: iml_omask, jml_omask + REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_omask, lat_omask + REAL, ALLOCATABLE, DIMENSION(:) :: dlon_omask, dlat_omask + REAL, ALLOCATABLE, DIMENSION (:,:) :: ocemask, ocetmp + real, dimension(klon) :: ocemask_fi + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0 ( longcles ) +#include "serre.h" + INTEGER ncid,varid,ndimid(4),dimid + character*30 namedim + CHARACTER*80 :: varname + +cIM28/02/2002 <== PM + REAL tmidmonth(12) + SAVE tmidmonth + DATA tmidmonth/15,45,75,105,135,165,195,225,255,285,315,345/ + +c initialisations: + CALL conf_gcm( 99, .TRUE. , clesphy0 ) + + + pi = 4. * ATAN(1.) + rad = 6 371 229. + omeg = 4.* ASIN(1.)/(24.*3600.) + g = 9.8 + daysec = 86400. + kappa = 0.2857143 + cpp = 1004.70885 + dtvr = daysec/FLOAT(day_step) + CALL inigeom +c +C Traitement du relief au sol +c + write(*,*) 'Traitement du relief au sol pour fabriquer masque' + ierr = NF_OPEN('Relief.nc', NF_NOWRITE, ncid) + + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ierr = NF_INQ_VARID(ncid,'RELIEF',varid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', imdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( lonmsk_ini(imdep) ) + ALLOCATE( dlon_msk(imdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,lonmsk_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,lonmsk_ini) +#endif + +c + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', jmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( latmsk_ini(jmdep) ) + ALLOCATE( dlat_msk(jmdep) ) + ALLOCATE( champ_msk(imdep*jmdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,latmsk_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,latmsk_ini) +#endif +c + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,varid,champ_msk) +#else + ierr = NF_GET_VAR_REAL(ncid,varid,champ_msk) +#endif +c + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +c + title='RELIEF' + + CALL conf_dat2d(title,imdep, jmdep, lonmsk_ini, latmsk_ini, + . dlon_msk, dlat_msk, champ_msk, interbar ) + + DO i = 1, iim + DO j = 1, jjp1 + mask(i,j) = masque(i,j) + ENDDO + ENDDO + WRITE(*,*) 'MASK:' + WRITE(*,'(96i1)')INT(mask) + ierr = NF_CLOSE(ncid) +c +c +C Traitement de la rugosite +c + PRINT*, 'Traitement de la rugosite' + ierr = NF_OPEN('Rugos.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ierr = NF_INQ_VARID(ncid,'RUGOS',varid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', imdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( dlon_ini(imdep) ) + ALLOCATE( dlon(imdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', jmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( dlat_ini(jmdep) ) + ALLOCATE( dlat(jmdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', lmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +c + ALLOCATE( champ(imdep*jmdep) ) + + DO 200 l = 1, lmdep + dimfirst(1) = 1 + dimfirst(2) = 1 + dimfirst(3) = l +c + dimlast(1) = imdep + dimlast(2) = jmdep + dimlast(3) = 1 +c + PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l) + print*,dimfirst,dimlast +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ) +#else + ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + title = 'Rugosite Amip ' +c + CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini, + . dlon, dlat, champ, interbar ) + + IF ( interbar ) THEN + DO j = 1, imdep * jmdep + champ(j) = LOG(champ(j)) + ENDDO + + IF( l.EQ.1 ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour la rugosite $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + ENDIF + CALL inter_barxy ( imdep,jmdep -1,dlon,dlat,champ , + , iim,jjm,rlonu,rlatv, jjp1,champint ) + DO j=1,jjp1 + DO i=1,iim + champint(i,j)=EXP(champint(i,j)) + ENDDO + ENDDO + + DO j = 1, jjp1 + DO i = 1, iim + IF(NINT(mask(i,j)).NE.1) THEN + champint( i,j ) = 0.001 + ENDIF + ENDDO + ENDDO + ELSE + CALL rugosite(imdep, jmdep, dlon, dlat, champ, + . iim, jjp1, rlonv, rlatu, champint, mask) + ENDIF + DO j = 1,jjp1 + DO i = 1, iim + champtime (i,j,l) = champint(i,j) + ENDDO + ENDDO +200 CONTINUE +c + DO l = 1, lmdep + timeyear(l) = timecoord(l) + ENDDO + + PRINT 222, timeyear(:lmdep) +222 FORMAT(2x,' Time year ',10f6.1) +c + + PRINT*, 'Interpolation temporelle dans l annee' + + DO j = 1, jjp1 + DO i = 1, iim + DO l = 1, lmdep + ax(l) = timeyear(l) + ay(l) = champtime (i,j,l) + ENDDO + CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder) + DO k = 1, 360 + time = FLOAT(k-1) + CALL SPLINT(ax,ay,yder,lmdep,time,by) + champan(i,j,k) = by + ENDDO + ENDDO + ENDDO + DO k = 1, 360 + DO j = 1, jjp1 + champan(iip1,j,k) = champan(1,j,k) + ENDDO + IF ( k.EQ.10 ) THEN + DO j = 1, jjp1 + CALL minmax( iip1,champan(1,j,10),chmin,chmax ) + PRINT *,' Rugosite au temps 10 ', chmin,chmax,j + ENDDO + ENDIF + ENDDO +c + DO k = 1, 360 + CALL gr_dyn_fi(1,iip1,jjp1,klon,champan(1,1,k), phy_rug(1,k)) + ENDDO +c + ierr = NF_CLOSE(ncid) + + DEALLOCATE( dlon ) + DEALLOCATE( dlon_ini ) + DEALLOCATE( dlat ) + DEALLOCATE( dlat_ini ) + DEALLOCATE( champ ) +c +c +C Traitement de la glace oceanique +c + PRINT*, 'Traitement de la glace oceanique' + + ierr = NF_OPEN('amipbc_sic_1x1.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) THEN + ierr = NF_OPEN('amipbc_sic_1x1_clim.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) THEN + print *, NF_STRERROR(ierr) + STOP + endif + ENDIF + +cIM22/02/2002 +cIM07/03/2002 AMIP.nc & amip79to95.nc +cIM ierr = NF_INQ_VARID(ncid,'SEA_ICE',varid) +cIM07/03/2002 amipbc_sic_1x1_clim.nc & amipbc_sic_1x1.nc + ierr = NF_INQ_VARID(ncid,'sicbcs',varid) +cIM22/02/2002 + if (ierr.ne.0) then + print *, NF_STRERROR(ierr),'sicbcs' + STOP + ENDIF + ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', imdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE ( dlon_ini(imdep) ) + ALLOCATE ( dlon(imdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, jmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE ( dlat_ini(jmdep) ) + ALLOCATE ( dlat(jmdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, lmdep +cIM28/02/2002 +cPM28/02/2002 : nouvelle coord temporelle fichiers AMIP pas en jours +c Ici on suppose qu'on a 12 mois (de 30 jours). + IF (lmdep.NE.12) THEN + print *, 'Unknown AMIP file: not 12 months ?' + STOP + ENDIF +cIM28/02/2002 + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +c + ALLOCATE ( champ(imdep*jmdep) ) + + DO l = 1, lmdep + dimfirst(1) = 1 + dimfirst(2) = 1 + dimfirst(3) = l +c + dimlast(1) = imdep + dimlast(2) = jmdep + dimlast(3) = 1 +c + PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l) +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ) +#else + ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + title = 'Sea-ice Amip ' +c + CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini, + . dlon, dlat, champ, interbar ) +c + IF( oldice ) THEN + CALL sea_ice(imdep, jmdep, dlon, dlat, champ, + . iim, jjp1, rlonv, rlatu, champint ) + ELSEIF ( interbar ) THEN + IF( l.EQ.1 ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour Sea-ice Amip $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + ENDIF +cIM07/03/2002 +cIM22/02/2002 : Sea-ice Amip entre 0. et 1. +cIM PRINT*,'SUB. limit_netcdf.F IM : Sea-ice et SST Amip_new clim' +cIM DO j = 1, imdep * jmdep +cIM28/02/2002 <==PM champ(j) = champ(j)/100. +cIM14/03/2002 champ(j) = max(0.0,(min(1.0, (champ(j)/100.) ))) +cIM champ(j) = amax1(0.0,(amin1(1.0, (champ(j)/100.) ))) +cIM ENDDO +cIM22/02/2002 + CALL inter_barxy ( imdep,jmdep -1,dlon, dlat , + , champ, iim, jjm, rlonu, rlatv, jjp1, champint ) + ELSE + CALL sea_ice(imdep, jmdep, dlon, dlat, champ, + . iim, jjp1, rlonv, rlatu, champint ) + ENDIF + DO j = 1,jjp1 + DO i = 1, iim + champtime (i,j,l) = champint(i,j) + ENDDO + ENDDO + ENDDO +c + DO l = 1, lmdep +cIM28/02/2002 <== PM timeyear(l) = timecoord(l) +cIM timeyear(l) = timecoord(l) +cIM07/03/2002 + timeyear(l) = tmidmonth(l) + ENDDO + PRINT 222, timeyear(:lmdep) +c + PRINT*, 'Interpolation temporelle' + DO j = 1, jjp1 + DO i = 1, iim + DO l = 1, lmdep + ax(l) = timeyear(l) + ay(l) = champtime (i,j,l) + ENDDO + CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder) + DO k = 1, 360 + time = FLOAT(k-1) + CALL SPLINT(ax,ay,yder,lmdep,time,by) + champan(i,j,k) = by + ENDDO + ENDDO + ENDDO + DO k = 1, 360 + DO j = 1, jjp1 + champan(iip1, j, k) = champan(1, j, k) + ENDDO + IF ( k.EQ.10 ) THEN + DO j = 1, jjp1 + CALL minmax( iip1,champan(1,j,10),chmin,chmax ) + PRINT *,' Sea ice au temps 10 ', chmin,chmax,j + ENDDO + ENDIF + ENDDO +c +cIM14/03/2002 : Sea-ice Amip entre 0. et 1. + PRINT*,'SUB. limit_netcdf.F IM : Sea-ice Amipbc ' + DO k = 1, 360 + DO j = 1, jjp1 + DO i = 1, iim + champan(i, j, k) = + $ amax1(0.0,(amin1(1.0,(champan(i, j, k)/100.)))) + ENDDO + champan(iip1, j, k) = champan(1, j, k) + ENDDO + ENDDO +cIM14/03/2002 + + DO k = 1, 360 + CALL gr_dyn_fi(1, iip1, jjp1, klon, + . champan(1,1,k), phy_ice) + IF ( newlmt) THEN + +CPB en attendant de mettre fraction de terre +c + WHERE(phy_ice(1:klon) .GE. 1.) phy_ice(1 : klon) = 1. + WHERE(phy_ice(1:klon) .LT. EPSFRA) phy_ice(1 : klon) = 0. +c + IF (fracterre ) THEN +c WRITE(*,*) 'passe dans cas fracterre' + pctsrf_t(:,is_ter,k) = pctsrf(:,is_ter) + pctsrf_t(:,is_lic,k) = pctsrf(:,is_lic) + pctsrf_t(1:klon,is_sic,k) = phy_ice(1:klon) + $ - pctsrf_t(1:klon,is_lic,k) +c Il y a des cas ou il y a de la glace dans landiceref et pas dans AMIP + WHERE (pctsrf_t(1:klon,is_sic,k) .LE. 0) + pctsrf_t(1:klon,is_sic,k) = 0. + END WHERE + WHERE( 1. - zmasq(1:klon) .LT. EPSFRA) + pctsrf_t(1:klon,is_sic,k) = 0. + pctsrf_t(1:klon,is_oce,k) = 0. + END WHERE + DO i = 1, klon + IF ( 1. - zmasq(i) .GT. EPSFRA) THEN + IF ( pctsrf_t(i,is_sic,k) .GE. 1 - zmasq(i)) THEN + pctsrf_t(i,is_sic,k) = 1 - zmasq(i) + pctsrf_t(i,is_oce,k) = 0. + ELSE + pctsrf_t(i,is_oce,k) = 1 - zmasq(i) + $ - pctsrf_t(i,is_sic,k) + IF (pctsrf_t(i,is_oce,k) .LT. EPSFRA) THEN + pctsrf_t(i,is_oce,k) = 0. + pctsrf_t(i,is_sic,k) = 1 - zmasq(i) + ENDIF + ENDIF + ENDIF + if (pctsrf_t(i,is_oce,k) .lt. 0.) then + WRITE(*,*) 'pb sous maille au point : i,k ' + $ , i,k,pctsrf_t(:,is_oce,k) + ENDIF + IF ( abs( pctsrf_t(i, is_ter,k) + pctsrf_t(i, is_lic,k) + + $ pctsrf_t(i, is_oce,k) + pctsrf_t(i, is_sic,k) - 1.) + $ .GT. EPSFRA) THEN + WRITE(*,*) 'physiq : pb sous surface au point ', i, + $ pctsrf_t(i, 1 : nbsrf,k), phy_ice(i) + ENDIF + END DO + ELSE + DO i = 1, klon + pctsrf_t(i,is_ter,k) = pctsrf(i,is_ter) + IF (NINT(pctsrf(i,is_ter)).EQ.1 ) THEN + pctsrf_t(i,is_sic,k) = 0. + pctsrf_t(i,is_oce,k) = 0. + IF(phy_ice(i) .GE. 1.e-5) THEN + pctsrf_t(i,is_lic,k) = phy_ice(i) + pctsrf_t(i,is_ter,k) = pctsrf_t(i,is_ter,k) + . - pctsrf_t(i,is_lic,k) + ELSE + pctsrf_t(i,is_lic,k) = 0. + ENDIF + ELSE + pctsrf_t(i,is_lic,k) = 0. + IF(phy_ice(i) .GE. 1.e-5) THEN + pctsrf_t(i,is_ter,k) = 0. + pctsrf_t(i,is_sic,k) = phy_ice(i) + pctsrf_t(i,is_oce,k) = 1. - pctsrf_t(i,is_sic,k) + ELSE + pctsrf_t(i,is_sic,k) = 0. + pctsrf_t(i,is_oce,k) = 1. + ENDIF + ENDIF + verif = pctsrf_t(i,is_ter,k) + + . pctsrf_t(i,is_oce,k) + + . pctsrf_t(i,is_sic,k) + + . pctsrf_t(i,is_lic,k) + IF ( verif .LT. 1. - 1.e-5 .OR. + $ verif .GT. 1 + 1.e-5) THEN + WRITE(*,*) 'pb sous maille au point : i,k,verif ' + $ , i,k,verif + ENDIF + END DO + ENDIF + ELSE + DO i = 1, klon + phy_nat(i,k) = phy_nat0(i) + IF ( (phy_ice(i) - 0.5).GE.1.e-5 ) THEN + IF (NINT(phy_nat0(i)).EQ.0) THEN + phy_nat(i,k) = 3.0 + ELSE + phy_nat(i,k) = 2.0 + ENDIF + ENDIF + IF( NINT(phy_nat(i,k)).EQ.0 ) THEN + IF ( phy_rug(i,k).NE.0.001 ) phy_rug(i,k) = 0.001 + ENDIF + END DO + ENDIF + ENDDO +c + + ierr = NF_CLOSE(ncid) +c + DEALLOCATE( dlon ) + DEALLOCATE( dlon_ini ) + DEALLOCATE( dlat ) + DEALLOCATE( dlat_ini ) + DEALLOCATE( champ ) + +477 continue +c +C Traitement de la sst +c + PRINT*, 'Traitement de la sst' +c ierr = NF_OPEN('AMIP_SST.nc', NF_NOWRITE, ncid) + ierr = NF_OPEN('amipbc_sst_1x1.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) THEN + ierr = NF_OPEN('amipbc_sst_1x1_clim.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) THEN + print *, NF_STRERROR(ierr) + STOP + endif + ENDIF + +cIM22/02/2002 +cIM ierr = NF_INQ_VARID(ncid,'SST',varid) + ierr = NF_INQ_VARID(ncid,'tosbcs',varid) +cIM22/02/2002 + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable SST ', namedim,'dimension ', imdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( dlon_ini(imdep) ) + ALLOCATE( dlon(imdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini) +#endif + + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable SST ', namedim, 'dimension ', jmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( dlat_ini(jmdep) ) + ALLOCATE( dlat(jmdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', lmdep +cIM28/02/2002 +cPM28/02/2002 : nouvelle coord temporelle fichiers AMIP pas en jours +c Ici on suppose qu'on a 12 mois (de 30 jours). + IF (lmdep.NE.12) THEN + print *, 'Unknown AMIP file: not 12 months ?' + STOP + ENDIF +cIM28/02/2002 + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( champ(imdep*jmdep) ) + IF( extrap ) THEN + ALLOCATE ( work(imdep,jmdep) ) + ENDIF +c + DO l = 1, lmdep + dimfirst(1) = 1 + dimfirst(2) = 1 + dimfirst(3) = l +c + dimlast(1) = imdep + dimlast(2) = jmdep + dimlast(3) = 1 +c + PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l) +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ) +#else + ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + title='Sst Amip' +c + CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini, + . dlon, dlat, champ, interbar ) + IF ( extrap ) THEN + CALL extrapol(champ, imdep, jmdep, 999999.,.TRUE.,.TRUE.,2,work) + ENDIF +c + + IF ( interbar ) THEN + IF( l.EQ.1 ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour la Sst Amip $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + ENDIF + CALL inter_barxy ( imdep,jmdep -1,dlon, dlat , + , champ, iim, jjm, rlonu, rlatv, jjp1, champint ) + ELSE + CALL grille_m(imdep, jmdep, dlon, dlat, champ, + . iim, jjp1, rlonv, rlatu, champint ) + ENDIF + + DO j = 1,jjp1 + DO i = 1, iim + champtime (i,j,l) = champint(i,j) + ENDDO + ENDDO + ENDDO +c + DO l = 1, lmdep +cIM28/02/2002 <==PM timeyear(l) = timecoord(l) + timeyear(l) = tmidmonth(l) + ENDDO + print 222, timeyear(:lmdep) +c +C interpolation temporelle + DO j = 1, jjp1 + DO i = 1, iim + DO l = 1, lmdep + ax(l) = timeyear(l) + ay(l) = champtime (i,j,l) + ENDDO + CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder) + DO k = 1, 360 + time = FLOAT(k-1) + CALL SPLINT(ax,ay,yder,lmdep,time,by) + champan(i,j,k) = by + ENDDO + ENDDO + ENDDO + DO k = 1, 360 + DO j = 1, jjp1 + champan(iip1,j,k) = champan(1,j,k) + ENDDO + IF ( k.EQ.10 ) THEN + DO j = 1, jjp1 + CALL minmax( iip1,champan(1,j,10),chmin,chmax ) + PRINT *,' SST au temps 10 ', chmin,chmax,j + ENDDO + ENDIF + ENDDO +c +cIM14/03/2002 : SST amipbc greater then 271.38 + PRINT*,'SUB. limit_netcdf.F IM : SST Amipbc >= 271.38 ' + DO k = 1, 360 + DO j = 1, jjp1 + DO i = 1, iim + champan(i, j, k) = amax1(champan(i, j, k), 271.38) + ENDDO + champan(iip1, j, k) = champan(1, j, k) + ENDDO + ENDDO +cIM14/03/2002 + DO k = 1, 360 + CALL gr_dyn_fi(1, iip1, jjp1, klon, + . champan(1,1,k), phy_sst(1,k)) + ENDDO +c + ierr = NF_CLOSE(ncid) +c + DEALLOCATE( dlon ) + DEALLOCATE( dlon_ini ) + DEALLOCATE( dlat ) + DEALLOCATE( dlat_ini ) + DEALLOCATE( champ ) +c +C Traitement de l'albedo +c + PRINT*, 'Traitement de l albedo' + ierr = NF_OPEN('Albedo.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_VARID(ncid,'ALBEDO',varid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', imdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE ( dlon_ini(imdep) ) + ALLOCATE ( dlon(imdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', jmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE ( dlat_ini(jmdep) ) + ALLOCATE ( dlat(jmdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', lmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +c + ALLOCATE ( champ(imdep*jmdep) ) + + DO l = 1, lmdep + dimfirst(1) = 1 + dimfirst(2) = 1 + dimfirst(3) = l +c + dimlast(1) = imdep + dimlast(2) = jmdep + dimlast(3) = 1 +c + PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l) +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ) +#else + ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + title='Albedo Amip' +c + CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini, + . dlon, dlat, champ, interbar ) +c +c + IF ( interbar ) THEN + IF( l.EQ.1 ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour l Albedo Amip $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + ENDIF + + CALL inter_barxy ( imdep,jmdep -1,dlon, dlat , + , champ, iim, jjm, rlonu, rlatv, jjp1, champint ) + ELSE + CALL grille_m(imdep, jmdep, dlon, dlat, champ, + . iim, jjp1, rlonv, rlatu, champint ) + ENDIF +c + DO j = 1,jjp1 + DO i = 1, iim + champtime (i, j, l) = champint(i, j) + ENDDO + ENDDO + ENDDO +c + DO l = 1, lmdep + timeyear(l) = timecoord(l) + ENDDO + print 222, timeyear(:lmdep) +c +C interpolation temporelle + DO j = 1, jjp1 + DO i = 1, iim + DO l = 1, lmdep + ax(l) = timeyear(l) + ay(l) = champtime (i, j, l) + ENDDO + CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder) + DO k = 1, 360 + time = FLOAT(k-1) + CALL SPLINT(ax,ay,yder,lmdep,time,by) + champan(i,j,k) = by + ENDDO + ENDDO + ENDDO + DO k = 1, 360 + DO j = 1, jjp1 + champan(iip1, j, k) = champan(1, j, k) + ENDDO + IF ( k.EQ.10 ) THEN + DO j = 1, jjp1 + CALL minmax( iip1,champan(1,j,10),chmin,chmax ) + PRINT *,' Albedo au temps 10 ', chmin,chmax,j + ENDDO + ENDIF + ENDDO +c + DO k = 1, 360 + CALL gr_dyn_fi(1, iip1, jjp1, klon, + . champan(1,1,k), phy_alb(1,k)) + ENDDO +c + ierr = NF_CLOSE(ncid) +c +c + DO k = 1, 360 + DO i = 1, klon + phy_bil(i,k) = 0.0 + ENDDO + ENDDO +c + PRINT*, 'Ecriture du fichier limit' +c + ierr = NF_CREATE ("limit.nc", NF_CLOBBER, nid) +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 30, + . "Fichier conditions aux limites") + ierr = NF_DEF_DIM (nid, "points_physiques", klon, ndim) + ierr = NF_DEF_DIM (nid, "time", NF_UNLIMITED, ntim) +c + dims(1) = ndim + dims(2) = ntim +c +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "TEMPS", NF_DOUBLE, 1,ntim, id_tim) +#else + ierr = NF_DEF_VAR (nid, "TEMPS", NF_FLOAT, 1,ntim, id_tim) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_tim, "title", 17, + . "Jour dans l annee") + IF (newlmt) THEN +c +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "FOCE", NF_DOUBLE, 2,dims, id_FOCE) +#else + ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 2,dims, id_FOCE) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_FOCE, "title", 14, + . "Fraction ocean") +c +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "FSIC", NF_DOUBLE, 2,dims, id_FSIC) +#else + ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 2,dims, id_FSIC) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_FSIC, "title", 21, + . "Fraction glace de mer") +c +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "FTER", NF_DOUBLE, 2,dims, id_FTER) +#else + ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 2,dims, id_FTER) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_FTER, "title", 14, + . "Fraction terre") +c +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "FLIC", NF_DOUBLE, 2,dims, id_FLIC) +#else + ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 2,dims, id_FLIC) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_FLIC, "title", 17, + . "Fraction land ice") +c + ELSE +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "NAT", NF_DOUBLE, 2,dims, id_NAT) +#else + ierr = NF_DEF_VAR (nid, "NAT", NF_FLOAT, 2,dims, id_NAT) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_NAT, "title", 23, + . "Nature du sol (0,1,2,3)") + ENDIF +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "SST", NF_DOUBLE, 2,dims, id_SST) +#else + ierr = NF_DEF_VAR (nid, "SST", NF_FLOAT, 2,dims, id_SST) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_SST, "title", 35, + . "Temperature superficielle de la mer") +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "BILS", NF_DOUBLE, 2,dims, id_BILS) +#else + ierr = NF_DEF_VAR (nid, "BILS", NF_FLOAT, 2,dims, id_BILS) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_BILS, "title", 32, + . "Reference flux de chaleur au sol") +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "ALB", NF_DOUBLE, 2,dims, id_ALB) +#else + ierr = NF_DEF_VAR (nid, "ALB", NF_FLOAT, 2,dims, id_ALB) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_ALB, "title", 19, + . "Albedo a la surface") +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "RUG", NF_DOUBLE, 2,dims, id_RUG) +#else + ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_RUG, "title", 8, + . "Rugosite") +c + ierr = NF_ENDDEF(nid) +c + DO k = 1, 360 +c + debut(1) = 1 + debut(2) = k + epais(1) = klon + epais(2) = 1 +c +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR1_DOUBLE (nid,id_tim,k,DBLE(k)) +c + IF (newlmt ) THEN + ierr = NF_PUT_VARA_DOUBLE (nid,id_FOCE,debut,epais + $ ,pctsrf_t(1,is_oce,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_FSIC,debut,epais + $ ,pctsrf_t(1,is_sic,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_FTER,debut,epais + $ ,pctsrf_t(1,is_ter,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_FLIC,debut,epais + $ ,pctsrf_t(1,is_lic,k)) + ELSE + ierr = NF_PUT_VARA_DOUBLE (nid,id_NAT,debut,epais + $ ,phy_nat(1,k)) + ENDIF +c + ierr = NF_PUT_VARA_DOUBLE (nid,id_SST,debut,epais,phy_sst(1,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_BILS,debut,epais,phy_bil(1,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_ALB,debut,epais,phy_alb(1,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_RUG,debut,epais,phy_rug(1,k)) +#else + ierr = NF_PUT_VAR1_REAL (nid,id_tim,k,FLOAT(k)) + IF (newlmt ) THEN + ierr = NF_PUT_VARA_REAL (nid,id_FOCE,debut,epais + $ ,pctsrf_t(1,is_oce,k)) + ierr = NF_PUT_VARA_REAL (nid,id_FSIC,debut,epais + $ ,pctsrf_t(1,is_sic,k)) + ierr = NF_PUT_VARA_REAL (nid,id_FTER,debut,epais + $ ,pctsrf_t(1,is_ter,k)) + ierr = NF_PUT_VARA_REAL (nid,id_FLIC,debut,epais + $ ,pctsrf_t(1,is_lic,k)) + ELSE + ierr = NF_PUT_VARA_REAL (nid,id_NAT,debut,epais + $ ,phy_nat(1,k)) + ENDIF + ierr = NF_PUT_VARA_REAL (nid,id_SST,debut,epais,phy_sst(1,k)) + ierr = NF_PUT_VARA_REAL (nid,id_BILS,debut,epais,phy_bil(1,k)) + ierr = NF_PUT_VARA_REAL (nid,id_ALB,debut,epais,phy_alb(1,k)) + ierr = NF_PUT_VARA_REAL (nid,id_RUG,debut,epais,phy_rug(1,k)) +#endif +c + ENDDO +c + ierr = NF_CLOSE(nid) +c +#else + WRITE(lunout,*) + & 'limit_netcdf: Earth-specific routine, needs Earth physics' +#endif +! of #ifdef CPP_EARTH + STOP + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/limx.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/limx.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/limx.F (revision 1280) @@ -0,0 +1,110 @@ +! +! $Header$ +! + SUBROUTINE limx(s0,sx,sm,pente_max) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + real pente_max + REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm) + real sx(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + integer n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL q(ip1jmp1,llm) + real dxq(ip1jmp1,llm) + + + REAL new_m,zm + real dxqu(ip1jmp1) + real adxqu(ip1jmp1),dxqmax(ip1jmp1) + + Logical extremum,first + save first + + REAL SSUM,CVMGP,CVMGT + integer ismax,ismin + EXTERNAL SSUM, convflu,ismin,ismax + EXTERNAL filtreg + + data first/.true./ + + + DO l = 1,llm + DO ij=1,ip1jmp1 + q(ij,l) = s0(ij,l) / sm ( ij,l ) + dxq(ij,l) = sx(ij,l) /sm(ij,l) + ENDDO + ENDDO + +c calcul de la pente a droite et a gauche de la maille + + do l = 1, llm + do ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + enddo + do ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) + enddo + + do ij=iip2,ip1jm + adxqu(ij)=abs(dxqu(ij)) + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do ij=iip2+1,ip1jm + dxqmax(ij)=pente_max*min(adxqu(ij-1),adxqu(ij)) + enddo + + do ij=iip1+iip1,ip1jm,iip1 + dxqmax(ij-iim)=dxqmax(ij) + enddo + +c calcul de la pente avec limitation + + do ij=iip2+1,ip1jm + if( dxqu(ij-1)*dxqu(ij).gt.0. + & .and. dxq(ij,l)*dxqu(ij).gt.0.) then + dxq(ij,l)= + & sign(min(abs(dxq(ij,l)),dxqmax(ij)),dxq(ij,l)) + else +c extremum local + dxq(ij,l)=0. + endif + enddo + do ij=iip1+iip1,ip1jm,iip1 + dxq(ij-iim,l)=dxq(ij,l) + enddo + + DO ij=1,ip1jmp1 + sx(ij,l) = dxq(ij,l)*sm(ij,l) + ENDDO + + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/limy.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/limy.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/limy.F (revision 1280) @@ -0,0 +1,194 @@ +! +! $Header$ +! + SUBROUTINE limy(s0,sy,sm,pente_max) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,w sont des arguments d'entree pour le s-pg .... +c dq sont des arguments de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + real pente_max + real s0(ip1jmp1,llm),sy(ip1jmp1,llm),sm(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,ij,l +c + REAL q(ip1jmp1,llm) + REAL airej2,airejjm,airescb(iim),airesch(iim) + real sigv,dyq(ip1jmp1),dyqv(ip1jm) + real adyqv(ip1jm),dyqmax(ip1jmp1) + REAL qbyv(ip1jm,llm) + + REAL qpns,qpsn,apn,aps,dyn1,dys1,dyn2,dys2 + Logical extremum,first + save first + + real convpn,convps,convmpn,convmps + real sinlon(iip1),sinlondlon(iip1) + real coslon(iip1),coslondlon(iip1) + save sinlon,coslon,sinlondlon,coslondlon +c +c + REAL SSUM + integer ismax,ismin + EXTERNAL SSUM, convflu,ismin,ismax + EXTERNAL filtreg + + data first/.true./ + + if(first) then + print*,'SCHEMA AMONT NOUVEAU' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + enddo + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + endif + +c + + do l = 1, llm +c + DO ij=1,ip1jmp1 + q(ij,l) = s0(ij,l) / sm ( ij,l ) + dyq(ij) = sy(ij,l) / sm ( ij,l ) + ENDDO +c +c -------------------------------- +c CALCUL EN LATITUDE +c -------------------------------- + +c On commence par calculer la valeur du traceur moyenne sur le premier cercle +c de latitude autour du pole (qpns pour le pole nord et qpsn pour +c le pole nord) qui sera utilisee pour evaluer les pentes au pole. + + airej2 = SSUM( iim, aire(iip2), 1 ) + airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) + DO i = 1, iim + airescb(i) = aire(i+ iip1) * q(i+ iip1,l) + airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l) + ENDDO + qpns = SSUM( iim, airescb ,1 ) / airej2 + qpsn = SSUM( iim, airesch ,1 ) / airejjm + +c calcul des pentes aux points v + + do ij=1,ip1jm + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + adyqv(ij)=abs(dyqv(ij)) + ENDDO + +c calcul des pentes aux points scalaires + + do ij=iip2,ip1jm + dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) + dyqmax(ij)=pente_max*dyqmax(ij) + enddo + +c calcul des pentes aux poles + +c calcul des pentes limites aux poles + +c print*,dyqv(iip1+1) +c apn=abs(dyq(1)/dyqv(iip1+1)) +c print*,dyq(ip1jm+1) +c print*,dyqv(ip1jm-iip1+1) +c aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) +c do ij=2,iim +c apn=amax1(abs(dyq(ij)/dyqv(ij)),apn) +c aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps) +c enddo +c apn=min(pente_max/apn,1.) +c aps=min(pente_max/aps,1.) + + +c cas ou on a un extremum au pole + +c if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +c & apn=0. +c if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +c & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +c & aps=0. + +c limitation des pentes aux poles +c do ij=1,iip1 +c dyq(ij)=apn*dyq(ij) +c dyq(ip1jm+ij)=aps*dyq(ip1jm+ij) +c enddo + +c test +c do ij=1,iip1 +c dyq(iip1+ij)=0. +c dyq(ip1jm+ij-iip1)=0. +c enddo +c do ij=1,ip1jmp1 +c dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) +c enddo + + if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) + & then + do ij=1,iip1 + dyqmax(ij)=0. + enddo + else + do ij=1,iip1 + dyqmax(ij)=pente_max*abs(dyqv(ij)) + enddo + endif + + if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* + & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) + &then + do ij=ip1jm+1,ip1jmp1 + dyqmax(ij)=0. + enddo + else + do ij=ip1jm+1,ip1jmp1 + dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) + enddo + endif + +c calcul des pentes limitees + + do ij=1,ip1jmp1 + if(dyqv(ij)*dyqv(ij-iip1).gt.0.) then + dyq(ij)=sign(min(abs(dyq(ij)),dyqmax(ij)),dyq(ij)) + else + dyq(ij)=0. + endif + enddo + + DO ij=1,ip1jmp1 + sy(ij,l) = dyq(ij) * sm ( ij,l ) + ENDDO + + enddo ! fin de la boucle sur les couches verticales + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/limz.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/limz.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/limz.F (revision 1280) @@ -0,0 +1,100 @@ +! +! $Header$ +! + SUBROUTINE limz(s0,sz,sm,pente_max) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + real pente_max + REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm) + real sz(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + integer n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL q(ip1jmp1,llm) + real dzq(ip1jmp1,llm) + + + REAL new_m,zm + real dzqw(ip1jmp1) + real adzqw(ip1jmp1),dzqmax(ip1jmp1) + + Logical extremum,first + save first + + REAL SSUM,CVMGP,CVMGT + integer ismax,ismin + EXTERNAL SSUM, convflu,ismin,ismax + EXTERNAL filtreg + + data first/.true./ + + + DO l = 1,llm + DO ij=1,ip1jmp1 + q(ij,l) = s0(ij,l) / sm ( ij,l ) + dzq(ij,l) = sz(ij,l) /sm(ij,l) + ENDDO + ENDDO + +c calcul de la pente en haut et en bas de la maille + do ij=1,ip1jmp1 + do l = 1, llm-1 + dzqw(l)=q(ij,l+1)-q(ij,l) + enddo + dzqw(llm)=0. + + do l=1,llm + adzqw(l)=abs(dzqw(l)) + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do l=2,llm-1 + dzqmax(l)=pente_max*min(adzqw(l-1),adzqw(l)) + enddo + +c calcul de la pente avec limitation + + do l=2,llm-1 + if( dzqw(l-1)*dzqw(l).gt.0. + & .and. dzq(ij,l)*dzqw(l).gt.0.) then + dzq(ij,l)= + & sign(min(abs(dzq(ij,l)),dzqmax(l)),dzq(ij,l)) + else +c extremum local + dzq(ij,l)=0. + endif + enddo + + DO l=1,llm + sz(ij,l) = dzq(ij,l)*sm(ij,l) + ENDDO + + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/logic.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/logic.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/logic.h (revision 1280) @@ -0,0 +1,18 @@ +! +! $Header$ +! +! +! +!----------------------------------------------------------------------- +! INCLUDE 'logic.h' + + COMMON/logic/ purmats,iflag_phys,forward,leapf,apphys, & + & statcl,conser,apdiss,apdelq,saison,ecripar,fxyhypb,ysinus & + & ,read_start,ok_guide,ok_strato,ok_gradsfile + + LOGICAL purmats,forward,leapf,apphys,statcl,conser, & + & apdiss,apdelq,saison,ecripar,fxyhypb,ysinus & + & ,read_start,ok_guide,ok_strato,ok_gradsfile + + INTEGER iflag_phys +!----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/massbar.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/massbar.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/massbar.F (revision 1280) @@ -0,0 +1,100 @@ +! +! $Header$ +! + SUBROUTINE massbar( masse, massebx, masseby ) +c +c ********************************************************************** +c +c Calcule les moyennes en x et y de la masse d'air dans chaque maille. +c ********************************************************************** +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. masse est un argum. d'entree pour le s-pg ... +c .. massebx,masseby sont des argum. de sortie pour le s-pg ... +c +c +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c + REAL masse( ip1jmp1,llm ), massebx( ip1jmp1,llm ) , + * masseby( ip1jm,llm ) +c +c +c Methode pour calculer massebx et masseby . +c ---------------------------------------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c On a : +c +c massebx(i,j) = masse(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c masseby(i,j) = masse(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c +c======================================================================= + + DO 100 l = 1 , llm +c + DO ij = 1, ip1jmp1 - 1 + massebx(ij,l) = masse( ij, l) * alpha1p2( ij ) + + * masse(ij+1, l) * alpha3p4(ij+1 ) + ENDDO + +c .... correction pour massebx( iip1,j) ..... +c ... massebx(iip1,j)= massebx(1,j) ... +c +CDIR$ IVDEP + DO ij = iip1, ip1jmp1, iip1 + massebx( ij,l ) = massebx( ij - iim,l ) + ENDDO + + + DO ij = 1,ip1jm + masseby( ij,l ) = masse( ij , l ) * alpha2p3( ij ) + + * masse(ij+iip1, l ) * alpha1p4( ij+iip1 ) + ENDDO + +100 CONTINUE +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/massbarxy.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/massbarxy.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/massbarxy.F (revision 1280) @@ -0,0 +1,47 @@ +! +! $Header$ +! + SUBROUTINE massbarxy( masse, massebxy ) +c +c ********************************************************************** +c +c Calcule les moyennes en x et y de la masse d'air dans chaque maille. +c ********************************************************************** +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. masse est un argum. d'entree pour le s-pg ... +c .. massebxy est un argum. de sortie pour le s-pg ... +c +c +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c + REAL masse( ip1jmp1,llm ), massebxy( ip1jm,llm ) +c + + DO 100 l = 1 , llm +c + DO 5 ij = 1, ip1jm - 1 + massebxy( ij,l ) = masse( ij ,l ) * alpha2( ij ) + + + masse( ij+1 ,l ) * alpha3( ij+1 ) + + + masse( ij+iip1,l ) * alpha1( ij+iip1 ) + + + masse( ij+iip2,l ) * alpha4( ij+iip2 ) + 5 CONTINUE + +c .... correction pour massebxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = iip1, ip1jm, iip1 + massebxy( ij,l ) = massebxy( ij - iim,l ) + 7 CONTINUE + +100 CONTINUE +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/massdair.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/massdair.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/massdair.F (revision 1280) @@ -0,0 +1,109 @@ +! +! $Header$ +! + SUBROUTINE massdair( p, masse ) +c +c ********************************************************************* +c .... Calcule la masse d'air dans chaque maille .... +c ********************************************************************* +c +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. p est un argum. d'entree pour le s-pg ... +c .. masse est un argum.de sortie pour le s-pg ... +c +c .... p est defini aux interfaces des llm couches ..... +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c +c ..... arguments .... +c + REAL p(ip1jmp1,llmp1), masse(ip1jmp1,llm) + +c .... Variables locales ..... + + INTEGER l,ij + REAL massemoyn, massemoys + + REAL SSUM +c +c +c Methode pour calculer massebx et masseby . +c ---------------------------------------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c On a : +c +c massebx(i,j) = masse(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c masseby(i,j) = masse(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c +c======================================================================= + + DO 100 l = 1 , llm +c + DO ij = 1, ip1jmp1 + masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) ) + ENDDO +c + DO ij = 1, ip1jmp1,iip1 + masse(ij+ iim,l) = masse(ij,l) + ENDDO +c +c DO ij = 1, iim +c masse( ij ,l) = masse( ij ,l) * aire( ij ) +c masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm) +c ENDDO +c massemoyn = SSUM(iim,masse( 1 ,l),1)/ apoln +c massemoys = SSUM(iim,masse(ip1jm+1,l),1)/ apols +c DO ij = 1, iip1 +c masse( ij ,l ) = massemoyn +c masse(ij+ip1jm,l ) = massemoys +c ENDDO + +100 CONTINUE +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/minmax.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/minmax.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/minmax.F (revision 1280) @@ -0,0 +1,23 @@ +! +! $Header$ +! + SUBROUTINE minmax(imax, xi, zmin, zmax ) +c +c P. Le Van + + INTEGER imax + REAL xi(imax) + REAL zmin,zmax + INTEGER i + + zmin = xi(1) + zmax = xi(1) + + DO i = 2, imax + zmin = MIN( zmin,xi(i) ) + zmax = MAX( zmax,xi(i) ) + ENDDO + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/minmax2.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/minmax2.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/minmax2.F (revision 1280) @@ -0,0 +1,20 @@ +! +! $Header$ +! + SUBROUTINE minmax2(imax, jmax, lmax, xi, zmin, zmax ) +c + INTEGER lmax,jmax,imax + REAL xi(imax*jmax*lmax) + REAL zmin,zmax + INTEGER i + + zmin = xi(1) + zmax = xi(1) + + DO i = 2, imax*jmax*lmax + zmin = MIN( zmin,xi(i) ) + zmax = MAX( zmax,xi(i) ) + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/mod_const_para.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/mod_const_para.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/mod_const_para.F90 (revision 1280) @@ -0,0 +1,16 @@ +MODULE mod_const_mpi + + INTEGER :: COMM_LMDZ + INTEGER :: MPI_REAL_LMDZ + + +CONTAINS + + SUBROUTINE Init_const_mpi + IMPLICIT NONE + + COMM_LMDZ=0 + MPI_REAL_LMDZ=0 + END SUBROUTINE Init_const_mpi + +END MODULE mod_const_mpi Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/nxgrad.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/nxgrad.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/nxgrad.F (revision 1280) @@ -0,0 +1,48 @@ +! +! $Header$ +! + SUBROUTINE nxgrad (klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij +c +c + DO 10 l = 1,klevel +c + DO 1 ij = 2, ip1jm + y( ij,l ) = ( rot( ij,l ) - rot( ij-1,l ) ) * cvsurcuv( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = 1, ip1jm, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + DO 4 ij = iip2,ip1jm + x( ij,l ) = ( rot( ij,l ) - rot( ij -iip1,l ) ) * cusurcvu( ij ) + 4 CONTINUE + DO 6 ij = 1,iip1 + x( ij ,l ) = 0. + x( ij +ip1jm,l ) = 0. + 6 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/nxgrad_gam.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/nxgrad_gam.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/nxgrad_gam.F (revision 1280) @@ -0,0 +1,47 @@ +! +! $Header$ +! + SUBROUTINE nxgrad_gam( klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij +c + DO 10 l = 1,klevel +c + DO 1 ij = 2, ip1jm + y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = 1, ip1jm, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + DO 4 ij = iip2,ip1jm + x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij ) + 4 CONTINUE + DO 6 ij = 1,iip1 + x( ij ,l ) = 0. + x( ij +ip1jm,l ) = 0. + 6 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/nxgradst.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/nxgradst.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/nxgradst.F (revision 1280) @@ -0,0 +1,47 @@ +! +! $Header$ +! + SUBROUTINE nxgradst (klevel,rot, x, y ) +c + IMPLICIT NONE +c Auteur : P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij +c + DO 10 l = 1,klevel +c + DO 1 ij = 2, ip1jm + y(ij,l)=( rot(ij,l) - rot(ij-1,l)) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... + + DO 2 ij = 1, ip1jm, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + DO 4 ij = iip2,ip1jm + x(ij,l)= rot(ij,l)-rot(ij-iip1,l) + 4 CONTINUE + DO 6 ij = 1,iip1 + x( ij ,l ) = 0. + x( ij +ip1jm,l ) = 0. + 6 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/nxgraro2.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/nxgraro2.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/nxgraro2.F (revision 1280) @@ -0,0 +1,68 @@ +! +! $Header$ +! + SUBROUTINE nxgraro2 (klevel,xcov, ycov, lr, grx, gry ) +c +c P.Le Van . +c *********************************************************** +c lr +c calcul de ( nxgrad (rot) ) du vect. v .... +c +c xcov et ycov etant les compos. covariantes de v +c *********************************************************** +c xcov , ycov et lr sont des arguments d'entree pour le s-prog +c grx et gry sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +c +c ...... variables en arguments ....... +c + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL grx( ip1jmp1,klevel ), gry( ip1jm,klevel ) +c +c ...... variables locales ........ +c + REAL rot(ip1jm,llm) , signe, nugradrs + INTEGER l,ij,iter,lr +c ........................................................ +c +c +c + signe = (-1.)**lr + nugradrs = signe * crot +c + CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 ) + CALL SCOPY ( ip1jm * klevel, ycov, 1, gry, 1 ) +c + CALL rotatf ( klevel, grx, gry, rot ) +c + CALL laplacien_rot ( klevel, rot, rot,grx,gry ) + +c +c ..... Iteration de l'operateur laplacien_rotgam ..... +c + DO iter = 1, lr -2 + CALL laplacien_rotgam ( klevel, rot, rot ) + ENDDO +c +c + CALL filtreg( rot, jjm, klevel, 2,1, .FALSE.,1) + CALL nxgrad ( klevel, rot, grx, gry ) +c + DO l = 1, klevel + DO ij = 1, ip1jm + gry( ij,l ) = gry( ij,l ) * nugradrs + ENDDO + DO ij = 1, ip1jmp1 + grx( ij,l ) = grx( ij,l ) * nugradrs + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/nxgrarot.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/nxgrarot.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/nxgrarot.F (revision 1280) @@ -0,0 +1,55 @@ +! +! $Header$ +! + SUBROUTINE nxgrarot (klevel,xcov, ycov, lr, grx, gry ) +c *********************************************************** +c +c Auteur : P.Le Van +c +c lr +c calcul de ( nXgrad (rot) ) du vect. v .... +c +c xcov et ycov etant les compos. covariantes de v +c *********************************************************** +c xcov , ycov et lr sont des arguments d'entree pour le s-prog +c grx et gry sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "logic.h" +c + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL grx( ip1jmp1,klevel ), gry( ip1jm,klevel ) +c + REAL rot(ip1jm,llm) + + INTEGER l,ij,iter,lr +c +c +c + CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 ) + CALL SCOPY ( ip1jm*klevel, ycov, 1, gry, 1 ) +c + DO 10 iter = 1,lr + CALL rotat (klevel,grx, gry, rot ) + CALL filtreg( rot, jjm, klevel, 2,1, .false.,2) + CALL nxgrad (klevel,rot, grx, gry ) +c + DO 5 l = 1, klevel + DO 2 ij = 1, ip1jm + gry( ij,l ) = - gry( ij,l ) * crot + 2 CONTINUE + DO 3 ij = 1, ip1jmp1 + grx( ij,l ) = - grx( ij,l ) * crot + 3 CONTINUE + 5 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ord_coord.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ord_coord.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ord_coord.F (revision 1280) @@ -0,0 +1,95 @@ +! +! $Header$ +! + SUBROUTINE ord_coord ( nmax, xi, xo, decrois ) + +c .... Auteur : P. Le Van .... +c +c ... Reordonne eventuellement les coordonnees de la grille donnees ... +c + IMPLICIT NONE + +c ..... Arguments en entree ..... + + INTEGER nmax + REAL xi(nmax) + +c ..... Arguments en sortie ..... +c + REAL xo(nmax+1) + LOGICAL decrois + +c .... Variables locales .... + + REAL xscr(nmax) + INTEGER i,ii + REAL pi, degres, chmin, chmax, mult +c + + pi = 2.*ASIN(1.) + degres = 180./pi + decrois = .FALSE. + + DO i = 1, nmax + xo(i) = xi(i) + ENDDO + + mult = 1. + IF( xo(1).GT.xo(nmax) ) mult = -1. + + CALL minmax(nmax,xo(1),chmin,chmax) + + IF(chmax.LT.6.5 ) THEN + DO i = 1,nmax + xo(i) = xo(i) * degres + ENDDO + ENDIF + + IF( ABS( xo( 1 ) + mult* 90. ). LT .0.001. OR . + , ABS( xo(nmax) - mult* 90. ). LT .0.001 ) THEN + PRINT *,' Reverifier les valeurs de xidat pour les donnees .' + PRINT *,' Elles doivent correspondre aux interfaces et non aux', + , 'ordonnees des donnees,egales a -90. et 90.deg aux 2 extremites ' + CALL ABORT + ENDIF + + IF( xo(1).GT.xo(nmax) ) THEN + DO i = 1, nmax + xscr(i) = xo(i) + ENDDO + DO i = 1, nmax + xo(i+1) = xscr(i) + ENDDO + xo ( 1 ) = 90. + ELSE + xo ( nmax +1) = 90. + ENDIF + + IF ( xo(2).LT.xo(1) ) decrois =.TRUE. + + DO i = 3, nmax + + IF(decrois.AND.xo(i).GT.xo(i-1) ) THEN + PRINT 1 + PRINT 2,(xo(ii),ii=1,nmax) + CALL ABORT + ENDIF + IF(.NOT.decrois.AND.xo(i).LT.xo(i-1) ) THEN + PRINT 1 + PRINT 2,(xo(ii),ii=1,nmax) + CALL ABORT + ENDIF + + ENDDO + + IF( decrois ) THEN +c CALL sort(nmax+1,xo(1)) + CALL sort(nmax+1,xo) + ENDIF + +1 FORMAT(5x,' Incoherence dans les valeurs des latitudes de la ', + , 'grille du modele ') +2 FORMAT(1x,8f8.2) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ord_coordm.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ord_coordm.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ord_coordm.F (revision 1280) @@ -0,0 +1,110 @@ +! +! $Header$ +! + SUBROUTINE ord_coordm ( nmax, xi, xo, jjm, jmods, decrois ) + +c .... Auteur : P. Le Van .... + +c ... Reordonne eventuellement les coordonnees de la grille modele ... +c + IMPLICIT NONE + +c ..... Arguments en entree ..... + + INTEGER nmax,jjm + REAL xi(nmax) + +c ..... Arguments en sortie ..... +c + REAL xo(nmax+1) + LOGICAL decrois + INTEGER jmods + +c .... Variables locales .... + + REAL xscr(nmax) + INTEGER i + REAL pi, degres, chmin, chmax,mult +c + DO i = 1, nmax + xo(i) = xi(i) + ENDDO + + mult = 1. + IF( xo(1).GT.xo(nmax) ) mult = - 1. + IF( nmax.EQ.jjm ) jmods = nmax +1 + IF( nmax.EQ.jjm +1 ) jmods = nmax -1 + + pi = 2.*ASIN(1.) + degres = 180./pi + decrois = .FALSE. + + CALL minmax(nmax,xo(1),chmin,chmax) + + IF(chmax.LT.6.5 ) THEN + DO i = 1,nmax + xo(i) = xo(i) * degres + ENDDO + ENDIF + + IF( nmax.EQ.jjm ) THEN + IF( xo(1).GT.xo(nmax) ) THEN + DO i = 1, nmax + xscr(i) = xo(i) + ENDDO + DO i = 1, nmax + xo(i+1) = xscr(i) + ENDDO + xo ( 1 ) = 90. + ELSE + xo ( nmax+1 ) = 90. + ENDIF + ELSE + IF( nmax.NE.jjm +1 ) THEN + PRINT *,' Dans la routine ord_coordm , l argument nmax ' + PRINT *,' n est pas egal a jjm ni a jjm +1 . Corriger !' + CALL ABORT + ELSE + IF( ABS( xo(1)+ mult * 90.).GT.0.01 ) THEN + PRINT *,' Avec nmax =',nmax,'on devrait avoir des', + , ' ordonnees = 90. deg pour j=1 ou jjm+1 ! ' + CALL ABORT + ELSE + IF( xo(1).LT.xo(nmax) ) THEN + DO i = 1, nmax + xscr(i) = xo(i) + ENDDO + DO i = 1, nmax -1 + xo(i) = xscr(i+1) + ENDDO + ENDIF + ENDIF + ENDIF + ENDIF + + IF ( xo(2).LT.xo(1) ) decrois =.TRUE. + + DO i = 3, nmax + + IF(decrois.AND.xo(i).GT.xo(i-1) ) THEN + PRINT 1 + CALL ABORT + ENDIF + IF(.NOT.decrois.AND.xo(i).LT.xo(i-1) ) THEN + PRINT 1 + CALL ABORT + ENDIF + + ENDDO + + IF( decrois ) THEN + CALL sort(jmods,xo(1)) + ENDIF + + +1 FORMAT(5x,' Incoherence dans les valeurs des latitudes de la ', + , 'grille du modele ') +2 FORMAT(1x,8f8.2) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/paramet.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/paramet.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/paramet.h (revision 1280) @@ -0,0 +1,29 @@ +! +! $Header$ +! +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! +!----------------------------------------------------------------------- +! INCLUDE 'paramet.h' + + INTEGER iip1,iip2,iip3,jjp1,llmp1,llmp2,llmm1 + INTEGER kftd,ip1jm,ip1jmp1,ip1jmi1,ijp1llm + INTEGER ijmllm,mvar + INTEGER jcfil,jcfllm + + PARAMETER( iip1= iim+1-1/iim,iip2=iim+2,iip3=iim+3 & + & ,jjp1=jjm+1-1/jjm) + PARAMETER( llmp1 = llm+1, llmp2 = llm+2, llmm1 = llm-1 ) + PARAMETER( kftd = iim/2 -ndm ) + PARAMETER( ip1jm = iip1*jjm, ip1jmp1= iip1*jjp1 ) + PARAMETER( ip1jmi1= ip1jm - iip1 ) + PARAMETER( ijp1llm= ip1jmp1 * llm, ijmllm= ip1jm * llm ) + PARAMETER( mvar= ip1jmp1*( 2*llm+1) + ijmllm ) + PARAMETER( jcfil=jjm/2+5, jcfllm=jcfil*llm ) + +!----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/pbar.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/pbar.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/pbar.F (revision 1280) @@ -0,0 +1,124 @@ +! +! $Header$ +! + SUBROUTINE pbar ( pext, pbarx, pbary, pbarxy ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************** +c calcul des moyennes en x et en y de (pression au sol*aire variable) .. +c ********************************************************************* +c +c pext est un argum. d'entree pour le s-pg .. +c pbarx,pbary et pbarxy sont des argum. de sortie pour le s-pg .. +c +c Methode: +c -------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c +c On a : +c +c pbarx(i,j) = Pext(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c pbary(i,j) = Pext(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) + +c Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1) +c localise au point ... Z (i,j) ... +c +c +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" + +#include "comgeom.h" + + REAL pext( ip1jmp1 ), pbarx ( ip1jmp1 ) + REAL pbary( ip1jm ), pbarxy( ip1jm ) + + INTEGER ij + + + + DO 1 ij = 1, ip1jmp1 - 1 + pbarx( ij ) = pext(ij) * alpha1p2(ij) + pext(ij+1)*alpha3p4(ij+1) + 1 CONTINUE + +c .... correction pour pbarx( iip1,j) ..... + +c ... pbarx(iip1,j)= pbarx(1,j) ... +CDIR$ IVDEP + DO 2 ij = iip1, ip1jmp1, iip1 + pbarx( ij ) = pbarx( ij - iim ) + 2 CONTINUE + + + DO 3 ij = 1,ip1jm + pbary( ij ) = pext( ij ) * alpha2p3( ij ) + + * pext( ij+iip1 ) * alpha1p4( ij+iip1 ) + 3 CONTINUE + + + DO 5 ij = 1, ip1jm - 1 + pbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) + + * pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2) + 5 CONTINUE + + +c .... correction pour pbarxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = iip1, ip1jm, iip1 + pbarxy( ij ) = pbarxy( ij - iim ) + 7 CONTINUE + + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/pentes_ini.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/pentes_ini.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/pentes_ini.F (revision 1280) @@ -0,0 +1,478 @@ +! +! $Header$ +! + SUBROUTINE pentes_ini (q,w,masse,pbaru,pbarv,mode) + IMPLICIT NONE + +c======================================================================= +c Adaptation LMDZ: A.Armengaud (LGGE) +c ---------------- +c +c ******************************************************************** +c Transport des traceurs par la methode des pentes +c ******************************************************************** +c Reference possible : Russel. G.L., Lerner J.A.: +c A new Finite-Differencing Scheme for Traceur Transport +c Equation , Journal of Applied Meteorology, pp 1483-1498,dec. 81 +c ******************************************************************** +c q,w,masse,pbaru et pbarv +c sont des arguments d'entree pour le s-pg .... +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +c Arguments: +c ---------- + integer mode + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ) + REAL q( iip1,jjp1,llm,0:3) + REAL w( ip1jmp1,llm ) + REAL masse( iip1,jjp1,llm) +c Local: +c ------ + LOGICAL limit + REAL sm ( iip1,jjp1, llm ) + REAL s0( iip1,jjp1,llm ), sx( iip1,jjp1,llm ) + REAL sy( iip1,jjp1,llm ), sz( iip1,jjp1,llm ) + real masn,mass,zz + INTEGER i,j,l,iq + +c modif Fred 24 03 96 + + real sinlon(iip1),sinlondlon(iip1) + real coslon(iip1),coslondlon(iip1) + save sinlon,coslon,sinlondlon,coslondlon + real dyn1,dyn2,dys1,dys2 + real qpn,qps,dqzpn,dqzps + real smn,sms,s0n,s0s,sxn(iip1),sxs(iip1) + real qmin,zq,pente_max +c + REAL SSUM + integer ismax,ismin,lati,latf + EXTERNAL SSUM, convflu,ismin,ismax + logical first + save first +c fin modif + +c EXTERNAL masskg + EXTERNAL advx + EXTERNAL advy + EXTERNAL advz + +c modif Fred 24 03 96 + data first/.true./ + + limit = .TRUE. + pente_max=2 +c if (mode.eq.1.or.mode.eq.3) then +c if (mode.eq.1) then + if (mode.ge.1) then + lati=2 + latf=jjm + else + lati=1 + latf=jjp1 + endif + + qmin=0.4995 + qmin=0. + if(first) then + print*,'SCHEMA AMONT NOUVEAU' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + print*,coslondlon(i),sinlondlon(i) + enddo + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + print*,'sum sinlondlon ',ssum(iim,sinlondlon,1)/sinlondlon(1) + print*,'sum coslondlon ',ssum(iim,coslondlon,1)/coslondlon(1) + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + q ( i,j,l,1 )=0. + q ( i,j,l,2 )=0. + q ( i,j,l,3 )=0. + ENDDO + ENDDO + ENDDO + + endif +c Fin modif Fred + +c *** q contient les qqtes de traceur avant l'advection + +c *** Affectation des tableaux S a partir de Q +c *** Rem : utilisation de SCOPY ulterieurement + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + s0( i,j,llm+1-l ) = q ( i,j,l,0 ) + sx( i,j,llm+1-l ) = q ( i,j,l,1 ) + sy( i,j,llm+1-l ) = q ( i,j,l,2 ) + sz( i,j,llm+1-l ) = q ( i,j,l,3 ) + ENDDO + ENDDO + ENDDO + +c PRINT*,'----- S0 just before conversion -------' +c PRINT*,'S0(16,12,1)=',s0(16,12,1) +c PRINT*,'Q(16,12,1,4)=',q(16,12,1,4) + +c *** On calcule la masse d'air en kg + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + sm ( i,j,llm+1-l)=masse( i,j,l ) + ENDDO + ENDDO + ENDDO + +c *** On converti les champs S en atome (resp. kg) +c *** Les routines d'advection traitent les champs +c *** a advecter si ces derniers sont en atome (resp. kg) +c *** A optimiser !!! + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + s0(i,j,l) = s0(i,j,l) * sm ( i,j,l ) + sx(i,j,l) = sx(i,j,l) * sm ( i,j,l ) + sy(i,j,l) = sy(i,j,l) * sm ( i,j,l ) + sz(i,j,l) = sz(i,j,l) * sm ( i,j,l ) + ENDDO + ENDDO + ENDDO + +c ss0 = 0. +c DO l = 1,llm +c DO j = 1,jjp1 +c DO i = 1,iim +c ss0 = ss0 + s0 ( i,j,l ) +c ENDDO +c ENDDO +c ENDDO +c PRINT*, 'valeur tot s0 avant advection=',ss0 + +c *** Appel des subroutines d'advection en X, en Y et en Z +c *** Advection avec "time-splitting" + +c----------------------------------------------------------- +c PRINT*,'----- S0 just before ADVX -------' +c PRINT*,'S0(16,12,1)=',s0(16,12,1) + +c----------------------------------------------------------- +c do l=1,llm +c do j=1,jjp1 +c do i=1,iip1 +c zq=s0(i,j,l)/sm(i,j,l) +c if(zq.lt.qmin) +c , print*,'avant advx1, s0(',i,',',j,',',l,')=',zq +c enddo +c enddo +c enddo +CCC + if(mode.eq.2) then + do l=1,llm + s0s=0. + s0n=0. + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + smn=0. + sms=0. + do i=1,iim + smn=smn+sm(i,1,l) + sms=sms+sm(i,jjp1,l) + s0n=s0n+s0(i,1,l) + s0s=s0s+s0(i,jjp1,l) + zz=sy(i,1,l)/sm(i,1,l) + dyn1=dyn1+sinlondlon(i)*zz + dyn2=dyn2+coslondlon(i)*zz + zz=sy(i,jjp1,l)/sm(i,jjp1,l) + dys1=dys1+sinlondlon(i)*zz + dys2=dys2+coslondlon(i)*zz + enddo + do i=1,iim + sy(i,1,l)=dyn1*sinlon(i)+dyn2*coslon(i) + sy(i,jjp1,l)=dys1*sinlon(i)+dys2*coslon(i) + enddo + do i=1,iim + s0(i,1,l)=s0n/smn+sy(i,1,l) + s0(i,jjp1,l)=s0s/sms-sy(i,jjp1,l) + enddo + + s0(iip1,1,l)=s0(1,1,l) + s0(iip1,jjp1,l)=s0(1,jjp1,l) + + do i=1,iim + sxn(i)=s0(i+1,1,l)-s0(i,1,l) + sxs(i)=s0(i+1,jjp1,l)-s0(i,jjp1,l) +c on rerentre les masses + enddo + do i=1,iim + sy(i,1,l)=sy(i,1,l)*sm(i,1,l) + sy(i,jjp1,l)=sy(i,jjp1,l)*sm(i,jjp1,l) + s0(i,1,l)=s0(i,1,l)*sm(i,1,l) + s0(i,jjp1,l)=s0(i,jjp1,l)*sm(i,jjp1,l) + enddo + sxn(iip1)=sxn(1) + sxs(iip1)=sxs(1) + do i=1,iim + sx(i+1,1,l)=0.25*(sxn(i)+sxn(i+1))*sm(i+1,1,l) + sx(i+1,jjp1,l)=0.25*(sxs(i)+sxs(i+1))*sm(i+1,jjp1,l) + enddo + s0(iip1,1,l)=s0(1,1,l) + s0(iip1,jjp1,l)=s0(1,jjp1,l) + sy(iip1,1,l)=sy(1,1,l) + sy(iip1,jjp1,l)=sy(1,jjp1,l) + sx(1,1,l)=sx(iip1,1,l) + sx(1,jjp1,l)=sx(iip1,jjp1,l) + enddo + endif + + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limx(s0,sx,sm,pente_max) +c call minmaxq(zq,1.e33,-1.e33,'avant advx ') + call advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf) +c call minmaxq(zq,1.e33,-1.e33,'avant advy ') + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limy(s0,sy,sm,pente_max) + call advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz ) +c call minmaxq(zq,1.e33,-1.e33,'avant advz ') + do j=1,jjp1 + do i=1,iip1 + sz(i,j,1)=0. + sz(i,j,llm)=0. + enddo + enddo + call limz(s0,sz,sm,pente_max) + call advz( limit,dtvr,w,sm,s0,sx,sy,sz ) + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limy(s0,sy,sm,pente_max) + call advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz ) + do l=1,llm + do j=1,jjp1 + sm(iip1,j,l)=sm(1,j,l) + s0(iip1,j,l)=s0(1,j,l) + sx(iip1,j,l)=sx(1,j,l) + sy(iip1,j,l)=sy(1,j,l) + sz(iip1,j,l)=sz(1,j,l) + enddo + enddo + + +c call minmaxq(zq,1.e33,-1.e33,'avant advx ') + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limx(s0,sx,sm,pente_max) + call advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf) +c call minmaxq(zq,1.e33,-1.e33,'apres advx ') +c do l=1,llm +c do j=1,jjp1 +c do i=1,iip1 +c zq=s0(i,j,l)/sm(i,j,l) +c if(zq.lt.qmin) +c , print*,'apres advx2, s0(',i,',',j,',',l,')=',zq +c enddo +c enddo +c enddo +c *** On repasse les S dans la variable q directement 14/10/94 +c On revient a des rapports de melange en divisant par la masse + +c En dehors des poles: + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + q(i,j,llm+1-l,0)=s0(i,j,l)/sm(i,j,l) + q(i,j,llm+1-l,1)=sx(i,j,l)/sm(i,j,l) + q(i,j,llm+1-l,2)=sy(i,j,l)/sm(i,j,l) + q(i,j,llm+1-l,3)=sz(i,j,l)/sm(i,j,l) + ENDDO + ENDDO + ENDDO + +c Traitements specifiques au pole + + if(mode.ge.1) then + DO l=1,llm +c filtrages aux poles + masn=ssum(iim,sm(1,1,l),1) + mass=ssum(iim,sm(1,jjp1,l),1) + qpn=ssum(iim,s0(1,1,l),1)/masn + qps=ssum(iim,s0(1,jjp1,l),1)/mass + dqzpn=ssum(iim,sz(1,1,l),1)/masn + dqzps=ssum(iim,sz(1,jjp1,l),1)/mass + do i=1,iip1 + q( i,1,llm+1-l,3)=dqzpn + q( i,jjp1,llm+1-l,3)=dqzps + q( i,1,llm+1-l,0)=qpn + q( i,jjp1,llm+1-l,0)=qps + enddo + if(mode.eq.3) then + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + do i=1,iim + dyn1=dyn1+sinlondlon(i)*sy(i,1,l)/sm(i,1,l) + dyn2=dyn2+coslondlon(i)*sy(i,1,l)/sm(i,1,l) + dys1=dys1+sinlondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l) + dys2=dys2+coslondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l) + enddo + do i=1,iim + q(i,1,llm+1-l,2)= + s (sinlon(i)*dyn1+coslon(i)*dyn2) + q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2) + q(i,jjp1,llm+1-l,2)= + s (sinlon(i)*dys1+coslon(i)*dys2) + q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) + s -q(i,jjp1,llm+1-l,2) + enddo + endif + if(mode.eq.1) then +c on filtre les valeurs au bord de la "grande maille pole" + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + do i=1,iim + zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0) + dyn1=dyn1+sinlondlon(i)*zz + dyn2=dyn2+coslondlon(i)*zz + zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l) + dys1=dys1+sinlondlon(i)*zz + dys2=dys2+coslondlon(i)*zz + enddo + do i=1,iim + q(i,1,llm+1-l,2)= + s (sinlon(i)*dyn1+coslon(i)*dyn2)/2. + q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2) + q(i,jjp1,llm+1-l,2)= + s (sinlon(i)*dys1+coslon(i)*dys2)/2. + q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) + s -q(i,jjp1,llm+1-l,2) + enddo + q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0) + q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0) + + do i=1,iim + sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0) + sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0) + enddo + sxn(iip1)=sxn(1) + sxs(iip1)=sxs(1) + do i=1,iim + q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1)) + q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1)) + enddo + q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1) + q(1,jjp1,llm+1-l,1)=q(iip1,jjp1,llm+1-l,1) + + endif + + ENDDO + endif + +c bouclage en longitude + do iq=0,3 + do l=1,llm + do j=1,jjp1 + q(iip1,j,l,iq)=q(1,j,l,iq) + enddo + enddo + enddo + +c PRINT*, ' SORTIE DE PENTES --- ca peut glisser ....' + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + IF (q(i,j,l,0).lt.0.) THEN +c PRINT*,'------------ BIP-----------' +c PRINT*,'Q0(',i,j,l,')=',q(i,j,l,0) +c PRINT*,'QX(',i,j,l,')=',q(i,j,l,1) +c PRINT*,'QY(',i,j,l,')=',q(i,j,l,2) +c PRINT*,'QZ(',i,j,l,')=',q(i,j,l,3) +c PRINT*,' PBL EN SORTIE DE PENTES' + q(i,j,l,0)=0. +c STOP + ENDIF + ENDDO + ENDDO + ENDDO + +c PRINT*, '-------------------------------------------' + + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + if(q(i,j,l,0).lt.qmin) + , print*,'apres pentes, s0(',i,',',j,',',l,')=',q(i,j,l,0) + enddo + enddo + enddo + RETURN + END + + + + + + + + + + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ppm3d.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ppm3d.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ppm3d.F (revision 1280) @@ -0,0 +1,2001 @@ +! +! $Header$ +! + +cFrom lin@explorer.gsfc.nasa.gov Wed Apr 15 17:44:44 1998 +cDate: Wed, 15 Apr 1998 11:37:03 -0400 +cFrom: lin@explorer.gsfc.nasa.gov +cTo: Frederic.Hourdin@lmd.jussieu.fr +cSubject: 3D transport module of the GSFC CTM and GEOS GCM + + +cThis code is sent to you by S-J Lin, DAO, NASA-GSFC + +cNote: this version is intended for machines like CRAY +C-90. No multitasking directives implemented. + + +C ******************************************************************** +C +C TransPort Core for Goddard Chemistry Transport Model (G-CTM), Goddard +C Earth Observing System General Circulation Model (GEOS-GCM), and Data +C Assimilation System (GEOS-DAS). +C +C ******************************************************************** +C +C Purpose: given horizontal winds on a hybrid sigma-p surfaces, +C one call to tpcore updates the 3-D mixing ratio +C fields one time step (NDT). [vertical mass flux is computed +C internally consistent with the discretized hydrostatic mass +C continuity equation of the C-Grid GEOS-GCM (for IGD=1)]. +C +C Schemes: Multi-dimensional Flux Form Semi-Lagrangian (FFSL) scheme based +C on the van Leer or PPM. +C (see Lin and Rood 1996). +C Version 4.5 +C Last modified: Dec. 5, 1996 +C Major changes from version 4.0: a more general vertical hybrid sigma- +C pressure coordinate. +C Subroutines modified: xtp, ytp, fzppm, qckxyz +C Subroutines deleted: vanz +C +C Author: Shian-Jiann Lin +C mail address: +C Shian-Jiann Lin* +C Code 910.3, NASA/GSFC, Greenbelt, MD 20771 +C Phone: 301-286-9540 +C E-mail: lin@dao.gsfc.nasa.gov +C +C *affiliation: +C Joint Center for Earth Systems Technology +C The University of Maryland Baltimore County +C NASA - Goddard Space Flight Center +C References: +C +C 1. Lin, S.-J., and R. B. Rood, 1996: Multidimensional flux form semi- +C Lagrangian transport schemes. Mon. Wea. Rev., 124, 2046-2070. +C +C 2. Lin, S.-J., W. C. Chao, Y. C. Sud, and G. K. Walker, 1994: A class of +C the van Leer-type transport schemes and its applications to the moist- +C ure transport in a General Circulation Model. Mon. Wea. Rev., 122, +C 1575-1593. +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C + subroutine ppm3d(IGD,Q,PS1,PS2,U,V,W,NDT,IORD,JORD,KORD,NC,IMR, + & JNP,j1,NLAY,AP,BP,PT,AE,fill,dum,Umax) + +c implicit none + +c rajout de déclarations +c integer Jmax,kmax,ndt0,nstep,k,j,i,ic,l,js,jn,imh,iad,jad,krd +c integer iu,iiu,j2,jmr,js0,jt +c real dtdy,dtdy5,rcap,iml,jn0,imjm,pi,dl,dp +c real dt,cr1,maxdt,ztc,d5,sum1,sum2,ru +C +C ******************************************************************** +C +C ============= +C INPUT: +C ============= +C +C Q(IMR,JNP,NLAY,NC): mixing ratios at current time (t) +C NC: total # of constituents +C IMR: first dimension (E-W); # of Grid intervals in E-W is IMR +C JNP: 2nd dimension (N-S); # of Grid intervals in N-S is JNP-1 +C NLAY: 3rd dimension (# of layers); vertical index increases from 1 at +C the model top to NLAY near the surface (see fig. below). +C It is assumed that 6 <= NLAY <= JNP (for dynamic memory allocation) +C +C PS1(IMR,JNP): surface pressure at current time (t) +C PS2(IMR,JNP): surface pressure at mid-time-level (t+NDT/2) +C PS2 is replaced by the predicted PS (at t+NDT) on output. +C Note: surface pressure can have any unit or can be multiplied by any +C const. +C +C The pressure at layer edges are defined as follows: +C +C p(i,j,k) = AP(k)*PT + BP(k)*PS(i,j) (1) +C +C Where PT is a constant having the same unit as PS. +C AP and BP are unitless constants given at layer edges +C defining the vertical coordinate. +C BP(1) = 0., BP(NLAY+1) = 1. +C The pressure at the model top is PTOP = AP(1)*PT +C +C For pure sigma system set AP(k) = 1 for all k, PT = PTOP, +C BP(k) = sige(k) (sigma at edges), PS = Psfc - PTOP. +C +C Note: the sigma-P coordinate is a subset of Eq. 1, which in turn +C is a subset of the following even more general sigma-P-thelta coord. +C currently under development. +C p(i,j,k) = (AP(k)*PT + BP(k)*PS(i,j))/(D(k)-C(k)*TE**(-1/kapa)) +C +C ///////////////////////////////// +C / \ ------------- PTOP -------------- AP(1), BP(1) +C | +C delp(1) | ........... Q(i,j,1) ............ +C | +C W(1) \ / --------------------------------- AP(2), BP(2) +C +C +C +C W(k-1) / \ --------------------------------- AP(k), BP(k) +C | +C delp(K) | ........... Q(i,j,k) ............ +C | +C W(k) \ / --------------------------------- AP(k+1), BP(k+1) +C +C +C +C / \ --------------------------------- AP(NLAY), BP(NLAY) +C | +C delp(NLAY) | ........... Q(i,j,NLAY) ......... +C | +C W(NLAY)=0 \ / ------------- surface ----------- AP(NLAY+1), BP(NLAY+1) +C ////////////////////////////////// +C +C U(IMR,JNP,NLAY) & V(IMR,JNP,NLAY):winds (m/s) at mid-time-level (t+NDT/2) +C U and V may need to be polar filtered in advance in some cases. +C +C IGD: grid type on which winds are defined. +C IGD = 0: A-Grid [all variables defined at the same point from south +C pole (j=1) to north pole (j=JNP) ] +C +C IGD = 1 GEOS-GCM C-Grid +C [North] +C +C V(i,j) +C | +C | +C | +C U(i-1,j)---Q(i,j)---U(i,j) [EAST] +C | +C | +C | +C V(i,j-1) +C +C U(i, 1) is defined at South Pole. +C V(i, 1) is half grid north of the South Pole. +C V(i,JMR) is half grid south of the North Pole. +C +C V must be defined at j=1 and j=JMR if IGD=1 +C V at JNP need not be given. +C +C NDT: time step in seconds (need not be constant during the course of +C the integration). Suggested value: 30 min. for 4x5, 15 min. for 2x2.5 +C (Lat-Lon) resolution. Smaller values are recommanded if the model +C has a well-resolved stratosphere. +C +C J1 defines the size of the polar cap: +C South polar cap edge is located at -90 + (j1-1.5)*180/(JNP-1) deg. +C North polar cap edge is located at 90 - (j1-1.5)*180/(JNP-1) deg. +C There are currently only two choices (j1=2 or 3). +C IMR must be an even integer if j1 = 2. Recommended value: J1=3. +C +C IORD, JORD, and KORD are integers controlling various options in E-W, N-S, +C and vertical transport, respectively. Recommended values for positive +C definite scalars: IORD=JORD=3, KORD=5. Use KORD=3 for non- +C positive definite scalars or when linear correlation between constituents +C is to be maintained. +C +C _ORD= +C 1: 1st order upstream scheme (too diffusive, not a useful option; it +C can be used for debugging purposes; this is THE only known "linear" +C monotonic advection scheme.). +C 2: 2nd order van Leer (full monotonicity constraint; +C see Lin et al 1994, MWR) +C 3: monotonic PPM* (slightly improved PPM of Collela & Woodward 1984) +C 4: semi-monotonic PPM (same as 3, but overshoots are allowed) +C 5: positive-definite PPM (constraint on the subgrid distribution is +C only strong enough to prevent generation of negative values; +C both overshoots & undershoots are possible). +C 6: un-constrained PPM (nearly diffusion free; slightly faster but +C positivity not quaranteed. Use this option only when the fields +C and winds are very smooth). +C +C *PPM: Piece-wise Parabolic Method +C +C Note that KORD <=2 options are no longer supported. DO not use option 4 or 5. +C for non-positive definite scalars (such as Ertel Potential Vorticity). +C +C The implicit numerical diffusion decreases as _ORD increases. +C The last two options (ORDER=5, 6) should only be used when there is +C significant explicit diffusion (such as a turbulence parameterization). You +C might get dispersive results otherwise. +C No filter of any kind is applied to the constituent fields here. +C +C AE: Radius of the sphere (meters). +C Recommended value for the planet earth: 6.371E6 +C +C fill(logical): flag to do filling for negatives (see note below). +C +C Umax: Estimate (upper limit) of the maximum U-wind speed (m/s). +C (220 m/s is a good value for troposphere model; 280 m/s otherwise) +C +C ============= +C Output +C ============= +C +C Q: mixing ratios at future time (t+NDT) (original values are over-written) +C W(NLAY): large-scale vertical mass flux as diagnosed from the hydrostatic +C relationship. W will have the same unit as PS1 and PS2 (eg, mb). +C W must be divided by NDT to get the correct mass-flux unit. +C The vertical Courant number C = W/delp_UPWIND, where delp_UPWIND +C is the pressure thickness in the "upwind" direction. For example, +C C(k) = W(k)/delp(k) if W(k) > 0; +C C(k) = W(k)/delp(k+1) if W(k) < 0. +C ( W > 0 is downward, ie, toward surface) +C PS2: predicted PS at t+NDT (original values are over-written) +C +C ******************************************************************** +C NOTES: +C This forward-in-time upstream-biased transport scheme reduces to +C the 2nd order center-in-time center-in-space mass continuity eqn. +C if Q = 1 (constant fields will remain constant). This also ensures +C that the computed vertical velocity to be identical to GEOS-1 GCM +C for on-line transport. +C +C A larger polar cap is used if j1=3 (recommended for C-Grid winds or when +C winds are noisy near poles). +C +C Flux-Form Semi-Lagrangian transport in the East-West direction is used +C when and where Courant # is greater than one. +C +C The user needs to change the parameter Jmax or Kmax if the resolution +C is greater than 0.5 deg in N-S or 150 layers in the vertical direction. +C (this TransPort Core is otherwise resolution independent and can be used +C as a library routine). +C +C PPM is 4th order accurate when grid spacing is uniform (x & y); 3rd +C order accurate for non-uniform grid (vertical sigma coord.). +C +C Time step is limitted only by transport in the meridional direction. +C (the FFSL scheme is not implemented in the meridional direction). +C +C Since only 1-D limiters are applied, negative values could +C potentially be generated when large time step is used and when the +C initial fields contain discontinuities. +C This does not necessarily imply the integration is unstable. +C These negatives are typically very small. A filling algorithm is +C activated if the user set "fill" to be true. +C +C The van Leer scheme used here is nearly as accurate as the original PPM +C due to the use of a 4th order accurate reference slope. The PPM imple- +C mented here is an improvement over the original and is also based on +C the 4th order reference slope. +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C +C User modifiable parameters +C + parameter (Jmax = 361, kmax = 150) +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C +C Input-Output arrays +C + + real Q(IMR,JNP,NLAY,NC),PS1(IMR,JNP),PS2(IMR,JNP), + & U(IMR,JNP,NLAY),V(IMR,JNP,NLAY),AP(NLAY+1), + & BP(NLAY+1),W(IMR,JNP,NLAY),NDT,val(NLAY),Umax + integer IGD,IORD,JORD,KORD,NC,IMR,JNP,j1,NLAY,AE + integer IMRD2 + real PT + logical cross, fill, dum +C +C Local dynamic arrays +C + real CRX(IMR,JNP),CRY(IMR,JNP),xmass(IMR,JNP),ymass(IMR,JNP), + & fx1(IMR+1),DPI(IMR,JNP,NLAY),delp1(IMR,JNP,NLAY), + & WK1(IMR,JNP,NLAY),PU(IMR,JNP),PV(IMR,JNP),DC2(IMR,JNP), + & delp2(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY,NC),VA(IMR,JNP), + & UA(IMR,JNP),qtmp(-IMR:2*IMR) +C +C Local static arrays +C + real DTDX(Jmax), DTDX5(Jmax), acosp(Jmax), + & cosp(Jmax), cose(Jmax), DAP(kmax),DBK(Kmax) + data NDT0, NSTEP /0, 0/ + data cross /.true./ + SAVE DTDY, DTDY5, RCAP, JS0, JN0, IML, + & DTDX, DTDX5, ACOSP, COSP, COSE, DAP,DBK +C + + JMR = JNP -1 + IMJM = IMR*JNP + j2 = JNP - j1 + 1 + NSTEP = NSTEP + 1 +C +C *********** Initialization ********************** + if(NSTEP.eq.1) then +c + write(6,*) '------------------------------------ ' + write(6,*) 'NASA/GSFC Transport Core Version 4.5' + write(6,*) '------------------------------------ ' +c + WRITE(6,*) 'IMR=',IMR,' JNP=',JNP,' NLAY=',NLAY,' j1=',j1 + WRITE(6,*) 'NC=',NC,IORD,JORD,KORD,NDT +C +C controles sur les parametres + if(NLAY.LT.6) then + write(6,*) 'NLAY must be >= 6' + stop + endif + if (JNP.LT.NLAY) then + write(6,*) 'JNP must be >= NLAY' + stop + endif + IMRD2=mod(IMR,2) + if (j1.eq.2.and.IMRD2.NE.0) then + write(6,*) 'if j1=2 IMR must be an even integer' + stop + endif + +C + if(Jmax.lt.JNP .or. Kmax.lt.NLAY) then + write(6,*) 'Jmax or Kmax is too small' + stop + endif +C + DO k=1,NLAY + DAP(k) = (AP(k+1) - AP(k))*PT + DBK(k) = BP(k+1) - BP(k) + ENDDO +C + PI = 4. * ATAN(1.) + DL = 2.*PI / float(IMR) + DP = PI / float(JMR) +C + if(IGD.eq.0) then +C Compute analytic cosine at cell edges + call cosa(cosp,cose,JNP,PI,DP) + else +C Define cosine consistent with GEOS-GCM (using dycore2.0 or later) + call cosc(cosp,cose,JNP,PI,DP) + endif +C + do 15 J=2,JMR +15 acosp(j) = 1. / cosp(j) +C +C Inverse of the Scaled polar cap area. +C + RCAP = DP / (IMR*(1.-COS((j1-1.5)*DP))) + acosp(1) = RCAP + acosp(JNP) = RCAP + endif +C + if(NDT0 .ne. NDT) then + DT = NDT + NDT0 = NDT + + if(Umax .lt. 180.) then + write(6,*) 'Umax may be too small!' + endif + CR1 = abs(Umax*DT)/(DL*AE) + MaxDT = DP*AE / abs(Umax) + 0.5 + write(6,*)'Largest time step for max(V)=',Umax,' is ',MaxDT + if(MaxDT .lt. abs(NDT)) then + write(6,*) 'Warning!!! NDT maybe too large!' + endif +C + if(CR1.ge.0.95) then + JS0 = 0 + JN0 = 0 + IML = IMR-2 + ZTC = 0. + else + ZTC = acos(CR1) * (180./PI) +C + JS0 = float(JMR)*(90.-ZTC)/180. + 2 + JS0 = max(JS0, J1+1) + IML = min(6*JS0/(J1-1)+2, 4*IMR/5) + JN0 = JNP-JS0+1 + endif +C +C + do J=2,JMR + DTDX(j) = DT / ( DL*AE*COSP(J) ) + +c print*,'dtdx=',dtdx(j) + DTDX5(j) = 0.5*DTDX(j) + enddo +C + + DTDY = DT /(AE*DP) +c print*,'dtdy=',dtdy + DTDY5 = 0.5*DTDY +C +c write(6,*) 'J1=',J1,' J2=', J2 + endif +C +C *********** End Initialization ********************** +C +C delp = pressure thickness: the psudo-density in a hydrostatic system. + do k=1,NLAY + do j=1,JNP + do i=1,IMR + delp1(i,j,k)=DAP(k)+DBK(k)*PS1(i,j) + delp2(i,j,k)=DAP(k)+DBK(k)*PS2(i,j) + enddo + enddo + enddo + +C + if(j1.ne.2) then + DO 40 IC=1,NC + DO 40 L=1,NLAY + DO 40 I=1,IMR + Q(I, 2,L,IC) = Q(I, 1,L,IC) +40 Q(I,JMR,L,IC) = Q(I,JNP,L,IC) + endif +C +C Compute "tracer density" + DO 550 IC=1,NC + DO 44 k=1,NLAY + DO 44 j=1,JNP + DO 44 i=1,IMR +44 DQ(i,j,k,IC) = Q(i,j,k,IC)*delp1(i,j,k) +550 continue +C + do 1500 k=1,NLAY +C + if(IGD.eq.0) then +C Convert winds on A-Grid to Courant # on C-Grid. + call A2C(U(1,1,k),V(1,1,k),IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5) + else +C Convert winds on C-grid to Courant # + do 45 j=j1,j2 + do 45 i=2,IMR +45 CRX(i,J) = dtdx(j)*U(i-1,j,k) + +C + do 50 j=j1,j2 +50 CRX(1,J) = dtdx(j)*U(IMR,j,k) +C + do 55 i=1,IMR*JMR +55 CRY(i,2) = DTDY*V(i,1,k) + endif +C +C Determine JS and JN + JS = j1 + JN = j2 +C + do j=JS0,j1+1,-1 + do i=1,IMR + if(abs(CRX(i,j)).GT.1.) then + JS = j + go to 2222 + endif + enddo + enddo +C +2222 continue + do j=JN0,j2-1 + do i=1,IMR + if(abs(CRX(i,j)).GT.1.) then + JN = j + go to 2233 + endif + enddo + enddo +2233 continue +C + if(j1.ne.2) then ! Enlarged polar cap. + do i=1,IMR + DPI(i, 2,k) = 0. + DPI(i,JMR,k) = 0. + enddo + endif +C +C ******* Compute horizontal mass fluxes ************ +C +C N-S component + do j=j1,j2+1 + D5 = 0.5 * COSE(j) + do i=1,IMR + ymass(i,j) = CRY(i,j)*D5*(delp2(i,j,k) + delp2(i,j-1,k)) + enddo + enddo +C + do 95 j=j1,j2 + DO 95 i=1,IMR +95 DPI(i,j,k) = (ymass(i,j) - ymass(i,j+1)) * acosp(j) +C +C Poles + sum1 = ymass(IMR,j1 ) + sum2 = ymass(IMR,J2+1) + do i=1,IMR-1 + sum1 = sum1 + ymass(i,j1 ) + sum2 = sum2 + ymass(i,J2+1) + enddo +C + sum1 = - sum1 * RCAP + sum2 = sum2 * RCAP + do i=1,IMR + DPI(i, 1,k) = sum1 + DPI(i,JNP,k) = sum2 + enddo +C +C E-W component +C + do j=j1,j2 + do i=2,IMR + PU(i,j) = 0.5 * (delp2(i,j,k) + delp2(i-1,j,k)) + enddo + enddo +C + do j=j1,j2 + PU(1,j) = 0.5 * (delp2(1,j,k) + delp2(IMR,j,k)) + enddo +C + do 110 j=j1,j2 + DO 110 i=1,IMR +110 xmass(i,j) = PU(i,j)*CRX(i,j) +C + DO 120 j=j1,j2 + DO 120 i=1,IMR-1 +120 DPI(i,j,k) = DPI(i,j,k) + xmass(i,j) - xmass(i+1,j) +C + DO 130 j=j1,j2 +130 DPI(IMR,j,k) = DPI(IMR,j,k) + xmass(IMR,j) - xmass(1,j) +C + DO j=j1,j2 + do i=1,IMR-1 + UA(i,j) = 0.5 * (CRX(i,j)+CRX(i+1,j)) + enddo + enddo +C + DO j=j1,j2 + UA(imr,j) = 0.5 * (CRX(imr,j)+CRX(1,j)) + enddo +ccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c Rajouts pour LMDZ.3.3 +ccccccccccccccccccccccccccccccccccccccccccccccccccccccc + do i=1,IMR + do j=1,JNP + VA(i,j)=0. + enddo + enddo + + do i=1,imr*(JMR-1) + VA(i,2) = 0.5*(CRY(i,2)+CRY(i,3)) + enddo +C + if(j1.eq.2) then + IMH = IMR/2 + do i=1,IMH + VA(i, 1) = 0.5*(CRY(i,2)-CRY(i+IMH,2)) + VA(i+IMH, 1) = -VA(i,1) + VA(i, JNP) = 0.5*(CRY(i,JNP)-CRY(i+IMH,JMR)) + VA(i+IMH,JNP) = -VA(i,JNP) + enddo + VA(IMR,1)=VA(1,1) + VA(IMR,JNP)=VA(1,JNP) + endif +C +C ****6***0*********0*********0*********0*********0*********0**********72 + do 1000 IC=1,NC +C + do i=1,IMJM + wk1(i,1,1) = 0. + wk1(i,1,2) = 0. + enddo +C +C E-W advective cross term + do 250 j=J1,J2 + if(J.GT.JS .and. J.LT.JN) GO TO 250 +C + do i=1,IMR + qtmp(i) = q(i,j,k,IC) + enddo +C + do i=-IML,0 + qtmp(i) = q(IMR+i,j,k,IC) + qtmp(IMR+1-i) = q(1-i,j,k,IC) + enddo +C + DO 230 i=1,IMR + iu = UA(i,j) + ru = UA(i,j) - iu + iiu = i-iu + if(UA(i,j).GE.0.) then + wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu)) + else + wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1)) + endif + wk1(i,j,1) = wk1(i,j,1) - qtmp(i) +230 continue +250 continue +C + if(JN.ne.0) then + do j=JS+1,JN-1 +C + do i=1,IMR + qtmp(i) = q(i,j,k,IC) + enddo +C + qtmp(0) = q(IMR,J,k,IC) + qtmp(IMR+1) = q( 1,J,k,IC) +C + do i=1,imr + iu = i - UA(i,j) + wk1(i,j,1) = UA(i,j)*(qtmp(iu) - qtmp(iu+1)) + enddo + enddo + endif +C ****6***0*********0*********0*********0*********0*********0**********72 +C Contribution from the N-S advection + do i=1,imr*(j2-j1+1) + JT = float(J1) - VA(i,j1) + wk1(i,j1,2) = VA(i,j1) * (q(i,jt,k,IC) - q(i,jt+1,k,IC)) + enddo +C + do i=1,IMJM + wk1(i,1,1) = q(i,1,k,IC) + 0.5*wk1(i,1,1) + wk1(i,1,2) = q(i,1,k,IC) + 0.5*wk1(i,1,2) + enddo +C + if(cross) then +C Add cross terms in the vertical direction. + if(IORD .GE. 2) then + iad = 2 + else + iad = 1 + endif +C + if(JORD .GE. 2) then + jad = 2 + else + jad = 1 + endif + call xadv(IMR,JNP,j1,j2,wk1(1,1,2),UA,JS,JN,IML,DC2,iad) + call yadv(IMR,JNP,j1,j2,wk1(1,1,1),VA,PV,W,jad) + do j=1,JNP + do i=1,IMR + q(i,j,k,IC) = q(i,j,k,IC) + DC2(i,j) + PV(i,j) + enddo + enddo + endif +C + call xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ(1,1,k,IC),wk1(1,1,2) + & ,CRX,fx1,xmass,IORD) + + call ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ(1,1,k,IC),wk1(1,1,1),CRY, + & DC2,ymass,WK1(1,1,3),wk1(1,1,4),WK1(1,1,5),WK1(1,1,6),JORD) +C +1000 continue +1500 continue +C +C ******* Compute vertical mass flux (same unit as PS) *********** +C +C 1st step: compute total column mass CONVERGENCE. +C + do 320 j=1,JNP + do 320 i=1,IMR +320 CRY(i,j) = DPI(i,j,1) +C + do 330 k=2,NLAY + do 330 j=1,JNP + do 330 i=1,IMR + CRY(i,j) = CRY(i,j) + DPI(i,j,k) +330 continue +C + do 360 j=1,JNP + do 360 i=1,IMR +C +C 2nd step: compute PS2 (PS at n+1) using the hydrostatic assumption. +C Changes (increases) to surface pressure = total column mass convergence +C + PS2(i,j) = PS1(i,j) + CRY(i,j) +C +C 3rd step: compute vertical mass flux from mass conservation principle. +C + W(i,j,1) = DPI(i,j,1) - DBK(1)*CRY(i,j) + W(i,j,NLAY) = 0. +360 continue +C + do 370 k=2,NLAY-1 + do 370 j=1,JNP + do 370 i=1,IMR + W(i,j,k) = W(i,j,k-1) + DPI(i,j,k) - DBK(k)*CRY(i,j) +370 continue +C + DO 380 k=1,NLAY + DO 380 j=1,JNP + DO 380 i=1,IMR + delp2(i,j,k) = DAP(k) + DBK(k)*PS2(i,j) +380 continue +C + KRD = max(3, KORD) + do 4000 IC=1,NC +C +C****6***0*********0*********0*********0*********0*********0**********72 + + call FZPPM(IMR,JNP,NLAY,j1,DQ(1,1,1,IC),W,Q(1,1,1,IC),WK1,DPI, + & DC2,CRX,CRY,PU,PV,xmass,ymass,delp1,KRD) +C + + if(fill) call qckxyz(DQ(1,1,1,IC),DC2,IMR,JNP,NLAY,j1,j2, + & cosp,acosp,.false.,IC,NSTEP) +C +C Recover tracer mixing ratio from "density" using predicted +C "air density" (pressure thickness) at time-level n+1 +C + DO k=1,NLAY + DO j=1,JNP + DO i=1,IMR + Q(i,j,k,IC) = DQ(i,j,k,IC) / delp2(i,j,k) +c print*,'i=',i,'j=',j,'k=',k,'Q(i,j,k,IC)=',Q(i,j,k,IC) + enddo + enddo + enddo +C + if(j1.ne.2) then + DO 400 k=1,NLAY + DO 400 I=1,IMR +c j=1 c'est le pôle Sud, j=JNP c'est le pôle Nord + Q(I, 2,k,IC) = Q(I, 1,k,IC) + Q(I,JMR,k,IC) = Q(I,JNP,k,IC) +400 CONTINUE + endif +4000 continue +C + if(j1.ne.2) then + DO 5000 k=1,NLAY + DO 5000 i=1,IMR + W(i, 2,k) = W(i, 1,k) + W(i,JMR,k) = W(i,JNP,k) +5000 continue + endif +C + RETURN + END +C +C****6***0*********0*********0*********0*********0*********0**********72 + subroutine FZPPM(IMR,JNP,NLAY,j1,DQ,WZ,P,DC,DQDT,AR,AL,A6, + & flux,wk1,wk2,wz2,delp,KORD) + parameter ( kmax = 150 ) + parameter ( R23 = 2./3., R3 = 1./3.) + real WZ(IMR,JNP,NLAY),P(IMR,JNP,NLAY),DC(IMR,JNP,NLAY), + & wk1(IMR,*),delp(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY), + & DQDT(IMR,JNP,NLAY) +C Assuming JNP >= NLAY + real AR(IMR,*),AL(IMR,*),A6(IMR,*),flux(IMR,*),wk2(IMR,*), + & wz2(IMR,*) +C + JMR = JNP - 1 + IMJM = IMR*JNP + NLAYM1 = NLAY - 1 +C + LMT = KORD - 3 +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C Compute DC for PPM +C ****6***0*********0*********0*********0*********0*********0**********72 +C + do 1000 k=1,NLAYM1 + do 1000 i=1,IMJM + DQDT(i,1,k) = P(i,1,k+1) - P(i,1,k) +1000 continue +C + DO 1220 k=2,NLAYM1 + DO 1220 I=1,IMJM + c0 = delp(i,1,k) / (delp(i,1,k-1)+delp(i,1,k)+delp(i,1,k+1)) + c1 = (delp(i,1,k-1)+0.5*delp(i,1,k))/(delp(i,1,k+1)+delp(i,1,k)) + c2 = (delp(i,1,k+1)+0.5*delp(i,1,k))/(delp(i,1,k-1)+delp(i,1,k)) + tmp = c0*(c1*DQDT(i,1,k) + c2*DQDT(i,1,k-1)) + Qmax = max(P(i,1,k-1),P(i,1,k),P(i,1,k+1)) - P(i,1,k) + Qmin = P(i,1,k) - min(P(i,1,k-1),P(i,1,k),P(i,1,k+1)) + DC(i,1,k) = sign(min(abs(tmp),Qmax,Qmin), tmp) +1220 CONTINUE + +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C Loop over latitudes (to save memory) +C ****6***0*********0*********0*********0*********0*********0**********72 +C + DO 2000 j=1,JNP + if((j.eq.2 .or. j.eq.JMR) .and. j1.ne.2) goto 2000 +C + DO k=1,NLAY + DO i=1,IMR + wz2(i,k) = WZ(i,j,k) + wk1(i,k) = P(i,j,k) + wk2(i,k) = delp(i,j,k) + flux(i,k) = DC(i,j,k) !this flux is actually the monotone slope + enddo + enddo +C +C****6***0*********0*********0*********0*********0*********0**********72 +C Compute first guesses at cell interfaces +C First guesses are required to be continuous. +C ****6***0*********0*********0*********0*********0*********0**********72 +C +C three-cell parabolic subgrid distribution at model top +C two-cell parabolic with zero gradient subgrid distribution +C at the surface. +C +C First guess top edge value + DO 10 i=1,IMR +C three-cell PPM +C Compute a,b, and c of q = aP**2 + bP + c using cell averages and delp + a = 3.*( DQDT(i,j,2) - DQDT(i,j,1)*(wk2(i,2)+wk2(i,3))/ + & (wk2(i,1)+wk2(i,2)) ) / + & ( (wk2(i,2)+wk2(i,3))*(wk2(i,1)+wk2(i,2)+wk2(i,3)) ) + b = 2.*DQDT(i,j,1)/(wk2(i,1)+wk2(i,2)) - + & R23*a*(2.*wk2(i,1)+wk2(i,2)) + AL(i,1) = wk1(i,1) - wk2(i,1)*(R3*a*wk2(i,1) + 0.5*b) + AL(i,2) = wk2(i,1)*(a*wk2(i,1) + b) + AL(i,1) +C +C Check if change sign + if(wk1(i,1)*AL(i,1).le.0.) then + AL(i,1) = 0. + flux(i,1) = 0. + else + flux(i,1) = wk1(i,1) - AL(i,1) + endif +10 continue +C +C Bottom + DO 15 i=1,IMR +C 2-cell PPM with zero gradient right at the surface +C + fct = DQDT(i,j,NLAYM1)*wk2(i,NLAY)**2 / + & ( (wk2(i,NLAY)+wk2(i,NLAYM1))*(2.*wk2(i,NLAY)+wk2(i,NLAYM1))) + AR(i,NLAY) = wk1(i,NLAY) + fct + AL(i,NLAY) = wk1(i,NLAY) - (fct+fct) + if(wk1(i,NLAY)*AR(i,NLAY).le.0.) AR(i,NLAY) = 0. + flux(i,NLAY) = AR(i,NLAY) - wk1(i,NLAY) +15 continue + +C +C****6***0*********0*********0*********0*********0*********0**********72 +C 4th order interpolation in the interior. +C****6***0*********0*********0*********0*********0*********0**********72 +C + DO 14 k=3,NLAYM1 + DO 12 i=1,IMR + c1 = DQDT(i,j,k-1)*wk2(i,k-1) / (wk2(i,k-1)+wk2(i,k)) + c2 = 2. / (wk2(i,k-2)+wk2(i,k-1)+wk2(i,k)+wk2(i,k+1)) + A1 = (wk2(i,k-2)+wk2(i,k-1)) / (2.*wk2(i,k-1)+wk2(i,k)) + A2 = (wk2(i,k )+wk2(i,k+1)) / (2.*wk2(i,k)+wk2(i,k-1)) + AL(i,k) = wk1(i,k-1) + c1 + c2 * + & ( wk2(i,k )*(c1*(A1 - A2)+A2*flux(i,k-1)) - + & wk2(i,k-1)*A1*flux(i,k) ) +C print *,'AL1',i,k, AL(i,k) +12 CONTINUE +14 continue +C + do 20 i=1,IMR*NLAYM1 + AR(i,1) = AL(i,2) +C print *,'AR1',i,AR(i,1) +20 continue +C + do 30 i=1,IMR*NLAY + A6(i,1) = 3.*(wk1(i,1)+wk1(i,1) - (AL(i,1)+AR(i,1))) +C print *,'A61',i,A6(i,1) +30 continue +C +C****6***0*********0*********0*********0*********0*********0**********72 +C Top & Bot always monotonic + call lmtppm(flux(1,1),A6(1,1),AR(1,1),AL(1,1),wk1(1,1),IMR,0) + call lmtppm(flux(1,NLAY),A6(1,NLAY),AR(1,NLAY),AL(1,NLAY), + & wk1(1,NLAY),IMR,0) +C +C Interior depending on KORD + if(LMT.LE.2) + & call lmtppm(flux(1,2),A6(1,2),AR(1,2),AL(1,2),wk1(1,2), + & IMR*(NLAY-2),LMT) +C +C****6***0*********0*********0*********0*********0*********0**********72 +C + DO 140 i=1,IMR*NLAYM1 + IF(wz2(i,1).GT.0.) then + CM = wz2(i,1) / wk2(i,1) + flux(i,2) = AR(i,1)+0.5*CM*(AL(i,1)-AR(i,1)+A6(i,1)*(1.-R23*CM)) + else +C print *,'test2-0',i,j,wz2(i,1),wk2(i,2) + CP= wz2(i,1) / wk2(i,2) +C print *,'testCP',CP + flux(i,2) = AL(i,2)+0.5*CP*(AL(i,2)-AR(i,2)-A6(i,2)*(1.+R23*CP)) +C print *,'test2',i, AL(i,2),AR(i,2),A6(i,2),R23 + endif +140 continue +C + DO 250 i=1,IMR*NLAYM1 + flux(i,2) = wz2(i,1) * flux(i,2) +250 continue +C + do 350 i=1,IMR + DQ(i,j, 1) = DQ(i,j, 1) - flux(i, 2) + DQ(i,j,NLAY) = DQ(i,j,NLAY) + flux(i,NLAY) +350 continue +C + do 360 k=2,NLAYM1 + do 360 i=1,IMR +360 DQ(i,j,k) = DQ(i,j,k) + flux(i,k) - flux(i,k+1) +2000 continue + return + end +C + subroutine xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ,Q,UC, + & fx1,xmass,IORD) + dimension UC(IMR,*),DC(-IML:IMR+IML+1),xmass(IMR,JNP) + & ,fx1(IMR+1),DQ(IMR,JNP),qtmp(-IML:IMR+1+IML) + dimension PU(IMR,JNP),Q(IMR,JNP),ISAVE(IMR) +C + IMP = IMR + 1 +C +C van Leer at high latitudes + jvan = max(1,JNP/18) + j1vl = j1+jvan + j2vl = j2-jvan +C + do 1310 j=j1,j2 +C + do i=1,IMR + qtmp(i) = q(i,j) + enddo +C + if(j.ge.JN .or. j.le.JS) goto 2222 +C ************* Eulerian ********** +C + qtmp(0) = q(IMR,J) + qtmp(-1) = q(IMR-1,J) + qtmp(IMP) = q(1,J) + qtmp(IMP+1) = q(2,J) +C + IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN + DO 1406 i=1,IMR + iu = float(i) - uc(i,j) +1406 fx1(i) = qtmp(iu) + ELSE + call xmist(IMR,IML,Qtmp,DC) + DC(0) = DC(IMR) +C + if(IORD.eq.2 .or. j.le.j1vl .or. j.ge.j2vl) then + DO 1408 i=1,IMR + iu = float(i) - uc(i,j) +1408 fx1(i) = qtmp(iu) + DC(iu)*(sign(1.,uc(i,j))-uc(i,j)) + else + call fxppm(IMR,IML,UC(1,j),Qtmp,DC,fx1,IORD) + endif +C + ENDIF +C + DO 1506 i=1,IMR +1506 fx1(i) = fx1(i)*xmass(i,j) +C + goto 1309 +C +C ***** Conservative (flux-form) Semi-Lagrangian transport ***** +C +2222 continue +C + do i=-IML,0 + qtmp(i) = q(IMR+i,j) + qtmp(IMP-i) = q(1-i,j) + enddo +C + IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN + DO 1306 i=1,IMR + itmp = INT(uc(i,j)) + ISAVE(i) = i - itmp + iu = i - uc(i,j) +1306 fx1(i) = (uc(i,j) - itmp)*qtmp(iu) + ELSE + call xmist(IMR,IML,Qtmp,DC) +C + do i=-IML,0 + DC(i) = DC(IMR+i) + DC(IMP-i) = DC(1-i) + enddo +C + DO 1307 i=1,IMR + itmp = INT(uc(i,j)) + rut = uc(i,j) - itmp + ISAVE(i) = i - itmp + iu = i - uc(i,j) +1307 fx1(i) = rut*(qtmp(iu) + DC(iu)*(sign(1.,rut) - rut)) + ENDIF +C + do 1308 i=1,IMR + IF(uc(i,j).GT.1.) then +CDIR$ NOVECTOR + do ist = ISAVE(i),i-1 + fx1(i) = fx1(i) + qtmp(ist) + enddo + elseIF(uc(i,j).LT.-1.) then + do ist = i,ISAVE(i)-1 + fx1(i) = fx1(i) - qtmp(ist) + enddo +CDIR$ VECTOR + endif +1308 continue + do i=1,IMR + fx1(i) = PU(i,j)*fx1(i) + enddo +C +C *************************************** +C +1309 fx1(IMP) = fx1(1) + DO 1215 i=1,IMR +1215 DQ(i,j) = DQ(i,j) + fx1(i)-fx1(i+1) +C +C *************************************** +C +1310 continue + return + end +C + subroutine fxppm(IMR,IML,UT,P,DC,flux,IORD) + parameter ( R3 = 1./3., R23 = 2./3. ) + DIMENSION UT(*),flux(*),P(-IML:IMR+IML+1),DC(-IML:IMR+IML+1) + DIMENSION AR(0:IMR),AL(0:IMR),A6(0:IMR) + integer LMT +c logical first +c data first /.true./ +c SAVE LMT +c if(first) then +C +C correction calcul de LMT a chaque passage pour pouvoir choisir +c plusieurs schemas PPM pour differents traceurs +c IF (IORD.LE.0) then +c if(IMR.GE.144) then +c LMT = 0 +c elseif(IMR.GE.72) then +c LMT = 1 +c else +c LMT = 2 +c endif +c else +c LMT = IORD - 3 +c endif +C + LMT = IORD - 3 +c write(6,*) 'PPM option in E-W direction = ', LMT +c first = .false. +C endif +C + DO 10 i=1,IMR +10 AL(i) = 0.5*(p(i-1)+p(i)) + (DC(i-1) - DC(i))*R3 +C + do 20 i=1,IMR-1 +20 AR(i) = AL(i+1) + AR(IMR) = AL(1) +C + do 30 i=1,IMR +30 A6(i) = 3.*(p(i)+p(i) - (AL(i)+AR(i))) +C + if(LMT.LE.2) call lmtppm(DC(1),A6(1),AR(1),AL(1),P(1),IMR,LMT) +C + AL(0) = AL(IMR) + AR(0) = AR(IMR) + A6(0) = A6(IMR) +C + DO i=1,IMR + IF(UT(i).GT.0.) then + flux(i) = AR(i-1) + 0.5*UT(i)*(AL(i-1) - AR(i-1) + + & A6(i-1)*(1.-R23*UT(i)) ) + else + flux(i) = AL(i) - 0.5*UT(i)*(AR(i) - AL(i) + + & A6(i)*(1.+R23*UT(i))) + endif + enddo + return + end +C + subroutine xmist(IMR,IML,P,DC) + parameter( R24 = 1./24.) + dimension P(-IML:IMR+1+IML),DC(-IML:IMR+1+IML) +C + do 10 i=1,IMR + tmp = R24*(8.*(p(i+1) - p(i-1)) + p(i-2) - p(i+2)) + Pmax = max(P(i-1), p(i), p(i+1)) - p(i) + Pmin = p(i) - min(P(i-1), p(i), p(i+1)) +10 DC(i) = sign(min(abs(tmp),Pmax,Pmin), tmp) + return + end +C + subroutine ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ,P,VC,DC2 + & ,ymass,fx,A6,AR,AL,JORD) + dimension P(IMR,JNP),VC(IMR,JNP),ymass(IMR,JNP) + & ,DC2(IMR,JNP),DQ(IMR,JNP),acosp(JNP) +C Work array + DIMENSION fx(IMR,JNP),AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP) +C + JMR = JNP - 1 + len = IMR*(J2-J1+2) +C + if(JORD.eq.1) then + DO 1000 i=1,len + JT = float(J1) - VC(i,J1) +1000 fx(i,j1) = p(i,JT) + else + + call ymist(IMR,JNP,j1,P,DC2,4) +C + if(JORD.LE.0 .or. JORD.GE.3) then + + call fyppm(VC,P,DC2,fx,IMR,JNP,j1,j2,A6,AR,AL,JORD) + + else + DO 1200 i=1,len + JT = float(J1) - VC(i,J1) +1200 fx(i,j1) = p(i,JT) + (sign(1.,VC(i,j1))-VC(i,j1))*DC2(i,JT) + endif + endif +C + DO 1300 i=1,len +1300 fx(i,j1) = fx(i,j1)*ymass(i,j1) +C + DO 1400 j=j1,j2 + DO 1400 i=1,IMR +1400 DQ(i,j) = DQ(i,j) + (fx(i,j) - fx(i,j+1)) * acosp(j) +C +C Poles + sum1 = fx(IMR,j1 ) + sum2 = fx(IMR,J2+1) + do i=1,IMR-1 + sum1 = sum1 + fx(i,j1 ) + sum2 = sum2 + fx(i,J2+1) + enddo +C + sum1 = DQ(1, 1) - sum1 * RCAP + sum2 = DQ(1,JNP) + sum2 * RCAP + do i=1,IMR + DQ(i, 1) = sum1 + DQ(i,JNP) = sum2 + enddo +C + if(j1.ne.2) then + do i=1,IMR + DQ(i, 2) = sum1 + DQ(i,JMR) = sum2 + enddo + endif +C + return + end +C + subroutine ymist(IMR,JNP,j1,P,DC,ID) + parameter ( R24 = 1./24. ) + dimension P(IMR,JNP),DC(IMR,JNP) +C + IMH = IMR / 2 + JMR = JNP - 1 + IJM3 = IMR*(JMR-3) +C + IF(ID.EQ.2) THEN + do 10 i=1,IMR*(JMR-1) + tmp = 0.25*(p(i,3) - p(i,1)) + Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2) + Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3)) + DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp) +10 CONTINUE + ELSE + do 12 i=1,IMH +C J=2 + tmp = (8.*(p(i,3) - p(i,1)) + p(i+IMH,2) - p(i,4))*R24 + Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2) + Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3)) + DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp) +C J=JMR + tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i+IMH,JMR))*R24 + Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR) + Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP)) + DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp) +12 CONTINUE + do 14 i=IMH+1,IMR +C J=2 + tmp = (8.*(p(i,3) - p(i,1)) + p(i-IMH,2) - p(i,4))*R24 + Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2) + Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3)) + DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp) +C J=JMR + tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i-IMH,JMR))*R24 + Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR) + Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP)) + DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp) +14 CONTINUE +C + do 15 i=1,IJM3 + tmp = (8.*(p(i,4) - p(i,2)) + p(i,1) - p(i,5))*R24 + Pmax = max(p(i,2),p(i,3),p(i,4)) - p(i,3) + Pmin = p(i,3) - min(p(i,2),p(i,3),p(i,4)) + DC(i,3) = sign(min(abs(tmp),Pmin,Pmax),tmp) +15 CONTINUE + ENDIF +C + if(j1.ne.2) then + do i=1,IMR + DC(i,1) = 0. + DC(i,JNP) = 0. + enddo + else +C Determine slopes in polar caps for scalars! +C + do 13 i=1,IMH +C South + tmp = 0.25*(p(i,2) - p(i+imh,2)) + Pmax = max(p(i,2),p(i,1), p(i+imh,2)) - p(i,1) + Pmin = p(i,1) - min(p(i,2),p(i,1), p(i+imh,2)) + DC(i,1)=sign(min(abs(tmp),Pmax,Pmin),tmp) +C North. + tmp = 0.25*(p(i+imh,JMR) - p(i,JMR)) + Pmax = max(p(i+imh,JMR),p(i,jnp), p(i,JMR)) - p(i,JNP) + Pmin = p(i,JNP) - min(p(i+imh,JMR),p(i,jnp), p(i,JMR)) + DC(i,JNP) = sign(min(abs(tmp),Pmax,pmin),tmp) +13 continue +C + do 25 i=imh+1,IMR + DC(i, 1) = - DC(i-imh, 1) + DC(i,JNP) = - DC(i-imh,JNP) +25 continue + endif + return + end +C + subroutine fyppm(VC,P,DC,flux,IMR,JNP,j1,j2,A6,AR,AL,JORD) + parameter ( R3 = 1./3., R23 = 2./3. ) + real VC(IMR,*),flux(IMR,*),P(IMR,*),DC(IMR,*) +C Local work arrays. + real AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP) + integer LMT +c logical first +C data first /.true./ +C SAVE LMT +C + IMH = IMR / 2 + JMR = JNP - 1 + j11 = j1-1 + IMJM1 = IMR*(J2-J1+2) + len = IMR*(J2-J1+3) +C if(first) then +C IF(JORD.LE.0) then +C if(JMR.GE.90) then +C LMT = 0 +C elseif(JMR.GE.45) then +C LMT = 1 +C else +C LMT = 2 +C endif +C else +C LMT = JORD - 3 +C endif +C +C first = .false. +C endif +C +c modifs pour pouvoir choisir plusieurs schemas PPM + LMT = JORD - 3 +C + DO 10 i=1,IMR*JMR + AL(i,2) = 0.5*(p(i,1)+p(i,2)) + (DC(i,1) - DC(i,2))*R3 + AR(i,1) = AL(i,2) +10 CONTINUE +C +CPoles: +C + DO i=1,IMH + AL(i,1) = AL(i+IMH,2) + AL(i+IMH,1) = AL(i,2) +C + AR(i,JNP) = AR(i+IMH,JMR) + AR(i+IMH,JNP) = AR(i,JMR) + ENDDO + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c Rajout pour LMDZ.3.3 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + AR(IMR,1)=AL(1,1) + AR(IMR,JNP)=AL(1,JNP) +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + + do 30 i=1,len +30 A6(i,j11) = 3.*(p(i,j11)+p(i,j11) - (AL(i,j11)+AR(i,j11))) +C + if(LMT.le.2) call lmtppm(DC(1,j11),A6(1,j11),AR(1,j11) + & ,AL(1,j11),P(1,j11),len,LMT) +C + + DO 140 i=1,IMJM1 + IF(VC(i,j1).GT.0.) then + flux(i,j1) = AR(i,j11) + 0.5*VC(i,j1)*(AL(i,j11) - AR(i,j11) + + & A6(i,j11)*(1.-R23*VC(i,j1)) ) + else + flux(i,j1) = AL(i,j1) - 0.5*VC(i,j1)*(AR(i,j1) - AL(i,j1) + + & A6(i,j1)*(1.+R23*VC(i,j1))) + endif +140 continue + return + end +C + subroutine yadv(IMR,JNP,j1,j2,p,VA,ady,wk,IAD) + REAL p(IMR,JNP),ady(IMR,JNP),VA(IMR,JNP) + REAL WK(IMR,-1:JNP+2) +C + JMR = JNP-1 + IMH = IMR/2 + do j=1,JNP + do i=1,IMR + wk(i,j) = p(i,j) + enddo + enddo +C Poles: + do i=1,IMH + wk(i, -1) = p(i+IMH,3) + wk(i+IMH,-1) = p(i,3) + wk(i, 0) = p(i+IMH,2) + wk(i+IMH,0) = p(i,2) + wk(i,JNP+1) = p(i+IMH,JMR) + wk(i+IMH,JNP+1) = p(i,JMR) + wk(i,JNP+2) = p(i+IMH,JNP-2) + wk(i+IMH,JNP+2) = p(i,JNP-2) + enddo +c write(*,*) 'toto 1' +C -------------------------------- + IF(IAD.eq.2) then + do j=j1-1,j2+1 + do i=1,IMR +c write(*,*) 'avt NINT','i=',i,'j=',j + JP = NINT(VA(i,j)) + rv = JP - VA(i,j) +c write(*,*) 'VA=',VA(i,j), 'JP1=',JP,'rv=',rv + JP = j - JP +c write(*,*) 'JP2=',JP + a1 = 0.5*(wk(i,jp+1)+wk(i,jp-1)) - wk(i,jp) + b1 = 0.5*(wk(i,jp+1)-wk(i,jp-1)) +c write(*,*) 'a1=',a1,'b1=',b1 + ady(i,j) = wk(i,jp) + rv*(a1*rv + b1) - wk(i,j) + enddo + enddo +c write(*,*) 'toto 2' +C + ELSEIF(IAD.eq.1) then + do j=j1-1,j2+1 + do i=1,imr + JP = float(j)-VA(i,j) + ady(i,j) = VA(i,j)*(wk(i,jp)-wk(i,jp+1)) + enddo + enddo + ENDIF +C + if(j1.ne.2) then + sum1 = 0. + sum2 = 0. + do i=1,imr + sum1 = sum1 + ady(i,2) + sum2 = sum2 + ady(i,JMR) + enddo + sum1 = sum1 / IMR + sum2 = sum2 / IMR +C + do i=1,imr + ady(i, 2) = sum1 + ady(i,JMR) = sum2 + ady(i, 1) = sum1 + ady(i,JNP) = sum2 + enddo + else +C Poles: + sum1 = 0. + sum2 = 0. + do i=1,imr + sum1 = sum1 + ady(i,1) + sum2 = sum2 + ady(i,JNP) + enddo + sum1 = sum1 / IMR + sum2 = sum2 / IMR +C + do i=1,imr + ady(i, 1) = sum1 + ady(i,JNP) = sum2 + enddo + endif +C + return + end +C + subroutine xadv(IMR,JNP,j1,j2,p,UA,JS,JN,IML,adx,IAD) + REAL p(IMR,JNP),adx(IMR,JNP),qtmp(-IMR:IMR+IMR),UA(IMR,JNP) +C + JMR = JNP-1 + do 1309 j=j1,j2 + if(J.GT.JS .and. J.LT.JN) GO TO 1309 +C + do i=1,IMR + qtmp(i) = p(i,j) + enddo +C + do i=-IML,0 + qtmp(i) = p(IMR+i,j) + qtmp(IMR+1-i) = p(1-i,j) + enddo +C + IF(IAD.eq.2) THEN + DO i=1,IMR + IP = NINT(UA(i,j)) + ru = IP - UA(i,j) + IP = i - IP + a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip) + b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1)) + adx(i,j) = qtmp(ip) + ru*(a1*ru + b1) + enddo + ELSEIF(IAD.eq.1) then + DO i=1,IMR + iu = UA(i,j) + ru = UA(i,j) - iu + iiu = i-iu + if(UA(i,j).GE.0.) then + adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu)) + else + adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1)) + endif + enddo + ENDIF +C + do i=1,IMR + adx(i,j) = adx(i,j) - p(i,j) + enddo +1309 continue +C +C Eulerian upwind +C + do j=JS+1,JN-1 +C + do i=1,IMR + qtmp(i) = p(i,j) + enddo +C + qtmp(0) = p(IMR,J) + qtmp(IMR+1) = p(1,J) +C + IF(IAD.eq.2) THEN + qtmp(-1) = p(IMR-1,J) + qtmp(IMR+2) = p(2,J) + do i=1,imr + IP = NINT(UA(i,j)) + ru = IP - UA(i,j) + IP = i - IP + a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip) + b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1)) + adx(i,j) = qtmp(ip)- p(i,j) + ru*(a1*ru + b1) + enddo + ELSEIF(IAD.eq.1) then +C 1st order + DO i=1,IMR + IP = i - UA(i,j) + adx(i,j) = UA(i,j)*(qtmp(ip)-qtmp(ip+1)) + enddo + ENDIF + enddo +C + if(j1.ne.2) then + do i=1,IMR + adx(i, 2) = 0. + adx(i,JMR) = 0. + enddo + endif +C set cross term due to x-adv at the poles to zero. + do i=1,IMR + adx(i, 1) = 0. + adx(i,JNP) = 0. + enddo + return + end +C + subroutine lmtppm(DC,A6,AR,AL,P,IM,LMT) +C +C A6 = CURVATURE OF THE TEST PARABOLA +C AR = RIGHT EDGE VALUE OF THE TEST PARABOLA +C AL = LEFT EDGE VALUE OF THE TEST PARABOLA +C DC = 0.5 * MISMATCH +C P = CELL-AVERAGED VALUE +C IM = VECTOR LENGTH +C +C OPTIONS: +C +C LMT = 0: FULL MONOTONICITY +C LMT = 1: SEMI-MONOTONIC CONSTRAINT (NO UNDERSHOOTS) +C LMT = 2: POSITIVE-DEFINITE CONSTRAINT +C + parameter ( R12 = 1./12. ) + dimension A6(IM),AR(IM),AL(IM),P(IM),DC(IM) +C + if(LMT.eq.0) then +C Full constraint + do 100 i=1,IM + if(DC(i).eq.0.) then + AR(i) = p(i) + AL(i) = p(i) + A6(i) = 0. + else + da1 = AR(i) - AL(i) + da2 = da1**2 + A6DA = A6(i)*da1 + if(A6DA .lt. -da2) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + elseif(A6DA .gt. da2) then + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif + endif +100 continue + elseif(LMT.eq.1) then +C Semi-monotonic constraint + do 150 i=1,IM + if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 150 + if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then + AR(i) = p(i) + AL(i) = p(i) + A6(i) = 0. + elseif(AR(i) .gt. AL(i)) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + else + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif +150 continue + elseif(LMT.eq.2) then + do 250 i=1,IM + if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 250 + fmin = p(i) + 0.25*(AR(i)-AL(i))**2/A6(i) + A6(i)*R12 + if(fmin.ge.0.) go to 250 + if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then + AR(i) = p(i) + AL(i) = p(i) + A6(i) = 0. + elseif(AR(i) .gt. AL(i)) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + else + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif +250 continue + endif + return + end +C + subroutine A2C(U,V,IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5) + dimension U(IMR,*),V(IMR,*),CRX(IMR,*),CRY(IMR,*),DTDX5(*) +C + do 35 j=j1,j2 + do 35 i=2,IMR +35 CRX(i,J) = dtdx5(j)*(U(i,j)+U(i-1,j)) +C + do 45 j=j1,j2 +45 CRX(1,J) = dtdx5(j)*(U(1,j)+U(IMR,j)) +C + do 55 i=1,IMR*JMR +55 CRY(i,2) = DTDY5*(V(i,2)+V(i,1)) + return + end +C + subroutine cosa(cosp,cose,JNP,PI,DP) + dimension cosp(*),cose(*) + JMR = JNP-1 + do 55 j=2,JNP + ph5 = -0.5*PI + (FLOAT(J-1)-0.5)*DP +55 cose(j) = cos(ph5) +C + JEQ = (JNP+1) / 2 + if(JMR .eq. 2*(JMR/2) ) then + do j=JNP, JEQ+1, -1 + cose(j) = cose(JNP+2-j) + enddo + else +C cell edge at equator. + cose(JEQ+1) = 1. + do j=JNP, JEQ+2, -1 + cose(j) = cose(JNP+2-j) + enddo + endif +C + do 66 j=2,JMR +66 cosp(j) = 0.5*(cose(j)+cose(j+1)) + cosp(1) = 0. + cosp(JNP) = 0. + return + end +C + subroutine cosc(cosp,cose,JNP,PI,DP) + dimension cosp(*),cose(*) +C + phi = -0.5*PI + do 55 j=2,JNP-1 + phi = phi + DP +55 cosp(j) = cos(phi) + cosp( 1) = 0. + cosp(JNP) = 0. +C + do 66 j=2,JNP + cose(j) = 0.5*(cosp(j)+cosp(j-1)) +66 CONTINUE +C + do 77 j=2,JNP-1 + cosp(j) = 0.5*(cose(j)+cose(j+1)) +77 CONTINUE + return + end +C + SUBROUTINE qckxyz (Q,qtmp,IMR,JNP,NLAY,j1,j2,cosp,acosp, + & cross,IC,NSTEP) +C + parameter( tiny = 1.E-60 ) + DIMENSION Q(IMR,JNP,NLAY),qtmp(IMR,JNP),cosp(*),acosp(*) + logical cross +C + NLAYM1 = NLAY-1 + len = IMR*(j2-j1+1) + ip = 0 +C +C Top layer + L = 1 + icr = 1 + call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + if(ipy.eq.0) goto 50 + call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny) + if(ipx.eq.0) goto 50 +C + if(cross) then + call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + endif + if(icr.eq.0) goto 50 +C +C Vertical filling... + do i=1,len + IF( Q(i,j1,1).LT.0.) THEN + ip = ip + 1 + Q(i,j1,2) = Q(i,j1,2) + Q(i,j1,1) + Q(i,j1,1) = 0. + endif + enddo +C +50 continue + DO 225 L = 2,NLAYM1 + icr = 1 +C + call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + if(ipy.eq.0) goto 225 + call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny) + if(ipx.eq.0) go to 225 + if(cross) then + call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + endif + if(icr.eq.0) goto 225 +C + do i=1,len + IF( Q(I,j1,L).LT.0.) THEN +C + ip = ip + 1 +C From above + qup = Q(I,j1,L-1) + qly = -Q(I,j1,L) + dup = min(qly,qup) + Q(I,j1,L-1) = qup - dup + Q(I,j1,L ) = dup-qly +C Below + Q(I,j1,L+1) = Q(I,j1,L+1) + Q(I,j1,L) + Q(I,j1,L) = 0. + ENDIF + ENDDO +225 CONTINUE +C +C BOTTOM LAYER + sum = 0. + L = NLAY +C + call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + if(ipy.eq.0) goto 911 + call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny) + if(ipx.eq.0) goto 911 +C + call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + if(icr.eq.0) goto 911 +C + DO I=1,len + IF( Q(I,j1,L).LT.0.) THEN + ip = ip + 1 +c +C From above +C + qup = Q(I,j1,NLAYM1) + qly = -Q(I,j1,L) + dup = min(qly,qup) + Q(I,j1,NLAYM1) = qup - dup +C From "below" the surface. + sum = sum + qly-dup + Q(I,j1,L) = 0. + ENDIF + ENDDO +C +911 continue +C + if(ip.gt.IMR) then + write(6,*) 'IC=',IC,' STEP=',NSTEP, + & ' Vertical filling pts=',ip + endif +C + if(sum.gt.1.e-25) then + write(6,*) IC,NSTEP,' Mass source from the ground=',sum + endif + RETURN + END +C + subroutine filcr(q,IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + dimension q(IMR,*),cosp(*),acosp(*) + icr = 0 + do 65 j=j1+1,j2-1 + DO 50 i=1,IMR-1 + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-E + dn = q(i+1,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i+1,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-E + ds = q(i+1,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i+1,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +50 continue + if(icr.eq.0 .and. q(IMR,j).ge.0.) goto 65 + DO 55 i=2,IMR + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-W + dn = q(i-1,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i-1,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-W + ds = q(i-1,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i-1,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +55 continue +C ***************************************** +C i=1 + i=1 + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-W + dn = q(IMR,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(IMR,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-W + ds = q(IMR,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(IMR,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +C ***************************************** +C i=IMR + i=IMR + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-E + dn = q(1,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(1,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-E + ds = q(1,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(1,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +C ***************************************** +65 continue +C + do i=1,IMR + if(q(i,j1).lt.0. .or. q(i,j2).lt.0.) then + icr = 1 + goto 80 + endif + enddo +C +80 continue +C + if(q(1,1).lt.0. .or. q(1,jnp).lt.0.) then + icr = 1 + endif +C + return + end +C + subroutine filns(q,IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + dimension q(IMR,*),cosp(*),acosp(*) +c logical first +c data first /.true./ +c save cap1 +C +c if(first) then + DP = 4.*ATAN(1.)/float(JNP-1) + CAP1 = IMR*(1.-COS((j1-1.5)*DP))/DP +c first = .false. +c endif +C + ipy = 0 + do 55 j=j1+1,j2-1 + DO 55 i=1,IMR + IF(q(i,j).LT.0.) THEN + ipy = 1 + dq = - q(i,j)*cosp(j) +C North + dn = q(i,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C South + ds = q(i,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +55 continue +C + do i=1,imr + IF(q(i,j1).LT.0.) THEN + ipy = 1 + dq = - q(i,j1)*cosp(j1) +C North + dn = q(i,j1+1)*cosp(j1+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i,j1+1) = (dn - d1)*acosp(j1+1) + q(i,j1) = (d1 - dq)*acosp(j1) + tiny + endif + enddo +C + j = j2 + do i=1,imr + IF(q(i,j).LT.0.) THEN + ipy = 1 + dq = - q(i,j)*cosp(j) +C South + ds = q(i,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif + enddo +C +C Check Poles. + if(q(1,1).lt.0.) then + dq = q(1,1)*cap1/float(IMR)*acosp(j1) + do i=1,imr + q(i,1) = 0. + q(i,j1) = q(i,j1) + dq + if(q(i,j1).lt.0.) ipy = 1 + enddo + endif +C + if(q(1,JNP).lt.0.) then + dq = q(1,JNP)*cap1/float(IMR)*acosp(j2) + do i=1,imr + q(i,JNP) = 0. + q(i,j2) = q(i,j2) + dq + if(q(i,j2).lt.0.) ipy = 1 + enddo + endif +C + return + end +C + subroutine filew(q,qtmp,IMR,JNP,j1,j2,ipx,tiny) + dimension q(IMR,*),qtmp(JNP,IMR) +C + ipx = 0 +C Copy & swap direction for vectorization. + do 25 i=1,imr + do 25 j=j1,j2 +25 qtmp(j,i) = q(i,j) +C + do 55 i=2,imr-1 + do 55 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(0.,qtmp(j,i-1)) + d1 = min(-qtmp(j,i),d0) + qtmp(j,i-1) = qtmp(j,i-1) - d1 + qtmp(j,i) = qtmp(j,i) + d1 +c east + d0 = max(0.,qtmp(j,i+1)) + d2 = min(-qtmp(j,i),d0) + qtmp(j,i+1) = qtmp(j,i+1) - d2 + qtmp(j,i) = qtmp(j,i) + d2 + tiny + endif +55 continue +c + i=1 + do 65 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(0.,qtmp(j,imr)) + d1 = min(-qtmp(j,i),d0) + qtmp(j,imr) = qtmp(j,imr) - d1 + qtmp(j,i) = qtmp(j,i) + d1 +c east + d0 = max(0.,qtmp(j,i+1)) + d2 = min(-qtmp(j,i),d0) + qtmp(j,i+1) = qtmp(j,i+1) - d2 +c + qtmp(j,i) = qtmp(j,i) + d2 + tiny + endif +65 continue + i=IMR + do 75 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(0.,qtmp(j,i-1)) + d1 = min(-qtmp(j,i),d0) + qtmp(j,i-1) = qtmp(j,i-1) - d1 + qtmp(j,i) = qtmp(j,i) + d1 +c east + d0 = max(0.,qtmp(j,1)) + d2 = min(-qtmp(j,i),d0) + qtmp(j,1) = qtmp(j,1) - d2 +c + qtmp(j,i) = qtmp(j,i) + d2 + tiny + endif +75 continue +C + if(ipx.ne.0) then + do 85 j=j1,j2 + do 85 i=1,imr +85 q(i,j) = qtmp(j,i) + else +C +C Poles. + if(q(1,1).lt.0. or. q(1,JNP).lt.0.) ipx = 1 + endif + return + end +C + subroutine zflip(q,im,km,nc) +C This routine flip the array q (in the vertical). + real q(im,km,nc) +C local dynamic array + real qtmp(im,km) +C + do 4000 IC = 1, nc +C + do 1000 k=1,km + do 1000 i=1,im + qtmp(i,k) = q(i,km+1-k,IC) +1000 continue +C + do 2000 i=1,im*km +2000 q(i,1,IC) = qtmp(i,1) +4000 continue + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/prather.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/prather.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/prather.F (revision 1280) @@ -0,0 +1,361 @@ +! +! $Header$ +! + SUBROUTINE prather (q,w,masse,pbaru,pbarv,nt,dt) + IMPLICIT NONE + +c======================================================================= +c Adaptation LMDZ: A.Armengaud (LGGE) +c ---------------- +c +c ************************************************ +c Transport des traceurs par la methode de prather +c Ref : +c +c ************************************************ +c q,w,pext,pbaru et pbarv : arguments d'entree pour le s-pg +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +c Arguments: +c ---------- + INTEGER iq,nt + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ) + REAL masse(iip1,jjp1,llm) + REAL q( iip1,jjp1,llm,0:9) + REAL w( ip1jmp1,llm ) + integer ordre,ilim + +c Local: +c ------ + LOGICAL limit + real zq(iip1,jjp1,llm) + REAL sm ( iip1,jjp1, llm ) + REAL s0( iip1,jjp1,llm ), sx( iip1,jjp1,llm ) + REAL sy( iip1,jjp1,llm ), sz( iip1,jjp1,llm ) + REAL sxx( iip1,jjp1,llm) + REAL sxy( iip1,jjp1,llm) + REAL sxz( iip1,jjp1,llm) + REAL syy( iip1,jjp1,llm ) + REAL syz( iip1,jjp1,llm ) + REAL szz( iip1,jjp1,llm ),zz + INTEGER i,j,l,indice + real sxn(iip1),sxs(iip1) + + real sinlon(iip1),sinlondlon(iip1) + real coslon(iip1),coslondlon(iip1) + real qmin,qmax + save qmin,qmax + save sinlon,coslon,sinlondlon,coslondlon + real dyn1,dyn2,dys1,dys2,qpn,qps,dqzpn,dqzps + real masn,mass +c + REAL SSUM + integer ismax,ismin + EXTERNAL SSUM, convflu,ismin,ismax + logical first + save first + EXTERNAL advxp,advyp,advzp + + + data first/.true./ + data qmin,qmax/-1.e33,1.e33/ + + +c========================================================================== +c========================================================================== +c MODIFICATION POUR PAS DE TEMPS ADAPTATIF, dtvr remplace par dt +c========================================================================== +c========================================================================== + REAL dt +c========================================================================== + limit = .TRUE. + + if(first) then + print*,'SCHEMA PRATHER' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + enddo + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + q( i,j,l,1 )=0. + q( i,j,l,2)=0. + q( i,j,l,3)=0. + q( i,j,l,4)=0. + q( i,j,l,5)=0. + q( i,j,l,6)=0. + q( i,j,l,7)=0. + q( i,j,l,8)=0. + q( i,j,l,9)=0. + ENDDO + ENDDO + ENDDO + endif +c Fin modif Fred + +c *** On calcule la masse d'air en kg + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + sm( i,j,llm+1-l ) =masse(i,j,l) + ENDDO + ENDDO + ENDDO + +c *** q contient les qqtes de traceur avant l'advection + +c *** Affectation des tableaux S a partir de Q + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + s0( i,j,l) = q ( i,j,llm+1-l,0 )*sm(i,j,l) + sx( i,j,l) = q( i,j,llm+1-l,1 )*sm(i,j,l) + sy( i,j,l) = q( i,j,llm+1-l,2)*sm(i,j,l) + sz( i,j,l) = q( i,j,llm+1-l,3)*sm(i,j,l) + sxx( i,j,l) = q( i,j,llm+1-l,4)*sm(i,j,l) + sxy( i,j,l) = q( i,j,llm+1-l,5)*sm(i,j,l) + sxz( i,j,l) = q( i,j,llm+1-l,6)*sm(i,j,l) + syy( i,j,l) = q( i,j,llm+1-l,7)*sm(i,j,l) + syz( i,j,l) = q( i,j,llm+1-l,8)*sm(i,j,l) + szz( i,j,l) = q( i,j,llm+1-l,9)*sm(i,j,l) + ENDDO + ENDDO + ENDDO +c *** Appel des subroutines d'advection en X, en Y et en Z +c *** Advection avec "time-splitting" + +c----------------------------------------------------------- + do indice =1,nt + call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) + end do + do l=1,llm + do i=1,iip1 + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo +c--------------------------------------------------------- + call advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) +c--------------------------------------------------------- + +c--------------------------------------------------------- + do j=1,jjp1 + do i=1,iip1 + sz(i,j,1)=0. + sz(i,j,llm)=0. + sxz(i,j,1)=0. + sxz(i,j,llm)=0. + syz(i,j,1)=0. + syz(i,j,llm)=0. + szz(i,j,1)=0. + szz(i,j,llm)=0. + enddo + enddo + call advzp( limit,dt*nt,w,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) + do l=1,llm + do i=1,iip1 + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + +c--------------------------------------------------------- + +c--------------------------------------------------------- + call advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) +c--------------------------------------------------------- + DO l = 1,llm + DO j = 1,jjp1 + s0( iip1,j,l)=s0( 1,j,l ) + sx( iip1,j,l)=sx( 1,j,l ) + sy( iip1,j,l)=sy( 1,j,l ) + sz( iip1,j,l)=sz( 1,j,l ) + sxx( iip1,j,l)=sxx( 1,j,l ) + sxy( iip1,j,l)=sxy( 1,j,l) + sxz( iip1,j,l)=sxz( 1,j,l ) + syy( iip1,j,l)=syy( 1,j,l ) + syz( iip1,j,l)=syz( 1,j,l) + szz( iip1,j,l)=szz( 1,j,l ) + ENDDO + ENDDO + do indice=1,nt + call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) + end do +c--------------------------------------------------------- +c--------------------------------------------------------- +c *** On repasse les S dans la variable qpr +c *** On repasse les S dans la variable q directement 14/10/94 + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + q( i,j,llm+1-l,0 )=s0( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,1 ) = sx( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,2 ) = sy( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,3 ) = sz( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,4 ) = sxx( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,5 ) = sxy( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,6 ) = sxz( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,7 ) = syy( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,8 ) = syz( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,9 ) = szz( i,j,l )/sm(i,j,l) + ENDDO + ENDDO + ENDDO + +c--------------------------------------------------------- +c go to 777 +c filtrages aux poles + +c Traitements specifiques au pole + +c filtrages aux poles + DO l=1,llm +c filtrages aux poles + masn=ssum(iim,sm(1,1,l),1) + mass=ssum(iim,sm(1,jjp1,l),1) + qpn=ssum(iim,s0(1,1,l),1)/masn + qps=ssum(iim,s0(1,jjp1,l),1)/mass + dqzpn=ssum(iim,sz(1,1,l),1)/masn + dqzps=ssum(iim,sz(1,jjp1,l),1)/mass + do i=1,iip1 + q( i,1,llm+1-l,3)=dqzpn + q( i,jjp1,llm+1-l,3)=dqzps + q( i,1,llm+1-l,0)=qpn + q( i,jjp1,llm+1-l,0)=qps + enddo +c enddo +c print*,'qpn',qpn,'qps',qps +c print*,'dqzpn',dqzpn,'dqzps',dqzps +c enddo + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + do i=1,iim + zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0) + dyn1=dyn1+sinlondlon(i)*zz + dyn2=dyn2+coslondlon(i)*zz + zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l) + dys1=dys1+sinlondlon(i)*zz + dys2=dys2+coslondlon(i)*zz + enddo + do i=1,iim + q(i,1,llm+1-l,2)= + $ (sinlon(i)*dyn1+coslon(i)*dyn2)/2. + q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0) + $ +q(i,1,llm+1-l,2) + q(i,jjp1,llm+1-l,2)= + $ (sinlon(i)*dys1+coslon(i)*dys2)/2. + q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) + $ -q(i,jjp1,llm+1-l,2) + enddo + q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0) + q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0) + do i=1,iim + sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0) + sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0) + enddo + sxn(iip1)=sxn(1) + sxs(iip1)=sxs(1) + do i=1,iim + q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1)) + q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1)) + END DO + q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1) + q(1,jjp1,llm+1-l,1)= + $ q(iip1,jjp1,llm+1-l,1) + enddo + do l=1,llm + do i=1,iim + q( i,1,llm+1-l,4)=0. + q( i,jjp1,llm+1-l,4)=0. + q( i,1,llm+1-l,5)=0. + q( i,jjp1,llm+1-l,5)=0. + q( i,1,llm+1-l,6)=0. + q( i,jjp1,llm+1-l,6)=0. + q( i,1,llm+1-l,7)=0. + q( i,jjp1,llm+1-l,7)=0. + q( i,1,llm+1-l,8)=0. + q( i,jjp1,llm+1-l,8)=0. + q( i,1,llm+1-l,9)=0. + q( i,jjp1,llm+1-l,9)=0. + enddo + ENDDO + +777 continue +c +c bouclage en longitude + do l=1,llm + do j=1,jjp1 + q(iip1,j,l,0)=q(1,j,l,0) + q(iip1,j,llm+1-l,0)=q(1,j,llm+1-l,0) + q(iip1,j,llm+1-l,1)=q(1,j,llm+1-l,1) + q(iip1,j,llm+1-l,2)=q(1,j,llm+1-l,2) + q(iip1,j,llm+1-l,3)=q(1,j,llm+1-l,3) + q(iip1,j,llm+1-l,4)=q(1,j,llm+1-l,4) + q(iip1,j,llm+1-l,5)=q(1,j,llm+1-l,5) + q(iip1,j,llm+1-l,6)=q(1,j,llm+1-l,6) + q(iip1,j,llm+1-l,7)=q(1,j,llm+1-l,7) + q(iip1,j,llm+1-l,8)=q(1,j,llm+1-l,8) + q(iip1,j,llm+1-l,9)=q(1,j,llm+1-l,9) + enddo + enddo + DO l = 1,llm + DO j = 2,jjm + DO i = 1,iip1 + IF (q(i,j,l,0).lt.0.) THEN + PRINT*,'------------ BIP-----------' + PRINT*,'S0(',i,j,l,')=',q(i,j,l,0), + $ q(i,j-1,l,0) + PRINT*,'SX(',i,j,l,')=',q(i,j,l,1) + PRINT*,'SY(',i,j,l,')=',q(i,j,l,2), + $ q(i,j-1,l,2) + PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3) +c PRINT*,' PBL EN SORTIE D'' ADVZP' + q(i,j,l,0)=0. +c STOP + ENDIF + ENDDO + ENDDO + do j=1,jjp1,jjm + do i=1,iip1 + IF (q(i,j,l,0).lt.0.) THEN + PRINT*,'------------ BIP 2-----------' + PRINT*,'S0(',i,j,l,')=',q(i,j,l,0) + PRINT*,'SX(',i,j,l,')=',q(i,j,l,1) + PRINT*,'SY(',i,j,l,')=',q(i,j,l,2) + PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3) + + q(i,j,l,0)=0. +c STOP + ENDIF + enddo + enddo + ENDDO + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/pres2lev.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/pres2lev.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/pres2lev.F (revision 1280) @@ -0,0 +1,84 @@ +! $Id$ +! +c****************************************************** + SUBROUTINE pres2lev(varo,varn,lmo,lmn,po,pn, + % ni,nj,ok_invertp) +c +c interpolation lineaire pour passer +c a une nouvelle discretisation verticale pour +c les variables de GCM +c Francois Forget (01/1995) +c MOdif remy roca 12/97 pour passer de pres2sig +c Modif F.Codron 07/08 po en 3D +c********************************************************** + + IMPLICIT NONE + +c Declarations: +c ============== +c +c ARGUMENTS +c """"""""" + LOGICAL, INTENT(IN) :: ok_invertp + INTEGER, INTENT(IN) :: lmo ! dimensions ancienne couches + INTEGER, INTENT(IN) :: lmn ! dimensions nouvelle couches + INTEGER lmomx ! dimensions ancienne couches + INTEGER lmnmx ! dimensions nouvelle couches + + parameter(lmomx=10000,lmnmx=10000) + + real, INTENT(IN) :: po(ni,nj,lmo) ! niveau de pression ancienne grille + real, INTENT(IN) :: pn(ni,nj,lmn) ! niveau de pression nouvelle grille + + INTEGER, INTENT(IN) :: ni,nj ! nombre de point horizontale + + REAL, INTENT(IN) :: varo(ni,nj,lmo) ! var dans l'ancienne grille + REAL, INTENT(OUT) :: varn(ni,nj,lmn) ! var dans la nouvelle grille + + real zvaro(lmomx),zpo(lmomx) + +c Autres variables +c """""""""""""""" + INTEGER n, ln ,lo, i, j, Nhoriz + REAL coef + +c run +c ==== + do i=1,ni + do j=1,nj +! Inversion de l'ordre des niveaux verticaux + IF (ok_invertp) THEN + do lo=1,lmo + zpo(lo)=po(i,j,lmo+1-lo) + zvaro(lo)=varo(i,j,lmo+1-lo) + enddo + ELSE + do lo=1,lmo + zpo(lo)=po(i,j,lo) + zvaro(lo)=varo(i,j,lo) + enddo + ENDIF + + do ln=1,lmn + if (pn(i,j,ln).ge.zpo(1))then + varn(i,j,ln) = zvaro(1) + else if (pn(i,j,ln).le.zpo(lmo)) then + varn(i,j,ln) = zvaro(lmo) + else + do lo=1,lmo-1 + if ( (pn(i,j,ln).le.zpo(lo)).and. + & (pn(i,j,ln).gt.zpo(lo+1)) )then + coef=(pn(i,j,ln)-zpo(lo)) + & /(zpo(lo+1)-zpo(lo)) + varn(i,j,ln)=zvaro(lo) + & +coef*(zvaro(lo+1)-zvaro(lo)) +c print*,'pn(',ln,')=',pn(i,j,ln),varn(i,j,ln) + end if + enddo + endif + enddo + + enddo + enddo + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/pression.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/pression.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/pression.F (revision 1280) @@ -0,0 +1,32 @@ +! +! $Header$ +! + SUBROUTINE pression( ngrid, ap, bp, ps, p ) +c + +c Auteurs : P. Le Van , Fr.Hourdin . + +c ************************************************************************ +c Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du +c sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) +c couches , avec p(ij,llm +1) = 0. et p(ij,1) = ps(ij) . +c ************************************************************************ +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +c + INTEGER ngrid + INTEGER l,ij + + REAL ap( llmp1 ), bp( llmp1 ), ps( ngrid ), p( ngrid,llmp1 ) + + DO l = 1, llmp1 + DO ij = 1, ngrid + p(ij,l) = ap(l) + bp(l) * ps(ij) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/profvert.def =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/profvert.def (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/profvert.def (revision 1280) @@ -0,0 +1,23 @@ +! +! $Header$ +! +nom_courbes=F +titre=/home/hourdin/LMDZ4/libf/dyn3d +xinf=0. +xsup=669. +yinf=6.5 +ysup=10.5 +axtxtx=sols +axtxty=pressure (mb) +pathcham=. +lstyles=1 9999 +linewidth=.2 +lcolors=1 9999 +frwidth=.5 +repery0=T +txtheight=2.5 +freecoord=/d2/hourdin/Ames/saison.def + +determination du champ physique +xlength=195. +ylength=105. Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/psextbar.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/psextbar.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/psextbar.F (revision 1280) @@ -0,0 +1,107 @@ +! +! $Header$ +! + SUBROUTINE psextbar ( ps, psexbarxy ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************** +c calcul des moyennes en x et en y de (pression au sol*aire variable) .. +c ********************************************************************** +c +c ps est un argum. d'entree pour le s-pg .. +c psexbarxy est un argum. de sortie pour le s-pg .. +c +c Methode: +c -------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c +c On a : +c +c pbarx(i,j) = Pext(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c pbary(i,j) = Pext(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) + +c Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1) +c localise au point ... Z (i,j) ... +c +c +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL ps( ip1jmp1 ), psexbarxy ( ip1jm ), pext( ip1jmp1 ) + + INTEGER l, ij +c + + DO ij = 1, ip1jmp1 + pext(ij) = ps(ij) * aire(ij) + ENDDO + + + DO 5 ij = 1, ip1jm - 1 + psexbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) + + * pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2) + 5 CONTINUE + + +c .... correction pour psexbarxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = iip1, ip1jm, iip1 + psexbarxy( ij ) = psexbarxy( ij - iim ) + 7 CONTINUE + + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/q_sat.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/q_sat.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/q_sat.F (revision 1280) @@ -0,0 +1,72 @@ +! +! $Header$ +! +c +c + + subroutine q_sat(np,temp,pres,qsat) +c + IMPLICIT none +c====================================================================== +c Autheur(s): Z.X. Li (LMD/CNRS) +c reecriture vectorisee par F. Hourdin. +c Objet: calculer la vapeur d'eau saturante (formule Centre Euro.) +c====================================================================== +c Arguments: +c kelvin---input-R: temperature en Kelvin +c millibar--input-R: pression en mb +c +c q_sat----output-R: vapeur d'eau saturante en kg/kg +c====================================================================== +c + integer np + REAL temp(np),pres(np),qsat(np) +c + REAL r2es + PARAMETER (r2es=611.14 *18.0153/28.9644) +c + REAL r3les, r3ies, r3es + PARAMETER (R3LES=17.269) + PARAMETER (R3IES=21.875) +c + REAL r4les, r4ies, r4es + PARAMETER (R4LES=35.86) + PARAMETER (R4IES=7.66) +c + REAL rtt + PARAMETER (rtt=273.16) +c + REAL retv + PARAMETER (retv=28.9644/18.0153 - 1.0) + + real zqsat + integer ip +c +C ------------------------------------------------------------------ +c +c + + do ip=1,np + +c write(*,*)'kelvin,millibar=',kelvin,millibar +c write(*,*)'temp,pres=',temp(ip),pres(ip) +c + IF (temp(ip) .LE. rtt) THEN + r3es = r3ies + r4es = r4ies + ELSE + r3es = r3les + r4es = r4les + ENDIF +c + zqsat=r2es/pres(ip)*EXP(r3es*(temp(ip)-rtt)/(temp(ip)-r4es)) + zqsat=MIN(0.5,ZQSAT) + zqsat=zqsat/(1.-retv *zqsat) +c + qsat(ip)= zqsat +c write(*,*)'qsat=',qsat(ip) + + enddo +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/qminimum.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/qminimum.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/qminimum.F (revision 1280) @@ -0,0 +1,87 @@ +! +! $Header$ +! + SUBROUTINE qminimum( q,nq,deltap ) + + IMPLICIT none +c +c -- Objet : Traiter les valeurs trop petites (meme negatives) +c pour l'eau vapeur et l'eau liquide +c +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +c + INTEGER nq + REAL q(ip1jmp1,llm,nq), deltap(ip1jmp1,llm) +c + INTEGER iq_vap, iq_liq + PARAMETER ( iq_vap = 1 ) ! indice pour l'eau vapeur + PARAMETER ( iq_liq = 2 ) ! indice pour l'eau liquide + REAL seuil_vap, seuil_liq + PARAMETER ( seuil_vap = 1.0e-10 ) ! seuil pour l'eau vapeur + PARAMETER ( seuil_liq = 1.0e-11 ) ! seuil pour l'eau liquide +c +c NB. ....( Il est souhaitable mais non obligatoire que les valeurs des +c parametres seuil_vap, seuil_liq soient pareilles a celles +c qui sont utilisees dans la routine ADDFI ) +c ................................................................. +c + INTEGER i, k, iq + REAL zx_defau, zx_abc, zx_pump(ip1jmp1), pompe +c + REAL SSUM +c + INTEGER imprim + SAVE imprim + DATA imprim /0/ +c +c Quand l'eau liquide est trop petite (ou negative), on prend +c l'eau vapeur de la meme couche et la convertit en eau liquide +c (sans changer la temperature !) +c + DO 1000 k = 1, llm + DO 1040 i = 1, ip1jmp1 + if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then + q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq + q(i,k,iq_liq) = seuil_liq + endif + 1040 CONTINUE + 1000 CONTINUE +c +c Quand l'eau vapeur est trop faible (ou negative), on complete +c le defaut en prennant de l'eau vapeur de la couche au-dessous. +c + iq = iq_vap +c + DO k = llm, 2, -1 +ccc zx_abc = dpres(k) / dpres(k-1) + DO i = 1, ip1jmp1 + if ( seuil_vap - q(i,k,iq) .gt. 0.d0 ) then + q(i,k-1,iq) = q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) * + & deltap(i,k) / deltap(i,k-1) + q(i,k,iq) = seuil_vap + endif + ENDDO + ENDDO +c +c Quand il s'agit de la premiere couche au-dessus du sol, on +c doit imprimer un message d'avertissement (saturation possible). +c + DO i = 1, ip1jmp1 + zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq) ) + q(i,1,iq) = AMAX1( q(i,1,iq), seuil_vap ) + ENDDO + pompe = SSUM(ip1jmp1,zx_pump,1) + IF (imprim.LE.500 .AND. pompe.GT.0.0) THEN + WRITE(6,'(1x,"ATT!:on pompe de l eau au sol",e15.7)') pompe + DO i = 1, ip1jmp1 + IF (zx_pump(i).GT.0.0) THEN + imprim = imprim + 1 + PRINT*,'QMINIMUM: en ',i,zx_pump(i) + ENDIF + ENDDO + ENDIF +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ran1.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ran1.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ran1.F (revision 1280) @@ -0,0 +1,34 @@ +! +! $Header$ +! + FUNCTION RAN1(IDUM) + DIMENSION R(97) + save r + save iff,ix1,ix2,ix3 + PARAMETER (M1=259200,IA1=7141,IC1=54773,RM1=3.8580247E-6) + PARAMETER (M2=134456,IA2=8121,IC2=28411,RM2=7.4373773E-6) + PARAMETER (M3=243000,IA3=4561,IC3=51349) + DATA IFF /0/ + IF (IDUM.LT.0.OR.IFF.EQ.0) THEN + IFF=1 + IX1=MOD(IC1-IDUM,M1) + IX1=MOD(IA1*IX1+IC1,M1) + IX2=MOD(IX1,M2) + IX1=MOD(IA1*IX1+IC1,M1) + IX3=MOD(IX1,M3) + DO 11 J=1,97 + IX1=MOD(IA1*IX1+IC1,M1) + IX2=MOD(IA2*IX2+IC2,M2) + R(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1 +11 CONTINUE + IDUM=1 + ENDIF + IX1=MOD(IA1*IX1+IC1,M1) + IX2=MOD(IA2*IX2+IC2,M2) + IX3=MOD(IA3*IX3+IC3,M3) + J=1+(97*IX3)/M3 + IF(J.GT.97.OR.J.LT.1)PAUSE + RAN1=R(J) + R(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1 + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/rotat.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/rotat.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/rotat.F (revision 1280) @@ -0,0 +1,58 @@ +! +! $Header$ +! + SUBROUTINE rotat (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. calcule le rotationnel +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij +c +c + DO 10 l = 1,klevel +c + DO ij = 1, ip1jm - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE + +ccc CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) + + DO l = 1, klevel + DO ij = 1, ip1jm + rot(ij,l) = rot(ij,l) * unsairez(ij) + ENDDO + ENDDO +c +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/rotat_nfil.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/rotat_nfil.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/rotat_nfil.F (revision 1280) @@ -0,0 +1,49 @@ +! +! $Header$ +! + SUBROUTINE rotat_nfil (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. Calcule le rotationnel non filtre , +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij +c +c + DO 10 l = 1,klevel +c + DO ij = 1, ip1jm - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/rotatf.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/rotatf.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/rotatf.F (revision 1280) @@ -0,0 +1,58 @@ +! +! $Header$ +! + SUBROUTINE rotatf (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. calcule le rotationnel +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij +c +c + DO 10 l = 1,klevel +c + DO ij = 1, ip1jm - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE + + CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) + + DO l = 1, klevel + DO ij = 1, ip1jm + rot(ij,l) = rot(ij,l) * unsairez(ij) + ENDDO + ENDDO +c +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/rotatst.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/rotatst.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/rotatst.F (revision 1280) @@ -0,0 +1,43 @@ +! +! $Header$ +! + SUBROUTINE rotatst (klevel,x, y, rot ) +c +c P. Le Van +c +c ***************************************************************** +c .. calcule le rotationnel a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ..... +c ***************************************************************** +c x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c + INTEGER klevel +#include "dimensions.h" +#include "paramet.h" + + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) + INTEGER l, ij +c +c + DO 5 l = 1,klevel +c + DO 1 ij = 1, ip1jm - 1 + rot( ij,l ) = ( y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) ) + 1 CONTINUE +c +c .... correction pour rot( iip1,j,l) .... +c +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO 2 ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + 2 CONTINUE +c + 5 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/serre.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/serre.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/serre.h (revision 1280) @@ -0,0 +1,11 @@ +! +! $Header$ +! +!c +!c +!c..include serre.h +!c + REAL clon,clat,transx,transy,alphax,alphay,pxo,pyo, & + & grossismx, grossismy, dzoomx, dzoomy,taux,tauy + COMMON/serre/clon,clat,transx,transy,alphax,alphay,pxo,pyo , & + & grossismx, grossismy, dzoomx, dzoomy,taux,tauy Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/sort.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/sort.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/sort.F (revision 1280) @@ -0,0 +1,37 @@ +! +! $Header$ +! +C +C + SUBROUTINE sort(n,d) +c +c P.Le Van +c +c... cette routine met le tableau d dans l'ordre croissant .... +cc ( pour avoir l'ordre decroissant,il suffit de remplacer l'instruc +c tion situee + bas IF(d(j).LE.p) THEN par +c IF(d(j).GE.p) THEN +c + + INTEGER n + REAL d(n) , p + INTEGER i,j,k + + DO i=1,n-1 + k=i + p=d(i) + DO j=i+1,n + IF(d(j).LE.p) THEN + k=j + p=d(j) + ENDIF + ENDDO + + IF(k.ne.i) THEN + d(k)=d(i) + d(i)=p + ENDIF + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/sortvarc.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/sortvarc.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/sortvarc.F (revision 1280) @@ -0,0 +1,166 @@ +! +! $Header$ +! + SUBROUTINE sortvarc + $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time , + $ vcov ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c sortie des variables de controle +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "ener.h" +#include "logic.h" +#include "temps.h" + +c Arguments: +c ---------- + + INTEGER itau + REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL vcov(ip1jm,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL vorpot(ip1jm,llm) + REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm) + REAL dp(ip1jmp1) + REAL time + REAL pk(ip1jmp1,llm) + +c Local: +c ------ + + REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm) + REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1) + REAL cosphi(ip1jm),omegcosp(ip1jm) + REAL dtvrs1j,rjour,heure,radsg,radomeg + REAL rday, massebxy(ip1jm,llm) + INTEGER l, ij, imjmp1 + + REAL SSUM + +c----------------------------------------------------------------------- + + dtvrs1j = dtvr/daysec + rjour = FLOAT( INT( itau * dtvrs1j )) + heure = ( itau*dtvrs1j-rjour ) * 24. + imjmp1 = iim * jjp1 + IF(ABS(heure - 24.).LE.0.0001 ) heure = 0. +c + CALL massbarxy ( masse, massebxy ) + +c ..... Calcul de rmsdpdt ..... + + ge(:)=dp(:)*dp(:) + + rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) +c + rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) + + CALL SCOPY( ijp1llm,bern,1,bernf,1 ) + CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1) + +c ..... Calcul du moment angulaire ..... + + radsg = rad /g + radomeg = rad * omeg +c + DO ij=iip2,ip1jm + cosphi( ij ) = COS(rlatu((ij-1)/iip1+1)) + omegcosp(ij) = radomeg * cosphi(ij) + ENDDO + +c ... Calcul de l'energie,de l'enstrophie,de l'entropie et de rmsv . + + DO l=1,llm + DO ij = 1,ip1jm + vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l) + ENDDO + ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1)) + + DO ij = 1,ip1jmp1 + ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l) + + s bernf(ij,l)-phi(ij,l)) + ENDDO + etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij = 1, ip1jmp1 + ge(ij) = masse(ij,l)*teta(ij,l) + ENDDO + stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij=1,ip1jmp1 + ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.) + ENDDO + rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)) + + DO ij =iip2,ip1jm + ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) * + * cosphi(ij) + ENDDO + angl(l) = radsg * + s (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1)) + ENDDO + + DO ij=1,ip1jmp1 + ge(ij)= ps(ij)*aire(ij) + ENDDO + ptot = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1) + etot = SSUM( llm, etotl, 1 ) + ztot = SSUM( llm, ztotl, 1 ) + stot = SSUM( llm, stotl, 1 ) + rmsv = SSUM( llm, rmsvl, 1 ) + ang = SSUM( llm, angl, 1 ) + +c rday = FLOAT(INT ( day_ini + time )) +c + rday = FLOAT(INT(time-jD_ref-jH_ref)) + IF(ptot0.eq.0.) THEN + PRINT 3500, itau, rday, heure,time + PRINT*,'WARNING!!! On recalcule les valeurs initiales de :' + PRINT*,'ptot,rmsdpdt,etot,ztot,stot,rmsv,ang' + PRINT *, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang + etot0 = etot + ptot0 = ptot + ztot0 = ztot + stot0 = stot + ang0 = ang + END IF + + etot= etot/etot0 + rmsv= SQRT(rmsv/ptot) + ptot= ptot/ptot0 + ztot= ztot/ztot0 + stot= stot/stot0 + ang = ang /ang0 + + + PRINT 3500, itau, rday, heure, time + PRINT 4000, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang + + RETURN + +3500 FORMAT(10("*"),4x,'pas',i7,5x,'jour',f9.0,'heure',f5.1,4x + * ,'date',f14.4,4x,10("*")) +4000 FORMAT(10x,'masse',4x,'rmsdpdt',7x,'energie',2x,'enstrophie' + * ,2x,'entropie',3x,'rmsv',4x,'mt.ang',/,'GLOB ' + . ,f10.6,e13.6,5f10.3/ + * ) + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/sortvarc0.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/sortvarc0.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/sortvarc0.F (revision 1280) @@ -0,0 +1,141 @@ +! +! $Header$ +! + SUBROUTINE sortvarc0 + $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time , + $ vcov) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c sortie des variables de controle +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "ener.h" +#include "logic.h" +#include "temps.h" + +c Arguments: +c ---------- + + INTEGER itau + REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL vcov(ip1jm,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL vorpot(ip1jm,llm) + REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm) + REAL dp(ip1jmp1) + REAL time + REAL pk(ip1jmp1,llm) + +c Local: +c ------ + + REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm) + REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1) + REAL cosphi(ip1jm),omegcosp(ip1jm) + REAL dtvrs1j,rjour,heure,radsg,radomeg + REAL rday, massebxy(ip1jm,llm) + INTEGER l, ij, imjmp1 + + REAL SSUM + integer ismin,ismax + +c----------------------------------------------------------------------- + + dtvrs1j = dtvr/daysec + rjour = FLOAT( INT( itau * dtvrs1j )) + heure = ( itau*dtvrs1j-rjour ) * 24. + imjmp1 = iim * jjp1 + IF(ABS(heure - 24.).LE.0.0001 ) heure = 0. +c + CALL massbarxy ( masse, massebxy ) + +c ..... Calcul de rmsdpdt ..... + + ge=dp*dp + + rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) +c + rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) + + CALL SCOPY( ijp1llm,bern,1,bernf,1 ) + CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1) + +c ..... Calcul du moment angulaire ..... + + radsg = rad /g + radomeg = rad * omeg +c + DO ij=iip2,ip1jm + cosphi( ij ) = COS(rlatu((ij-1)/iip1+1)) + omegcosp(ij) = radomeg * cosphi(ij) + ENDDO + +c ... Calcul de l'energie,de l'enstrophie,de l'entropie et de rmsv . + + DO l=1,llm + DO ij = 1,ip1jm + vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l) + ENDDO + ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1)) + + DO ij = 1,ip1jmp1 + ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l) + + s bernf(ij,l)-phi(ij,l)) + ENDDO + etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij = 1, ip1jmp1 + ge(ij) = masse(ij,l)*teta(ij,l) + ENDDO + stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij=1,ip1jmp1 + ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.) + ENDDO + rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)) + + DO ij =iip2,ip1jm + ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) * + * cosphi(ij) + ENDDO + angl(l) = radsg * + s (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1)) + ENDDO + + DO ij=1,ip1jmp1 + ge(ij)= ps(ij)*aire(ij) + ENDDO + ptot0 = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1) + etot0 = SSUM( llm, etotl, 1 ) + ztot0 = SSUM( llm, ztotl, 1 ) + stot0 = SSUM( llm, stotl, 1 ) + rmsv = SSUM( llm, rmsvl, 1 ) + ang0 = SSUM( llm, angl, 1 ) + + rday = FLOAT(INT (time )) +c + PRINT 3500, itau, rday, heure, time + PRINT *, ptot0,etot0,ztot0,stot0,ang0 + +3500 FORMAT(10("*"),4x,'pas',i7,5x,'jour',f5.0,'heure',f5.1,4x + * ,'date',f10.5,4x,10("*")) + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/spline.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/spline.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/spline.F (revision 1280) @@ -0,0 +1,79 @@ +! +! $Header$ +! + subroutine spline(x,y,n,yp1,ypn,y2) + +c + +c Routine to set up the interpolating function for a cubic spline + +c interpolation (see "Numerical Recipes" for details). + +c + implicit real (a-h,o-z) + implicit integer (i-n) + + parameter(nllm=4096) + + dimension x(n),y(n),y2(n),u(nllm) + +c +c write(6,*)(x(i),i=1,n) +c write(6,*)(y(i),i=1,n) + + if(yp1.gt.0.99E30) then +c the lower boundary condition is set + y2(1)=0. +c either to be "natural" + u(1)=0. + + else +c or else to have a specified first + y2(1)=-0.5 +c derivative + u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) + + end if + + do 11 i=2,n-1 +c decomposition loop of the tridiagonal + sig=(x(i)-x(i-1))/(x(i+1)-x(i-1)) +c algorithm. Y2 and U are used + p=sig*y2(i-1)+2. +c for temporary storage of the decompo- + y2(i)=(sig-1.)/p +c sed factors + u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) + + . /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p + + 11 continue + + if(ypn.gt.0.99E30) then +c the upper boundary condition is set + qn=0. +c either to be "natural" + un=0. + + else +c or else to have a specified first + qn=0.5 +c derivative + un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1))) + + end if + + y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.) + + do 12 k=n-1,1,-1 +c this is the backsubstitution loop of + y2(k)=y2(k)*y2(k+1)+u(k) +c the tridiagonal algorithm + 12 continue + +c + + return + + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/splint.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/splint.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/splint.F (revision 1280) @@ -0,0 +1,56 @@ +! +! $Header$ +! + + SUBROUTINE splint(xa,ya,y2a,n,x,y) + +c +c Routine to compute a cubic-spline interpolated value Y given the +c value of X, the arrays XA, YA and the 2nd derivative array Y2A +c computed by SUBROUTINE SPLINE. See "Numerical Recipes" for details +c + + IMPLICIT REAL (a-h,o-z) + IMPLICIT INTEGER (i-n) + DIMENSION xa(n),ya(n),y2a(n) + + kl0=1 + + khi=n +c means of bisection + 1 IF(khi-kl0.gt.1) THEN + + k=(khi+kl0)/2 + + IF(xa(k).gt.x) THEN + + khi=k + + ELSE + + kl0=k + + END IF + + GO TO 1 + + END IF +c KL0 and KHI now bracket the X + h=xa(khi)-xa(kl0) + + IF(h.eq.0.0) STOP + a=(xa(khi)-x)/h +c evaluation of cubic spline polynomial + b=(x-xa(kl0))/h + + y=a*ya(kl0)+b*ya(khi)+((a**3-a)*y2a(kl0)+(b**3-b)*y2a(khi))*(h**2) + + ./6. + +c + + RETURN + + END + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/startvar.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/startvar.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/startvar.F (revision 1280) @@ -0,0 +1,1193 @@ +! +! $Id$ +! + MODULE startvar +#ifdef CPP_EARTH +! This module is designed to work for Earth (and with ioipsl) + ! + ! + ! There are three ways to access data from the database of atmospheric data which + ! can be used to initialize the model. This depends on the type of field which needs + ! to be extracted. In any case the call should come after a restget and should be of the type : + ! CALL startget(...) + ! + ! We will details the possible arguments to startget here : + ! + ! - A 2D variable on the dynamical grid : + ! CALL startget(varname, iml, jml, lon_in, lat_in, champ, val_ex, jml2, lon_in2, lat_in2, interbar ) + ! + ! - A 1D variable on the physical grid : + ! CALL startget(varname, iml, jml, lon_in, lat_in, nbindex, champ, val_exp, jml2, lon_in2, lat_in2, interbar ) + ! + ! + ! - A 3D variable on the dynamical grid : + ! CALL startget(varname, iml, jml, lon_in, lat_in, lml, pls, workvar, champ, val_exp, jml2, lon_in2, lat_in2, interbar ) + ! + ! + ! There is special constraint on the atmospheric data base except that the + ! the data needs to be in netCDF and the variables should have the the following + ! names in the file : + ! + ! 'RELIEF' : High resolution orography + ! 'ST' : Surface temperature + ! 'CDSW' : Soil moisture + ! 'Z' : Surface geopotential + ! 'SP' : Surface pressure + ! 'U' : East ward wind + ! 'V' : Northward wind + ! 'TEMP' : Temperature + ! 'R' : Relative humidity + ! + USE ioipsl + ! + ! + IMPLICIT NONE + ! + ! + PRIVATE + PUBLIC startget + ! + ! + INTERFACE startget + MODULE PROCEDURE startget_phys2d, startget_phys1d, startget_dyn + END INTERFACE + ! + INTEGER, SAVE :: fid_phys, fid_dyn + INTEGER, SAVE :: iml_phys, iml_rel, iml_dyn + INTEGER, SAVE :: jml_phys, jml_rel, jml_dyn + INTEGER, SAVE :: llm_dyn, ttm_dyn + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: lon_phys, lon_rug, + . lon_alb, lon_rel, lon_dyn + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: lat_phys, lat_rug, + . lat_alb, lat_rel, lat_dyn + REAL, ALLOCATABLE, SAVE, DIMENSION (:) :: levdyn_ini + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: relief, zstd, zsig, + . zgam, zthe, zpic, zval + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: rugo, masque, phis + ! + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: tsol, qsol, psol_dyn + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: var_ana3d + ! + CONTAINS + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE startget_phys2d(varname, iml, jml, lon_in, lat_in, + . champ, val_exp, jml2, lon_in2, lat_in2 , interbar, masque_lu ) + ! + ! There is a big mess with the size in logitude, should it be iml or iml+1. + ! I have chosen to use the iml+1 as an argument to this routine and we declare + ! internaly smaler fields when needed. This needs to be cleared once and for all in LMDZ. + ! A convention is required. + ! + ! + CHARACTER*(*), INTENT(in) :: varname + INTEGER, INTENT(in) :: iml, jml ,jml2 + REAL, INTENT(in) :: lon_in(iml), lat_in(jml) + REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) + REAL, INTENT(inout) :: champ(iml,jml) + REAL, INTENT(in) :: val_exp + REAL, INTENT(in), optional :: masque_lu(iml,jml) + LOGICAL interbar + ! + ! This routine only works if the variable does not exist or is constant + ! + IF ( MINVAL(champ(:,:)).EQ.MAXVAL(champ(:,:)) .AND. + .MINVAL(champ(:,:)).EQ.val_exp ) THEN + ! + SELECTCASE(varname) + ! + CASE ('relief') + ! + ! If we do not have the orography we need to get it + ! + IF ( .NOT.ALLOCATED(relief)) THEN + ! + if (present(masque_lu)) then + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2,lon_in2,lat_in2, interbar, masque_lu ) + else + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2,lon_in2,lat_in2, interbar) + endif + ! + ENDIF + ! + IF (SIZE(relief) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) 'STARTVAR module has been', + .' initialized to the wrong size' + STOP + ! + ENDIF + ! + champ(:,:) = relief(:,:) + ! + CASE ('rugosite') + ! + ! If we do not have the orography we need to get it + ! + IF ( .NOT.ALLOCATED(rugo)) THEN + ! + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2,lon_in2,lat_in2 , interbar ) + ! + ENDIF + ! + IF (SIZE(rugo) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ! + ENDIF + ! + champ(:,:) = rugo(:,:) + ! + CASE ('masque') + ! + ! If we do not have the orography we need to get it + ! + IF ( .NOT.ALLOCATED(masque)) THEN + ! + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2,lon_in2,lat_in2 , interbar ) + ! + ENDIF + ! + IF (SIZE(masque) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ! + ENDIF + ! + champ(:,:) = masque(:,:) + ! + CASE ('surfgeo') + ! + ! If we do not have the orography we need to get it + ! + IF ( .NOT.ALLOCATED(phis)) THEN + ! + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2,lon_in2, lat_in2 , interbar ) + ! + ENDIF + ! + IF (SIZE(phis) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ! + ENDIF + ! + champ(:,:) = phis(:,:) + ! + CASE ('psol') + ! + ! If we do not have the orography we need to get it + ! + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + ! + CALL start_init_dyn( iml, jml, lon_in, lat_in, + . jml2,lon_in2, lat_in2 , interbar ) + ! + ENDIF + ! + IF (SIZE(psol_dyn) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ! + ENDIF + ! + champ(:,:) = psol_dyn(:,:) + ! + CASE DEFAULT + ! + WRITE(*,*) 'startget_phys2d' + WRITE(*,*) 'No rule is present to extract variable', + . varname(:LEN_TRIM(varname)),' from any data set' + STOP + ! + END SELECT + ! + ELSE + ! + ! There are a few fields we might need if we need to interpolate 3D filed. Thus if they come through here we + ! will catch them + ! + SELECTCASE(varname) + ! + CASE ('surfgeo') + ! + IF ( .NOT.ALLOCATED(phis)) THEN + ALLOCATE(phis(iml,jml)) + ENDIF + ! + IF (SIZE(phis) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ! + ENDIF + ! + phis(:,:) = champ(:,:) + ! + END SELECT + ! + ENDIF + ! + END SUBROUTINE startget_phys2d + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE start_init_orog ( iml,jml,lon_in, lat_in,jml2,lon_in2 , + , lat_in2 , interbar, masque_lu ) + ! + INTEGER, INTENT(in) :: iml, jml, jml2 + REAL, INTENT(in) :: lon_in(iml), lat_in(jml) + REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) + REAL, intent(in), optional :: masque_lu(iml,jml) + LOGICAL interbar + ! + ! LOCAL + ! + LOGICAL interbar2 + REAL :: lev(1), date, dt,chmin,chmax + INTEGER :: itau(1), fid + INTEGER :: llm_tmp, ttm_tmp + INTEGER :: i, j + INTEGER :: iret + CHARACTER*25 title + REAL, ALLOCATABLE :: relief_hi(:,:) + REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:) + REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) + REAL, ALLOCATABLE :: tmp_var(:,:) + INTEGER, ALLOCATABLE :: tmp_int(:,:) + ! + CHARACTER*120 :: orogfname + LOGICAL :: check=.TRUE. + ! + ! + orogfname = 'Relief.nc' + ! + IF ( check ) WRITE(*,*) 'Reading the high resolution orography' + ! + CALL flininfo(orogfname,iml_rel, jml_rel, llm_tmp, ttm_tmp, fid) + ! + ALLOCATE (lat_rel(iml_rel,jml_rel), stat=iret) + ALLOCATE (lon_rel(iml_rel,jml_rel), stat=iret) + ALLOCATE (relief_hi(iml_rel,jml_rel), stat=iret) + ! + CALL flinopen(orogfname, .FALSE., iml_rel, jml_rel, + .llm_tmp, lon_rel, lat_rel, lev, ttm_tmp, + . itau, date, dt, fid) + ! + CALL flinget(fid, 'RELIEF', iml_rel, jml_rel, llm_tmp, + . ttm_tmp, 1, 1, relief_hi) + ! + CALL flinclo(fid) + ! + ! In case we have a file which is in degrees we do the transformation + ! + ALLOCATE(lon_rad(iml_rel)) + ALLOCATE(lon_ini(iml_rel)) + + IF ( MAXVAL(lon_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lon_ini(:) = lon_rel(:,1) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lon_ini(:) = lon_rel(:,1) + ENDIF + + ALLOCATE(lat_rad(jml_rel)) + ALLOCATE(lat_ini(jml_rel)) + + IF ( MAXVAL(lat_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lat_ini(:) = lat_rel(1,:) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lat_ini(:) = lat_rel(1,:) + ENDIF + ! + ! + + title='RELIEF' + + interbar2 = .FALSE. + CALL conf_dat2d(title,iml_rel, jml_rel, lon_ini, lat_ini, + . lon_rad, lat_rad, relief_hi , interbar2 ) + + IF ( check ) WRITE(*,*) 'Computes all the parameters needed', + .' for the gravity wave drag code' + ! + ! Allocate the data we need to put in the interpolated fields + ! + ! RELIEF: orographie moyenne + ALLOCATE(relief(iml,jml)) + ! zphi : orographie moyenne + ALLOCATE(phis(iml,jml)) + ! zstd: deviation standard de l'orographie sous-maille + ALLOCATE(zstd(iml,jml)) + ! zsig: pente de l'orographie sous-maille + ALLOCATE(zsig(iml,jml)) + ! zgam: anisotropy de l'orographie sous maille + ALLOCATE(zgam(iml,jml)) + ! zthe: orientation de l'axe oriente dans la direction + ! de plus grande pente de l'orographie sous maille + ALLOCATE(zthe(iml,jml)) + ! zpic: hauteur pics de la SSO + ALLOCATE(zpic(iml,jml)) + ! zval: hauteur vallees de la SSO + ALLOCATE(zval(iml,jml)) + ! masque : Masque terre ocean + ALLOCATE(tmp_int(iml,jml)) + ALLOCATE(masque(iml,jml)) + + masque = -99999. + if (present(masque_lu)) then + masque = masque_lu + endif + ! + CALL grid_noro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi, + . iml-1, jml, lon_in, lat_in, + . phis, relief, zstd, zsig, zgam, zthe, zpic, zval, masque) + phis = phis * 9.81 + ! +! masque(:,:) = FLOAT(tmp_int(:,:)) + ! + ! Compute surface roughness + ! + IF ( check ) WRITE(*,*) + .'Compute surface roughness induced by the orography' + ! + ALLOCATE(rugo(iml,jml)) + ALLOCATE(tmp_var(iml-1,jml)) + ! + CALL rugsoro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi, + . iml-1, jml, lon_in, lat_in, tmp_var) + ! + DO j = 1, jml + DO i = 1, iml-1 + rugo(i,j) = tmp_var(i,j) + ENDDO + rugo(iml,j) = tmp_var(1,j) + ENDDO +c +cc *** rugo n'est pas utilise pour l'instant ****** + ! + ! Build land-sea mask + ! + ! + RETURN + ! + END SUBROUTINE start_init_orog + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE startget_phys1d(varname, iml, jml, lon_in, + .lat_in, nbindex, champ, val_exp ,jml2, lon_in2, lat_in2,interbar) + ! + CHARACTER*(*), INTENT(in) :: varname + INTEGER, INTENT(in) :: iml, jml, nbindex, jml2 + REAL, INTENT(in) :: lon_in(iml), lat_in(jml) + REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) + REAL, INTENT(inout) :: champ(nbindex) + REAL, INTENT(in) :: val_exp + LOGICAL interbar + ! + ! + ! This routine only works if the variable does not exist or is constant + ! + IF ( MINVAL(champ(:)).EQ.MAXVAL(champ(:)) .AND. + .MINVAL(champ(:)).EQ.val_exp ) THEN + SELECTCASE(varname) + CASE ('tsol') + IF ( .NOT.ALLOCATED(tsol)) THEN + CALL start_init_phys( iml, jml, lon_in, lat_in, + . jml2, lon_in2, lat_in2, interbar ) + ENDIF + IF ( SIZE(tsol) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex, tsol, champ) + CASE ('qsol') + IF ( .NOT.ALLOCATED(qsol)) THEN + CALL start_init_phys( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(qsol) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex, qsol, champ) + CASE ('psol') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF (SIZE(psol_dyn) .NE. SIZE(lon_in)*SIZE(lat_in)) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex, psol_dyn, champ) + CASE ('zmea') + IF ( .NOT.ALLOCATED(relief)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(relief) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex, relief, champ) + CASE ('zstd') + IF ( .NOT.ALLOCATED(zstd)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zstd) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zstd, champ) + CASE ('zsig') + IF ( .NOT.ALLOCATED(zsig)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zsig) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zsig, champ) + CASE ('zgam') + IF ( .NOT.ALLOCATED(zgam)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zgam) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zgam, champ) + CASE ('zthe') + IF ( .NOT.ALLOCATED(zthe)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zthe) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zthe, champ) + CASE ('zpic') + IF ( .NOT.ALLOCATED(zpic)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zpic) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zpic, champ) + CASE ('zval') + IF ( .NOT.ALLOCATED(zval)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zval) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zval, champ) + CASE ('rads') + champ(:) = 0.0 + CASE ('snow') + champ(:) = 0.0 +cIM "slab" ocean + CASE ('tslab') + champ(:) = 0.0 + CASE ('seaice') + champ(:) = 0.0 + CASE ('rugmer') + champ(:) = 0.001 + CASE ('agsno') + champ(:) = 50.0 + CASE DEFAULT + WRITE(*,*) 'startget_phys1d' + WRITE(*,*) 'No rule is present to extract variable ', + . varname(:LEN_TRIM(varname)),' from any data set' + STOP + END SELECT + ELSE + ! + ! If we see tsol we catch it as we may need it for a 3D interpolation + ! + SELECTCASE(varname) + CASE ('tsol') + IF ( .NOT.ALLOCATED(tsol)) THEN + ALLOCATE(tsol(SIZE(lon_in),SIZE(lat_in) )) + ENDIF + CALL gr_fi_dyn(1, iml, jml, nbindex, champ, tsol) + END SELECT + ENDIF + END SUBROUTINE startget_phys1d + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE start_init_phys( iml, jml, lon_in, lat_in, jml2, + . lon_in2, lat_in2 , interbar ) + ! + INTEGER, INTENT(in) :: iml, jml ,jml2 + REAL, INTENT(in) :: lon_in(iml), lat_in(jml) + REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) + LOGICAL interbar + ! + ! LOCAL + ! +!ac REAL :: lev(1), date, dt + REAL :: date, dt + REAL, DIMENSION(:), ALLOCATABLE :: levphys_ini +!ac + INTEGER :: itau(1) + INTEGER :: llm_tmp, ttm_tmp + INTEGER :: i, j + ! + CHARACTER*25 title + CHARACTER*120 :: physfname + LOGICAL :: check=.TRUE. + ! + REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:) + REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) + REAL, ALLOCATABLE :: var_ana(:,:), tmp_var(:,:) + ! + physfname = 'ECPHY.nc' + ! + IF ( check ) WRITE(*,*) 'Opening the surface analysis' + ! + CALL flininfo(physfname, iml_phys, jml_phys, llm_tmp, + . ttm_tmp, fid_phys) + ! + ALLOCATE (lat_phys(iml_phys,jml_phys)) + ALLOCATE (lon_phys(iml_phys,jml_phys)) +!ac + ALLOCATE (levphys_ini(llm_tmp)) + ! +! CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, +! . llm_tmp, lon_phys, lat_phys, lev, ttm_tmp, +! . itau, date, dt, fid_phys) + ! + CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, + . llm_tmp, lon_phys, lat_phys, levphys_ini, ttm_tmp, + . itau, date, dt, fid_phys) + ! + DEALLOCATE (levphys_ini) +!ac + ! + ! Allocate the space we will need to get the data out of this file + ! + ALLOCATE(var_ana(iml_phys, jml_phys)) + ! + ! In case we have a file which is in degrees we do the transformation + ! + ALLOCATE(lon_rad(iml_phys)) + ALLOCATE(lon_ini(iml_phys)) + + IF ( MAXVAL(lon_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lon_ini(:) = lon_phys(:,1) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lon_ini(:) = lon_phys(:,1) + ENDIF + + ALLOCATE(lat_rad(jml_phys)) + ALLOCATE(lat_ini(jml_phys)) + + IF ( MAXVAL(lat_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lat_ini(:) = lat_phys(1,:) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lat_ini(:) = lat_phys(1,:) + ENDIF + + + ! + ! We get the two standard varibales + ! Surface temperature + ! + ALLOCATE(tsol(iml,jml)) + ALLOCATE(tmp_var(iml-1,jml)) + ! + ! + + CALL flinget(fid_phys, 'ST', iml_phys, jml_phys, + .llm_tmp, ttm_tmp, 1, 1, var_ana) + + title='ST' + CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, + . lon_rad, lat_rad, var_ana , interbar ) + + IF ( interbar ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour ST $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + CALL inter_barxy ( iml_phys,jml_phys -1,lon_rad,lat_rad , + , var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var ) + ELSE + CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad, + . var_ana, iml-1, jml, lon_in, lat_in, tmp_var ) + ENDIF + + CALL gr_int_dyn(tmp_var, tsol, iml-1, jml) + ! + ! Soil moisture + ! + ALLOCATE(qsol(iml,jml)) + CALL flinget(fid_phys, 'CDSW', iml_phys, jml_phys, + . llm_tmp, ttm_tmp, 1, 1, var_ana) + + title='CDSW' + CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, + . lon_rad, lat_rad, var_ana, interbar ) + + IF ( interbar ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour CDSW $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + CALL inter_barxy ( iml_phys,jml_phys -1,lon_rad,lat_rad , + , var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var ) + ELSE + CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad, + . var_ana, iml-1, jml, lon_in, lat_in, tmp_var ) + ENDIF +c + CALL gr_int_dyn(tmp_var, qsol, iml-1, jml) + ! + CALL flinclo(fid_phys) + ! + END SUBROUTINE start_init_phys + ! + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! + SUBROUTINE startget_dyn(varname, iml, jml, lon_in, lat_in, + . lml, pls, workvar, champ, val_exp,jml2, lon_in2, lat_in2 , + , interbar ) + ! + ! ARGUMENTS + ! + CHARACTER*(*), INTENT(in) :: varname + INTEGER, INTENT(in) :: iml, jml, lml, jml2 + REAL, INTENT(in) :: lon_in(iml), lat_in(jml) + REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) + REAL, INTENT(in) :: pls(iml, jml, lml) + REAL, INTENT(in) :: workvar(iml, jml, lml) + REAL, INTENT(inout) :: champ(iml, jml, lml) + REAL, INTENT(in) :: val_exp + LOGICAL interbar + ! + ! LOCAL + ! + INTEGER :: il, ij, ii + REAL :: xppn, xpps + ! +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comconst.h" + ! + ! This routine only works if the variable does not exist or is constant + ! + IF ( MINVAL(champ(:,:,:)).EQ.MAXVAL(champ(:,:,:)) .AND. + . MINVAL(champ(:,:,:)).EQ.val_exp ) THEN + ! + SELECTCASE(varname) + CASE ('u') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 , + . lon_in2,lat_in2 , interbar ) + ENDIF + CALL start_inter_3d('U', iml, jml, lml, lon_in, + . lat_in, jml2, lon_in2, lat_in2, pls, champ,interbar ) + DO il=1,lml + DO ij=1,jml + DO ii=1,iml-1 + champ(ii,ij,il) = champ(ii,ij,il) * cu(ii,ij) + ENDDO + champ(iml,ij, il) = champ(1,ij, il) + ENDDO + ENDDO + CASE ('v') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in , jml2, + . lon_in2, lat_in2 , interbar ) + ENDIF + CALL start_inter_3d('V', iml, jml, lml, lon_in, + . lat_in, jml2, lon_in2, lat_in2, pls, champ, interbar ) + DO il=1,lml + DO ij=1,jml + DO ii=1,iml-1 + champ(ii,ij,il) = champ(ii,ij,il) * cv(ii,ij) + ENDDO + champ(iml,ij, il) = champ(1,ij, il) + ENDDO + ENDDO + CASE ('t') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 , + . lon_in2, lat_in2 ,interbar ) + ENDIF + CALL start_inter_3d('TEMP', iml, jml, lml, lon_in, + . lat_in, jml2, lon_in2, lat_in2, pls, champ, interbar ) + + CASE ('tpot') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in , jml2 , + . lon_in2, lat_in2 , interbar ) + ENDIF + CALL start_inter_3d('TEMP', iml, jml, lml, lon_in, + . lat_in, jml2, lon_in2, lat_in2, pls, champ, interbar ) + IF ( MINVAL(workvar(:,:,:)) .NE. MAXVAL(workvar(:,:,:)) ) + . THEN + DO il=1,lml + DO ij=1,jml + DO ii=1,iml-1 + champ(ii,ij,il) = champ(ii,ij,il) * cpp + . / workvar(ii,ij,il) + ENDDO + champ(iml,ij,il) = champ(1,ij,il) + ENDDO + ENDDO + DO il=1,lml + xppn = SUM(aire(:,1)*champ(:,1,il))/apoln + xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols + champ(:,1,il) = xppn + champ(:,jml,il) = xpps + ENDDO + ELSE + WRITE(*,*)'Could not compute potential temperature as the' + WRITE(*,*)'Exner function is missing or constant.' + STOP + ENDIF + CASE ('q') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 , + . lon_in2, lat_in2 , interbar ) + ENDIF + CALL start_inter_3d('R', iml, jml, lml, lon_in, lat_in, + . jml2, lon_in2, lat_in2, pls, champ, interbar ) + IF ( MINVAL(workvar(:,:,:)) .NE. MAXVAL(workvar(:,:,:)) ) + . THEN + DO il=1,lml + DO ij=1,jml + DO ii=1,iml-1 + champ(ii,ij,il) = 0.01 * champ(ii,ij,il) * + . workvar(ii,ij,il) + ENDDO + champ(iml,ij,il) = champ(1,ij,il) + ENDDO + ENDDO + WHERE ( champ .LT. 0.) champ = 1.0E-10 + DO il=1,lml + xppn = SUM(aire(:,1)*champ(:,1,il))/apoln + xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols + champ(:,1,il) = xppn + champ(:,jml,il) = xpps + ENDDO + ELSE + WRITE(*,*)'Could not compute specific humidity as the' + WRITE(*,*)'saturated humidity is missing or constant.' + STOP + ENDIF + CASE DEFAULT + WRITE(*,*) 'startget_dyn' + WRITE(*,*) 'No rule is present to extract variable ', + . varname(:LEN_TRIM(varname)),' from any data set' + STOP + END SELECT + ENDIF + END SUBROUTINE startget_dyn + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE start_init_dyn( iml, jml, lon_in, lat_in,jml2,lon_in2 , + , lat_in2 , interbar ) + ! + INTEGER, INTENT(in) :: iml, jml, jml2 + REAL, INTENT(in) :: lon_in(iml), lat_in(jml) + REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) + LOGICAL interbar + ! + ! LOCAL + ! + REAL :: lev(1), date, dt + INTEGER :: itau(1) + INTEGER :: i, j + integer :: iret + ! + CHARACTER*120 :: physfname + LOGICAL :: check=.TRUE. + ! + REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:) + REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) + REAL, ALLOCATABLE :: var_ana(:,:), tmp_var(:,:), z(:,:) + REAL, ALLOCATABLE :: xppn(:), xpps(:) + LOGICAL :: allo + ! + ! +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" + + CHARACTER*25 title + + ! + physfname = 'ECDYN.nc' + ! + IF ( check ) WRITE(*,*) 'Opening the surface analysis' + ! + CALL flininfo(physfname, iml_dyn, jml_dyn, llm_dyn, + . ttm_dyn, fid_dyn) + IF ( check ) WRITE(*,*) 'Values read: ', iml_dyn, jml_dyn, + . llm_dyn, ttm_dyn + ! + ALLOCATE (lat_dyn(iml_dyn,jml_dyn), stat=iret) + ALLOCATE (lon_dyn(iml_dyn,jml_dyn), stat=iret) + ALLOCATE (levdyn_ini(llm_dyn), stat=iret) + ! + CALL flinopen(physfname, .FALSE., iml_dyn, jml_dyn, llm_dyn, + . lon_dyn, lat_dyn, levdyn_ini, ttm_dyn, + . itau, date, dt, fid_dyn) + ! + + allo = allocated (var_ana) + if (allo) then + DEALLOCATE(var_ana, stat=iret) + endif + ALLOCATE(var_ana(iml_dyn, jml_dyn), stat=iret) + + allo = allocated (lon_rad) + if (allo) then + DEALLOCATE(lon_rad, stat=iret) + endif + + ALLOCATE(lon_rad(iml_dyn), stat=iret) + ALLOCATE(lon_ini(iml_dyn)) + + IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lon_ini(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lon_ini(:) = lon_dyn(:,1) + ENDIF + + ALLOCATE(lat_rad(jml_dyn)) + ALLOCATE(lat_ini(jml_dyn)) + + IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lat_ini(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lat_ini(:) = lat_dyn(1,:) + ENDIF + ! + + + ALLOCATE(z(iml, jml)) + ALLOCATE(tmp_var(iml-1,jml)) + ! + CALL flinget(fid_dyn, 'Z', iml_dyn, jml_dyn, 0, ttm_dyn, + . 1, 1, var_ana) +c + title='Z' + CALL conf_dat2d( title,iml_dyn, jml_dyn,lon_ini, lat_ini, + . lon_rad, lat_rad, var_ana, interbar ) +c + IF ( interbar ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour Z $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + CALL inter_barxy ( iml_dyn,jml_dyn -1,lon_rad,lat_rad , + , var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var) + ELSE + CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana, + . iml-1, jml, lon_in, lat_in, tmp_var) + ENDIF + + CALL gr_int_dyn(tmp_var, z, iml-1, jml) + ! + ALLOCATE(psol_dyn(iml, jml)) + ! + CALL flinget(fid_dyn, 'SP', iml_dyn, jml_dyn, 0, ttm_dyn, + . 1, 1, var_ana) + + title='SP' + CALL conf_dat2d( title,iml_dyn, jml_dyn,lon_ini, lat_ini, + . lon_rad, lat_rad, var_ana, interbar ) + + IF ( interbar ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour SP $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + CALL inter_barxy ( iml_dyn,jml_dyn -1,lon_rad,lat_rad , + , var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var) + ELSE + CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana, + . iml-1, jml, lon_in, lat_in, tmp_var ) + ENDIF + + CALL gr_int_dyn(tmp_var, psol_dyn, iml-1, jml) + ! + IF ( .NOT.ALLOCATED(tsol)) THEN + ! These variables may have been allocated by the need to + ! create a start field for them or by the varibale + ! coming out of the restart file. In case we dor have it we will initialize it. + ! + CALL start_init_phys( iml, jml, lon_in, lat_in,jml2,lon_in2, + . lat_in2 , interbar ) + ELSE + IF ( SIZE(tsol) .NE. SIZE(psol_dyn) ) THEN + WRITE(*,*) 'start_init_dyn :' + WRITE(*,*) 'The temperature field we have does not ', + . 'have the right size' + STOP + ENDIF + ENDIF + IF ( .NOT.ALLOCATED(phis)) THEN + ! + ! These variables may have been allocated by the need to create a start field for them or by the varibale + ! coming out of the restart file. In case we dor have it we will initialize it. + ! + CALL start_init_orog( iml, jml, lon_in, lat_in, jml2, lon_in2 , + . lat_in2 , interbar ) + ! + ELSE + ! + IF (SIZE(phis) .NE. SIZE(psol_dyn)) THEN + ! + WRITE(*,*) 'start_init_dyn :' + WRITE(*,*) 'The orography field we have does not ', + . ' have the right size' + STOP + ENDIF + ! + ENDIF + ! + ! PSOL is computed in Pascals + ! + ! + DO j = 1, jml + DO i = 1, iml-1 + psol_dyn(i,j) = psol_dyn(i,j)*(1.0+(z(i,j)-phis(i,j)) + . /287.0/tsol(i,j)) + ENDDO + psol_dyn(iml,j) = psol_dyn(1,j) + ENDDO + ! + ! + ALLOCATE(xppn(iml-1)) + ALLOCATE(xpps(iml-1)) + ! + DO i = 1, iml-1 + xppn(i) = aire( i,1) * psol_dyn( i,1) + xpps(i) = aire( i,jml) * psol_dyn( i,jml) + ENDDO + ! + DO i = 1, iml + psol_dyn(i,1 ) = SUM(xppn)/apoln + psol_dyn(i,jml) = SUM(xpps)/apols + ENDDO + ! + RETURN + ! + END SUBROUTINE start_init_dyn + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE start_inter_3d(varname, iml, jml, lml, lon_in, + . lat_in, jml2, lon_in2, lat_in2, pls_in, var3d, interbar ) + ! + ! This subroutine gets a variables from a 3D file and does the interpolations needed + ! + ! + ! ARGUMENTS + ! + CHARACTER*(*) :: varname + INTEGER :: iml, jml, lml, jml2 + REAL :: lon_in(iml), lat_in(jml), pls_in(iml, jml, lml) + REAL :: lon_in2(iml) , lat_in2(jml2) + REAL :: var3d(iml, jml, lml) + LOGICAL interbar + real chmin,chmax + ! + ! LOCAL + ! + CHARACTER*25 title + INTEGER :: ii, ij, il, jsort,i,j,l + REAL :: bx, by + REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:) + REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) , lev_dyn(:) + REAL, ALLOCATABLE :: var_tmp2d(:,:), var_tmp3d(:,:,:) + REAL, ALLOCATABLE :: ax(:), ay(:), yder(:) +! REAL, ALLOCATABLE :: varrr(:,:,:) + INTEGER, ALLOCATABLE :: lind(:) + ! + LOGICAL :: check = .TRUE. + ! + IF ( .NOT. ALLOCATED(var_ana3d)) THEN + ALLOCATE(var_ana3d(iml_dyn, jml_dyn, llm_dyn)) + ENDIF +! ALLOCATE(varrr(iml_dyn, jml_dyn, llm_dyn)) + ! + ! + IF ( check) WRITE(*,*) 'Going into flinget to extract the 3D ', + . ' field.', fid_dyn + IF ( check) WRITE(*,*) fid_dyn, varname, iml_dyn, jml_dyn, + . llm_dyn,ttm_dyn + ! + CALL flinget(fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, + . ttm_dyn, 1, 1, var_ana3d) + ! + IF ( check) WRITE(*,*) 'Allocating space for the interpolation', + . iml, jml, llm_dyn + ! + ALLOCATE(lon_rad(iml_dyn)) + ALLOCATE(lon_ini(iml_dyn)) + + IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lon_ini(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lon_ini(:) = lon_dyn(:,1) + ENDIF + + ALLOCATE(lat_rad(jml_dyn)) + ALLOCATE(lat_ini(jml_dyn)) + + ALLOCATE(lev_dyn(llm_dyn)) + + IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lat_ini(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lat_ini(:) = lat_dyn(1,:) + ENDIF + ! + + CALL conf_dat3d ( varname,iml_dyn, jml_dyn, llm_dyn, lon_ini, + . lat_ini, levdyn_ini, lon_rad, lat_rad, lev_dyn, var_ana3d , + , interbar ) + + ALLOCATE(var_tmp2d(iml-1, jml)) + ALLOCATE(var_tmp3d(iml, jml, llm_dyn)) + ALLOCATE(ax(llm_dyn)) + ALLOCATE(ay(llm_dyn)) + ALLOCATE(yder(llm_dyn)) + ALLOCATE(lind(llm_dyn)) + ! + + DO il=1,llm_dyn + ! + IF( interbar ) THEN + IF( il.EQ.1 ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour ', varname + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + ENDIF + CALL inter_barxy ( iml_dyn, jml_dyn -1,lon_rad, lat_rad, + , var_ana3d(:,:,il),iml-1, jml2, lon_in2, lat_in2,jml,var_tmp2d ) + ELSE + CALL grille_m(iml_dyn, jml_dyn, lon_rad, lat_rad, + . var_ana3d(:,:,il), iml-1, jml, lon_in, lat_in, var_tmp2d ) + ENDIF + ! + CALL gr_int_dyn(var_tmp2d, var_tmp3d(:,:,il), iml-1, jml) + ! + ENDDO + ! + DO il=1,llm_dyn + lind(il) = llm_dyn-il+1 + ENDDO + ! +c +c ... Pour l'interpolation verticale ,on interpole du haut de l'atmosphere +c vers le sol ... +c + DO ij=1,jml + DO ii=1,iml-1 + ! + ax(:) = lev_dyn(lind(:)) + ay(:) = var_tmp3d(ii, ij, lind(:)) + ! + + CALL SPLINE(ax, ay, llm_dyn, 1.e30, 1.e30, yder) + ! + DO il=1,lml + bx = pls_in(ii, ij, il) + CALL SPLINT(ax, ay, yder, llm_dyn, bx, by) + var3d(ii, ij, il) = by + ENDDO + ! + ENDDO + var3d(iml, ij, :) = var3d(1, ij, :) + ENDDO + + do il=1,lml + call minmax(iml*jml,var3d(1,1,il),chmin,chmax) + SELECTCASE(varname) + CASE('U') + WRITE(*,*) ' U min max l ',il,chmin,chmax + CASE('V') + WRITE(*,*) ' V min max l ',il,chmin,chmax + CASE('TEMP') + WRITE(*,*) ' TEMP min max l ',il,chmin,chmax + CASE('R') + WRITE(*,*) ' R min max l ',il,chmin,chmax + END SELECT + enddo + + DEALLOCATE(lon_rad) + DEALLOCATE(lon_ini) + DEALLOCATE(lat_rad) + DEALLOCATE(lat_ini) + DEALLOCATE(lev_dyn) + DEALLOCATE(var_tmp2d) + DEALLOCATE(var_tmp3d) + DEALLOCATE(ax) + DEALLOCATE(ay) + DEALLOCATE(yder) + DEALLOCATE(lind) + + ! + RETURN + ! + END SUBROUTINE start_inter_3d + ! +#endif +! of #ifdef CPP_EARTH + END MODULE startvar Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/temps.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/temps.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/temps.h (revision 1280) @@ -0,0 +1,24 @@ +! +! $Id$ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! +! jD_ref = jour julien de la date de reference (lancement de l'experience) +! hD_ref = "heure" julienne de la date de reference +!----------------------------------------------------------------------- +! INCLUDE 'temps.h' + + COMMON/temps/itaufin, dt, day_ini, day_end, annee_ref, day_ref, & + & itau_dyn, itau_phy, jD_ref, jH_ref, calend + + INTEGER itaufin + INTEGER itau_dyn, itau_phy + INTEGER day_ini, day_end, annee_ref, day_ref + REAL dt, jD_ref, jH_ref + CHARACTER (len=10) :: calend + +!----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/test_period.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/test_period.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/test_period.F (revision 1280) @@ -0,0 +1,115 @@ +! +! $Header$ +! + SUBROUTINE test_period ( ucov, vcov, teta, q, p, phis ) +c +c Auteur : P. Le Van +c --------- +c .... Cette routine teste la periodicite en longitude des champs ucov, +c teta, q , p et phis .......... +c + USE infotrac +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +c +c ...... Arguments ...... +c + REAL ucov(ip1jmp1,llm), vcov(ip1jm,llm), teta(ip1jmp1,llm) , + , q(ip1jmp1,llm,nqtot), p(ip1jmp1,llmp1), phis(ip1jmp1) +c +c ..... Variables locales ..... +c + INTEGER ij,l,nq +c + DO l = 1, llm + DO ij = 1, ip1jmp1, iip1 + IF( ucov(ij,l).NE.ucov(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- UCOV --- n est pas', + , ' periodique en longitude ! ' + PRINT *,' l, ij = ', l, ij, ij+iim + STOP + ENDIF + IF( teta(ij,l).NE.teta(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- TETA --- n est pas', + , ' periodique en longitude ! ' + PRINT *,' l, ij = ', l, ij, ij+iim + , , teta(ij,l), teta(ij+iim,l) + STOP + ENDIF + ENDDO + + do ij=1,iim + if (teta(ij,l).ne.teta(1,l) + s .or.teta(ip1jm+ij,l).ne.teta(ip1jm+1,l) ) then + PRINT *,'STOP dans test_period car --- TETA --- n est pas', + , ' constant aux poles ! ' + print*,'teta(',1 ,',',l,')=',teta(1 ,l) + print*,'teta(',ij,',',l,')=',teta(ij,l) + print*,'teta(',ip1jm+1 ,',',l,')=',teta(ip1jm+1 ,l) + print*,'teta(',ip1jm+ij,',',l,')=',teta(ip1jm+ij,l) + stop + endif + enddo + ENDDO + +c + DO l = 1, llm + DO ij = 1, ip1jm, iip1 + IF( vcov(ij,l).NE.vcov(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- VCOV --- n est pas', + , ' periodique en longitude !' + PRINT *,' l, ij = ', l, ij, ij+iim,vcov(ij+iim,l),vcov(ij,l) + vcov(ij+iim,l)=vcov(ij,l) +c STOP + ENDIF + ENDDO + ENDDO + +c + DO nq =1, nqtot + DO l =1, llm + DO ij = 1, ip1jmp1, iip1 + IF( q(ij,l,nq).NE.q(ij+iim,l,nq) ) THEN + PRINT *,'STOP dans test_period car --- Q --- n est pas ', + , 'periodique en longitude !' + PRINT *,' nq , l, ij = ', nq, l, ij, ij+iim + STOP + ENDIF + ENDDO + ENDDO + ENDDO +c + DO l = 1, llm + DO ij = 1, ip1jmp1, iip1 + IF( p(ij,l).NE.p(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- P --- n est pas', + , ' periodique en longitude !' + PRINT *,' l ij = ',l, ij, ij+iim + STOP + ENDIF + IF( phis(ij).NE.phis(ij+iim) ) THEN + PRINT *,'STOP dans test_period car --- PHIS --- n est pas', + , ' periodique en longitude ! l, IJ = ', l, ij,ij+iim + PRINT *,' ij = ', ij, ij+iim + STOP + ENDIF + ENDDO + do ij=1,iim + if (p(ij,l).ne.p(1,l) + s .or.p(ip1jm+ij,l).ne.p(ip1jm+1,l) ) then + PRINT *,'STOP dans test_period car --- P --- n est pas', + , ' constant aux poles ! ' + print*,'p(',1 ,',',l,')=',p(1 ,l) + print*,'p(',ij,',',l,')=',p(ij,l) + print*,'p(',ip1jm+1 ,',',l,')=',p(ip1jm+1 ,l) + print*,'p(',ip1jm+ij,',',l,')=',p(ip1jm+ij,l) + stop + endif + enddo + ENDDO +c +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/tetaleveli1j.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/tetaleveli1j.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/tetaleveli1j.F (revision 1280) @@ -0,0 +1,139 @@ +c================================================================ +c================================================================ + SUBROUTINE tetaleveli1j(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres) +c================================================================ +c================================================================ + +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +! USE dimphy + IMPLICIT none + +#include "dimensions.h" +ccccc#include "dimphy.h" + +c================================================================ +c +c Interpoler des champs 3-D u, v et g du modele a un niveau de +c pression donnee (pres) +c +c INPUT: ilon ----- nombre de points +c ilev ----- nombre de couches +c lnew ----- true si on doit reinitialiser les poids +c pgcm ----- pressions modeles +c pres ----- pression vers laquelle on interpolle +c Qgcm ----- champ GCM +c Qpres ---- champ interpolle au niveau pres +c +c================================================================ +c +c arguments : +c ----------- + + INTEGER ilon, ilev + logical lnew + + REAL pgcm(ilon,ilev) + REAL Qgcm(ilon,ilev) + real pres + REAL Qpres(ilon) + +c local : +c ------- + +cIM 211004 +c INTEGER lt(klon), lb(klon) +c REAL ptop, pbot, aist(klon), aisb(klon) +c +#include "paramet.h" +c + INTEGER lt(ip1jm), lb(ip1jm) + REAL ptop, pbot, aist(ip1jm), aisb(ip1jm) +cMI 211004 + save lt,lb,ptop,pbot,aist,aisb + + INTEGER i, k +c +c PRINT*,'tetalevel pres=',pres +c===================================================================== + if (lnew) then +c on réinitialise les réindicages et les poids +c===================================================================== + + +c Chercher les 2 couches les plus proches du niveau a obtenir +c +c Eventuellement, faire l'extrapolation a partir des deux couches +c les plus basses ou les deux couches les plus hautes: + DO 130 i = 1, ilon +cIM IF ( ABS(pres-pgcm(i,ilev) ) .LT. + IF ( ABS(pres-pgcm(i,ilev) ) .GT. + . ABS(pres-pgcm(i,1)) ) THEN + lt(i) = ilev ! 2 + lb(i) = ilev-1 ! 1 + ELSE + lt(i) = 2 + lb(i) = 1 + ENDIF +cIM PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)', +cIM .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1)) + 130 CONTINUE + DO 150 k = 1, ilev-1 + DO 140 i = 1, ilon + pbot = pgcm(i,k) + ptop = pgcm(i,k+1) +cIM IF (ptop.LE.pres .AND. pbot.GE.pres) THEN + IF (ptop.GE.pres .AND. pbot.LE.pres) THEN + lt(i) = k+1 + lb(i) = k + ENDIF + 140 CONTINUE + 150 CONTINUE +c +c Interpolation lineaire: +c + DO i = 1, ilon +c interpolation en logarithme de pression: +c +c ... Modif . P. Le Van ( 20/01/98) .... +c Modif Frédéric Hourdin (3/01/02) + + IF(pgcm(i,lb(i)).EQ.0.OR. + $ pgcm(i,lt(i)).EQ.0.) THEN +c + PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i), + . lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres +c + ENDIF +c + aist(i) = LOG( pgcm(i,lb(i))/ pres ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) ) + aisb(i) = LOG( pres / pgcm(i,lt(i)) ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i))) + enddo + + + endif ! lnew + +c====================================================================== +c inteprollation +c====================================================================== + + do i=1,ilon + Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i) +cIM PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i), +cIM $ Qgcm(i,lt(i)),aist(i),Qpres(i) + enddo +c +c Je mets les vents a zero quand je rencontre une montagne + do i = 1, ilon +cIM if (pgcm(i,1).LT.pres) THEN + if (pgcm(i,1).GT.pres) THEN +c Qpres(i)=1e33 + Qpres(i)=1e+20 +cIM PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres + endif + enddo + +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/tetaleveli1j1.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/tetaleveli1j1.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/tetaleveli1j1.F (revision 1280) @@ -0,0 +1,139 @@ +c================================================================ +c================================================================ + SUBROUTINE tetaleveli1j1(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres) +c================================================================ +c================================================================ + +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +! USE dimphy + IMPLICIT none + +#include "dimensions.h" +cccc#include "dimphy.h" + +c================================================================ +c +c Interpoler des champs 3-D u, v et g du modele a un niveau de +c pression donnee (pres) +c +c INPUT: ilon ----- nombre de points +c ilev ----- nombre de couches +c lnew ----- true si on doit reinitialiser les poids +c pgcm ----- pressions modeles +c pres ----- pression vers laquelle on interpolle +c Qgcm ----- champ GCM +c Qpres ---- champ interpolle au niveau pres +c +c================================================================ +c +c arguments : +c ----------- + + INTEGER ilon, ilev + logical lnew + + REAL pgcm(ilon,ilev) + REAL Qgcm(ilon,ilev) + real pres + REAL Qpres(ilon) + +c local : +c ------- + +cIM 211004 +c INTEGER lt(klon), lb(klon) +c REAL ptop, pbot, aist(klon), aisb(klon) +c +#include "paramet.h" +c + INTEGER lt(ip1jmp1), lb(ip1jmp1) + REAL ptop, pbot, aist(ip1jmp1), aisb(ip1jmp1) +cMI 211004 + save lt,lb,ptop,pbot,aist,aisb + + INTEGER i, k +c +c PRINT*,'tetalevel pres=',pres +c===================================================================== + if (lnew) then +c on réinitialise les réindicages et les poids +c===================================================================== + + +c Chercher les 2 couches les plus proches du niveau a obtenir +c +c Eventuellement, faire l'extrapolation a partir des deux couches +c les plus basses ou les deux couches les plus hautes: + DO 130 i = 1, ilon +cIM IF ( ABS(pres-pgcm(i,ilev) ) .LT. + IF ( ABS(pres-pgcm(i,ilev) ) .GT. + . ABS(pres-pgcm(i,1)) ) THEN + lt(i) = ilev ! 2 + lb(i) = ilev-1 ! 1 + ELSE + lt(i) = 2 + lb(i) = 1 + ENDIF +cIM PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)', +cIM .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1)) + 130 CONTINUE + DO 150 k = 1, ilev-1 + DO 140 i = 1, ilon + pbot = pgcm(i,k) + ptop = pgcm(i,k+1) +cIM IF (ptop.LE.pres .AND. pbot.GE.pres) THEN + IF (ptop.GE.pres .AND. pbot.LE.pres) THEN + lt(i) = k+1 + lb(i) = k + ENDIF + 140 CONTINUE + 150 CONTINUE +c +c Interpolation lineaire: +c + DO i = 1, ilon +c interpolation en logarithme de pression: +c +c ... Modif . P. Le Van ( 20/01/98) .... +c Modif Frédéric Hourdin (3/01/02) + + IF(pgcm(i,lb(i)).EQ.0.OR. + $ pgcm(i,lt(i)).EQ.0.) THEN +c + PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i), + . lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres +c + ENDIF +c + aist(i) = LOG( pgcm(i,lb(i))/ pres ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) ) + aisb(i) = LOG( pres / pgcm(i,lt(i)) ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i))) + enddo + + + endif ! lnew + +c====================================================================== +c inteprollation +c====================================================================== + + do i=1,ilon + Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i) +cIM PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i), +cIM $ Qgcm(i,lt(i)),aist(i),Qpres(i) + enddo +c +c Je mets les vents a zero quand je rencontre une montagne + do i = 1, ilon +cIM if (pgcm(i,1).LT.pres) THEN + if (pgcm(i,1).GT.pres) THEN +c Qpres(i)=1e33 + Qpres(i)=1e+20 +cIM PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres + endif + enddo + +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/top_bound.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/top_bound.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/top_bound.F (revision 1280) @@ -0,0 +1,142 @@ + SUBROUTINE top_bound( vcov,ucov,teta,masse, du,dv,dh ) + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + + +c .. DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO, +C F. LOTT DEC. 2006 +c ( 10/12/06 ) + +c======================================================================= +c +c Auteur: F. LOTT +c ------- +c +c Objet: +c ------ +c +c Dissipation linéaire (ex top_bound de la physique) +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +! #include "comgeom.h" +#include "comdissipn.h" + +c Arguments: +c ---------- + + REAL ucov(iip1,jjp1,llm),vcov(iip1,jjm,llm),teta(iip1,jjp1,llm) + REAL masse(iip1,jjp1,llm) + REAL dv(iip1,jjm,llm),du(iip1,jjp1,llm),dh(iip1,jjp1,llm) + +c Local: +c ------ + + REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm),zm + REAL uzon(jjp1,llm),vzon(jjm,llm),tzon(jjp1,llm) + + INTEGER NDAMP + PARAMETER (NDAMP=4) + integer i + REAL,SAVE :: rdamp(llm) +! & (/(0., i =1,llm-NDAMP),0.125E-5,.25E-5,.5E-5,1.E-5/) + + LOGICAL,SAVE :: first=.true. + + INTEGER j,l + + +C CALCUL DES CHAMPS EN MOYENNE ZONALE: + + if (iflag_top_bound.eq.0) return + + if (first) then + if (iflag_top_bound.eq.1) then +! couche eponge dans les 4 dernieres couches du modele + rdamp(:)=0. + rdamp(llm)=tau_top_bound + rdamp(llm-1)=tau_top_bound/2. + rdamp(llm-2)=tau_top_bound/4. + rdamp(llm-3)=tau_top_bound/8. + else if (iflag_top_bound.eq.2) then +! couce eponge dans toutes les couches de pression plus faible que +! 100 fois la pression de la derniere couche + rdamp(:)=tau_top_bound + s *max(presnivs(llm)/presnivs(:)-0.01,0.) + endif + first=.false. + print*,'TOP_BOUND rdamp=',rdamp + endif + + CALL massbar(masse,massebx,masseby) + + do l=1,llm + do j=1,jjm + vzon(j,l)=0. + zm=0. + do i=1,iim +! Rm: on peut travailler directement avec la moyenne zonale de vcov +! plutot qu'avec celle de v car le coefficient cv qui relie les deux +! ne varie qu'en latitude + vzon(j,l)=vzon(j,l)+vcov(i,j,l)*masseby(i,j,l) + zm=zm+masseby(i,j,l) + enddo + vzon(j,l)=vzon(j,l)/zm + enddo + enddo + + do l=1,llm + do i=1,iip1 + do j=1,jjm + dv(i,j,l)=dv(i,j,l)-rdamp(l)*(vcov(i,j,l)-vzon(j,l)) + enddo + enddo + enddo + + do l=1,llm + do j=2,jjm + uzon(j,l)=0. + zm=0. + do i=1,iim + uzon(j,l)=uzon(j,l)+massebx(i,j,l)*ucov(i,j,l)/cu(i,j) + zm=zm+massebx(i,j,l) + enddo + uzon(j,l)=uzon(j,l)/zm + enddo + enddo + + do l=1,llm + do j=2,jjm + zm=0. + tzon(j,l)=0. + do i=1,iim + tzon(j,l)=tzon(j,l)+teta(i,j,l)*masse(i,j,l) + zm=zm+masse(i,j,l) + enddo + tzon(j,l)=tzon(j,l)/zm + enddo + enddo + +C AMORTISSEMENTS LINEAIRES: + + do l=1,llm + do i=1,iip1 + do j=2,jjm + du(i,j,l)=du(i,j,l) + s -rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l)) + dh(i,j,l)=dh(i,j,l)-rdamp(l)*(teta(i,j,l)-tzon(j,l)) + enddo + enddo + enddo + + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/tourabs.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/tourabs.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/tourabs.F (revision 1280) @@ -0,0 +1,98 @@ + SUBROUTINE tourabs ( ntetaSTD,vcov, ucov, vorabs ) + IMPLICIT NONE + +c======================================================================= +c +c Modif: I. Musat (28/10/04) +c ------- +c adaptation du code tourpot.F pour le calcul de la vorticite absolue +c cf. P. Le Van +c +c Objet: +c ------ +c +c ******************************************************************* +c ............. calcul de la vorticite absolue ................. +c ******************************************************************* +c +c ntetaSTD, vcov,ucov sont des argum. d'entree pour le s-pg . +c vorabs est un argum.de sortie pour le s-pg . +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "logic.h" +#include "comconst.h" +c + INTEGER ntetaSTD + REAL vcov( ip1jm,ntetaSTD ), ucov( ip1jmp1,ntetaSTD ) + REAL vorabs( ip1jm,ntetaSTD ) +c +c variables locales + INTEGER l, ij, i, j + REAL rot( ip1jm,ntetaSTD ) + + + +c ... vorabs = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) .. + + + +c ........ Calcul du rotationnel du vent V puis filtrage ........ + + DO 5 l = 1,ntetaSTD + + DO 2 i = 1, iip1 + DO 2 j = 1, jjm +c + ij=i+(j-1)*iip1 + IF(ij.LE.ip1jm - 1) THEN +c + IF(cv(ij).EQ.0..OR.cv(ij+1).EQ.0..OR. + $ cu(ij).EQ.0..OR.cu(ij+iip1).EQ.0.) THEN + rot( ij,l ) = 0. + continue + ELSE + rot( ij,l ) = (vcov(ij+1,l)/cv(ij+1)-vcov(ij,l)/cv(ij))/ + $ (2.*pi*RAD*cos(rlatv(j)))*float(iim) + $ +(ucov(ij+iip1,l)/cu(ij+iip1)-ucov(ij,l)/cu(ij))/ + $ (pi*RAD)*(float(jjm)-1.) +c + ENDIF + ENDIF !(ij.LE.ip1jm - 1) THEN + 2 CONTINUE + +c .... correction pour rot( iip1,j,l ) ..... +c .... rot(iip1,j,l) = rot(1,j,l) ..... + +CDIR$ IVDEP + + DO 3 ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim, l ) + 3 CONTINUE + + 5 CONTINUE + + + CALL filtreg( rot, jjm, ntetaSTD, 2, 1, .FALSE., 1 ) + + + DO 10 l = 1, ntetaSTD + + DO 6 ij = 1, ip1jm - 1 + vorabs( ij,l ) = ( rot(ij,l) + fext(ij)*unsairez(ij) ) + 6 CONTINUE + +c ..... correction pour vorabs( iip1,j,l) ..... +c .... vorabs(iip1,j,l)= vorabs(1,j,l) .... +CDIR$ IVDEP + DO 8 ij = iip1, ip1jm, iip1 + vorabs( ij,l ) = vorabs( ij -iim,l ) + 8 CONTINUE + + 10 CONTINUE + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/tourpot.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/tourpot.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/tourpot.F (revision 1280) @@ -0,0 +1,81 @@ +! +! $Header$ +! + SUBROUTINE tourpot ( vcov, ucov, massebxy, vorpot ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c ......... calcul du tourbillon potentiel ......... +c ******************************************************************* +c +c vcov,ucov,fext et pbarxyfl sont des argum. d'entree pour le s-pg . +c vorpot est un argum.de sortie pour le s-pg . +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "logic.h" + + REAL rot( ip1jm,llm ) + REAL vcov( ip1jm,llm ),ucov( ip1jmp1,llm ) + REAL massebxy( ip1jm,llm ),vorpot( ip1jm,llm ) + + INTEGER l, ij + + + + +c ... vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy .. + + + +c ........ Calcul du rotationnel du vent V puis filtrage ........ + + DO 5 l = 1,llm + + DO 2 ij = 1, ip1jm - 1 + rot( ij,l ) = vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l) + 2 CONTINUE + +c .... correction pour rot( iip1,j,l ) ..... +c .... rot(iip1,j,l) = rot(1,j,l) ..... + +CDIR$ IVDEP + + DO 3 ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim, l ) + 3 CONTINUE + + 5 CONTINUE + + + CALL filtreg( rot, jjm, llm, 2, 1, .FALSE., 1 ) + + + DO 10 l = 1, llm + + DO 6 ij = 1, ip1jm - 1 + vorpot( ij,l ) = ( rot(ij,l) + fext(ij) ) / massebxy(ij,l) + 6 CONTINUE + +c ..... correction pour vorpot( iip1,j,l) ..... +c .... vorpot(iip1,j,l)= vorpot(1,j,l) .... +CDIR$ IVDEP + DO 8 ij = iip1, ip1jm, iip1 + vorpot( ij,l ) = vorpot( ij -iim,l ) + 8 CONTINUE + + 10 CONTINUE + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/traceurpole.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/traceurpole.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/traceurpole.F (revision 1280) @@ -0,0 +1,69 @@ +! +! $Header$ +! + subroutine traceurpole(q,masse) + + implicit none + +#include "dimensions.h" +c#include "paramr2.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissip.h" +#include "comvert.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "control.h" +#include "ener.h" +#include "description.h" + + +c Arguments + integer iq + real masse(iip1,jjp1,llm) + real q(iip1,jjp1,llm) + + +c Locals + integer i,j,l + real sommemassen(llm) + real sommemqn(llm) + real sommemasses(llm) + real sommemqs(llm) + real qpolen(llm),qpoles(llm) + + +c On impose une seule valeur au pôle Sud j=jjm+1=jjp1 + sommemasses=0 + sommemqs=0 + do l=1,llm + do i=1,iip1 + sommemasses(l)=sommemasses(l)+masse(i,jjp1,l) + sommemqs(l)=sommemqs(l)+masse(i,jjp1,l)*q(i,jjp1,l) + enddo + qpoles(l)=sommemqs(l)/sommemasses(l) + enddo + +c On impose une seule valeur du traceur au pôle Nord j=1 + sommemassen=0 + sommemqn=0 + do l=1,llm + do i=1,iip1 + sommemassen(l)=sommemassen(l)+masse(i,1,l) + sommemqn(l)=sommemqn(l)+masse(i,1,l)*q(i,1,l) + enddo + qpolen(l)=sommemqn(l)/sommemassen(l) + enddo + +c On force le traceur à prendre cette valeur aux pôles + do l=1,llm + do i=1,iip1 + q(i,1,l)=qpolen(l) + q(i,jjp1,l)=qpoles(l) + enddo + enddo + + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/tracstoke.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/tracstoke.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/tracstoke.h (revision 1280) @@ -0,0 +1,5 @@ +! +! $Header$ +! + common /tracstoke/istdyn,istphy,unittrac + integer istdyn,istphy,unittrac Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ugeostr.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ugeostr.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/ugeostr.F (revision 1280) @@ -0,0 +1,69 @@ +! +! $Id$ +! + subroutine ugeostr(phi,ucov) + + +c Calcul du vent covariant geostrophique a partir du champs de +c geopotentiel en supposant que le vent au sol est nul. + + implicit none + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" + + real ucov(iip1,jjp1,llm),phi(iip1,jjp1,llm) + real um(jjm,llm),fact,u(iip1,jjm,llm) + integer i,j,l + + real zlat + + um(:,:)=0 ! initialize um() + + DO j=1,jjm + + if (abs(sin(rlatv(j))).lt.1.e-4) then + zlat=1.e-4 + else + zlat=rlatv(j) + endif + fact=cos(zlat) + fact=fact*fact + fact=fact*fact + fact=fact*fact + fact=(1.-fact)/ + s (2.*omeg*sin(zlat)*(rlatu(j+1)-rlatu(j))) + fact=-fact/rad + DO l=1,llm + DO i=1,iim + u(i,j,l)=fact*(phi(i,j+1,l)-phi(i,j,l)) + um(j,l)=um(j,l)+u(i,j,l)/float(iim) + ENDDO + ENDDO + ENDDO + call dump2d(jjm,llm,um,'Vent-u geostrophique') + +c +c----------------------------------------------------------------------- +c calcul des champ de vent: +c ------------------------- + + DO 301 l=1,llm + DO 302 i=1,iip1 + ucov(i,1,l)=0. + ucov(i,jjp1,l)=0. +302 CONTINUE + DO 304 j=2,jjm + DO 305 i=1,iim + ucov(i,j,l) = 0.5*(u(i,j,l)+u(i,j-1,l))*cu(i,j) +305 CONTINUE + ucov(iip1,j,l)=ucov(1,j,l) +304 CONTINUE +301 CONTINUE + + print*,301 + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/vitvert.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/vitvert.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/vitvert.F (revision 1280) @@ -0,0 +1,52 @@ +! +! $Header$ +! + SUBROUTINE vitvert ( convm , w ) +c + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c .... calcul de la vitesse verticale aux niveaux sigma .... +c ******************************************************************* +c convm est un argument d'entree pour le s-pg ...... +c w est un argument de sortie pour le s-pg ...... +c +c la vitesse verticale est orientee de haut en bas . +c au sol, au niveau sigma(1), w(i,j,1) = 0. +c au sommet, au niveau sigma(llm+1) , la vit.verticale est aussi +c egale a 0. et n'est pas stockee dans le tableau w . +c +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + + REAL w(ip1jmp1,llm),convm(ip1jmp1,llm) + INTEGER l, ij + + + + DO 2 l = 1,llmm1 + + DO 1 ij = 1,ip1jmp1 + w( ij, l+1 ) = convm( ij, l+1 ) - bp(l+1) * convm( ij, 1 ) + 1 CONTINUE + + 2 CONTINUE + + DO 5 ij = 1,ip1jmp1 + w(ij,1) = 0. +5 CONTINUE + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/vlsplt.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/vlsplt.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/vlsplt.F (revision 1280) @@ -0,0 +1,959 @@ +! +! $Header$ +! +c +c + + SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c pente_max facteur de limitation des pentes: 2 en general +c 0 pour un schema amont +c pbaru,pbarv,w flux de masse en u ,v ,w +c pdt pas de temps +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" + +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max +c REAL masse(iip1,jjp1,llm),pente_max + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL q(ip1jmp1,llm) +c REAL q(iip1,jjp1,llm) + REAL w(ip1jmp1,llm),pdt +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii + INTEGER ijlqmin,iqmin,jqmin,lqmin +c + REAL zm(ip1jmp1,llm),newmasse + REAL mu(ip1jmp1,llm) + REAL mv(ip1jm,llm) + REAL mw(ip1jmp1,llm+1) + REAL zq(ip1jmp1,llm),zz + REAL dqx(ip1jmp1,llm),dqy(ip1jmp1,llm),dqz(ip1jmp1,llm) + REAL second,temps0,temps1,temps2,temps3 + REAL ztemps1,ztemps2,ztemps3 + REAL zzpbar, zzw + LOGICAL testcpu + SAVE testcpu + SAVE temps1,temps2,temps3 + INTEGER iminn,imaxx + + REAL qmin,qmax + DATA qmin,qmax/0.,1.e33/ + DATA testcpu/.false./ + DATA temps1,temps2,temps3/0.,0.,0./ + + + zzpbar = 0.5 * pdt + zzw = pdt + DO l=1,llm + DO ij = iip2,ip1jm + mu(ij,l)=pbaru(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jm + mv(ij,l)=pbarv(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jmp1 + mw(ij,l)=w(ij,l) * zzw + ENDDO + ENDDO + + DO ij=1,ip1jmp1 + mw(ij,llm+1)=0. + ENDDO + + CALL SCOPY(ijp1llm,q,1,zq,1) + CALL SCOPY(ijp1llm,masse,1,zm,1) + +cprint*,'Entree vlx1' +c call minmaxq(zq,qmin,qmax,'avant vlx ') + call vlx(zq,pente_max,zm,mu) +cprint*,'Sortie vlx1' +c call minmaxq(zq,qmin,qmax,'apres vlx1 ') + +c print*,'Entree vly1' + call vly(zq,pente_max,zm,mv) +c call minmaxq(zq,qmin,qmax,'apres vly1 ') +cprint*,'Sortie vly1' + call vlz(zq,pente_max,zm,mw) +c call minmaxq(zq,qmin,qmax,'apres vlz ') + + + call vly(zq,pente_max,zm,mv) +c call minmaxq(zq,qmin,qmax,'apres vly ') + + + call vlx(zq,pente_max,zm,mu) +c call minmaxq(zq,qmin,qmax,'apres vlx2 ') + + + DO l=1,llm + DO ij=1,ip1jmp1 + q(ij,l)=zq(ij,l) + ENDDO + DO ij=1,ip1jm+1,iip1 + q(ij+iim,l)=q(ij,l) + ENDDO + ENDDO + + RETURN + END + SUBROUTINE vlx(q,pente_max,masse,u_m) + +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL u_m( ip1jmp1,llm ),pbarv( iip1,jjm,llm) + REAL q(ip1jmp1,llm) + REAL w(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL new_m,zu_m,zdum(ip1jmp1,llm) + REAL sigu(ip1jmp1),dxq(ip1jmp1,llm),dxqu(ip1jmp1) + REAL zz(ip1jmp1) + REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm) + REAL u_mq(ip1jmp1,llm) + + Logical extremum,first,testcpu + SAVE first,testcpu + + REAL SSUM + REAL temps0,temps1,temps2,temps3,temps4,temps5,second + SAVE temps0,temps1,temps2,temps3,temps4,temps5 + + REAL z1,z2,z3 + + DATA first,testcpu/.true.,.false./ + + IF(first) THEN + temps1=0. + temps2=0. + temps3=0. + temps4=0. + temps5=0. + first=.false. + ENDIF + +c calcul de la pente a droite et a gauche de la maille + + + IF (pente_max.gt.-1.e-5) THEN +c IF (pente_max.gt.10) THEN + +c calcul des pentes avec limitation, Van Leer scheme I: +c ----------------------------------------------------- + +c calcul de la pente aux points u + DO l = 1, llm + DO ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) +c IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0' +c sigu(ij)=u_m(ij,l)/masse(ij,l) + ENDDO + DO ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) +c sigu(ij)=sigu(ij-iim) + ENDDO + + DO ij=iip2,ip1jm + adxqu(ij)=abs(dxqu(ij)) + ENDDO + +c calcul de la pente maximum dans la maille en valeur absolue + + DO ij=iip2+1,ip1jm + dxqmax(ij,l)=pente_max* + , min(adxqu(ij-1),adxqu(ij)) +c limitation subtile +c , min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij))) + + + ENDDO + + DO ij=iip1+iip1,ip1jm,iip1 + dxqmax(ij-iim,l)=dxqmax(ij,l) + ENDDO + + DO ij=iip2+1,ip1jm +#ifdef CRAY + dxq(ij,l)= + , cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij)) +#else + IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN + dxq(ij,l)=dxqu(ij-1)+dxqu(ij) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF +#endif + dxq(ij,l)=0.5*dxq(ij,l) + dxq(ij,l)= + , sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l)) + ENDDO + + ENDDO ! l=1,llm +cprint*,'Ok calcul des pentes' + + ELSE ! (pente_max.lt.-1.e-5) + +c Pentes produits: +c ---------------- + + DO l = 1, llm + DO ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + ENDDO + DO ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) + ENDDO + + DO ij=iip2+1,ip1jm + zz(ij)=dxqu(ij-1)*dxqu(ij) + zz(ij)=zz(ij)+zz(ij) + IF(zz(ij).gt.0) THEN + dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij)) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF + ENDDO + + ENDDO + + ENDIF ! (pente_max.lt.-1.e-5) + +c bouclage de la pente en iip1: +c ----------------------------- + + DO l=1,llm + DO ij=iip1+iip1,ip1jm,iip1 + dxq(ij-iim,l)=dxq(ij,l) + ENDDO + DO ij=1,ip1jmp1 + iadvplus(ij,l)=0 + ENDDO + + ENDDO + +c print*,'Bouclage en iip1' + +c calcul des flux a gauche et a droite + +#ifdef CRAY + + DO l=1,llm + DO ij=iip2,ip1jm-1 + zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l), + , 1.+u_m(ij,l)/masse(ij+1,l), + , u_m(ij,l)) + zdum(ij,l)=0.5*zdum(ij,l) + u_mq(ij,l)=cvmgp( + , q(ij,l)+zdum(ij,l)*dxq(ij,l), + , q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l), + , u_m(ij,l)) + u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l) + ENDDO + ENDDO +#else +c on cumule le flux correspondant a toutes les mailles dont la masse +c au travers de la paroi pENDant le pas de temps. +cprint*,'Cumule ....' + + DO l=1,llm + DO ij=iip2,ip1jm-1 +c print*,'masse(',ij,')=',masse(ij,l) + IF (u_m(ij,l).gt.0.) THEN + zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l) + u_mq(ij,l)=u_m(ij,l)*(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l)) + ELSE + zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l) + u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l)) + ENDIF + ENDDO + ENDDO +#endif +c stop + +c go to 9999 +c detection des points ou on advecte plus que la masse de la +c maille + DO l=1,llm + DO ij=iip2,ip1jm-1 + IF(zdum(ij,l).lt.0) THEN + iadvplus(ij,l)=1 + u_mq(ij,l)=0. + ENDIF + ENDDO + ENDDO +cprint*,'Ok test 1' + DO l=1,llm + DO ij=iip1+iip1,ip1jm,iip1 + iadvplus(ij,l)=iadvplus(ij-iim,l) + ENDDO + ENDDO +c print*,'Ok test 2' + + +c traitement special pour le cas ou on advecte en longitude plus que le +c contenu de la maille. +c cette partie est mal vectorisee. + +c calcul du nombre de maille sur lequel on advecte plus que la maille. + + n0=0 + DO l=1,llm + nl(l)=0 + DO ij=iip2,ip1jm + nl(l)=nl(l)+iadvplus(ij,l) + ENDDO + n0=n0+nl(l) + ENDDO + + IF(n0.gt.0) THEN + PRINT*,'Nombre de points pour lesquels on advect plus que le' + & ,'contenu de la maille : ',n0 + + DO l=1,llm + IF(nl(l).gt.0) THEN + iju=0 +c indicage des mailles concernees par le traitement special + DO ij=iip2,ip1jm + IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN + iju=iju+1 + indu(iju)=ij + ENDIF + ENDDO + niju=iju +c PRINT*,'niju,nl',niju,nl(l) + +c traitement des mailles + DO iju=1,niju + ij=indu(iju) + j=(ij-1)/iip1+1 + zu_m=u_m(ij,l) + u_mq(ij,l)=0. + IF(zu_m.gt.0.) THEN + ijq=ij + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l) + zu_m=zu_m-masse(ijq,l) + i=mod(i-2+iim,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m* + & (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l)) + ELSE + ijq=ij+1 + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(-zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l) + zu_m=zu_m+masse(ijq,l) + i=mod(i,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)- + & 0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l)) + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF ! n0.gt.0 +9999 continue + + +c bouclage en latitude +cprint*,'cvant bouclage en latitude' + DO l=1,llm + DO ij=iip1+iip1,ip1jm,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + ENDDO + ENDDO + + +c calcul des tENDances + + DO l=1,llm + DO ij=iip2+1,ip1jm + new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+ + & u_mq(ij-1,l)-u_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + ENDDO +c ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous) + DO ij=iip1+iip1,ip1jm,iip1 + q(ij-iim,l)=q(ij,l) + masse(ij-iim,l)=masse(ij,l) + ENDDO + ENDDO +c CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1) +c CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1) + + + RETURN + END + SUBROUTINE vly(q,pente_max,masse,masse_adv_v) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,masse_adv_v,w sont des arguments d'entree pour le s-pg .... +c dq sont des arguments de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL masse_adv_v( ip1jm,llm) + REAL q(ip1jmp1,llm), dq( ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,ij,l +c + REAL airej2,airejjm,airescb(iim),airesch(iim) + REAL dyq(ip1jmp1,llm),dyqv(ip1jm),zdvm(ip1jmp1,llm) + REAL adyqv(ip1jm),dyqmax(ip1jmp1) + REAL qbyv(ip1jm,llm) + + REAL qpns,qpsn,apn,aps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs +c REAL newq,oldmasse + Logical extremum,first,testcpu + REAL temps0,temps1,temps2,temps3,temps4,temps5,second + SAVE temps0,temps1,temps2,temps3,temps4,temps5 + SAVE first,testcpu + + REAL convpn,convps,convmpn,convmps + real massepn,masseps,qpn,qps + REAL sinlon(iip1),sinlondlon(iip1) + REAL coslon(iip1),coslondlon(iip1) + SAVE sinlon,coslon,sinlondlon,coslondlon + SAVE airej2,airejjm +c +c + REAL SSUM + + DATA first,testcpu/.true.,.false./ + DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ + + IF(first) THEN + PRINT*,'Shema Amont nouveau appele dans Vanleer ' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + ENDDO + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + airej2 = SSUM( iim, aire(iip2), 1 ) + airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) + ENDIF + +c +cPRINT*,'CALCUL EN LATITUDE' + + DO l = 1, llm +c +c -------------------------------- +c CALCUL EN LATITUDE +c -------------------------------- + +c On commence par calculer la valeur du traceur moyenne sur le premier cercle +c de latitude autour du pole (qpns pour le pole nord et qpsn pour +c le pole nord) qui sera utilisee pour evaluer les pentes au pole. + + DO i = 1, iim + airescb(i) = aire(i+ iip1) * q(i+ iip1,l) + airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l) + ENDDO + qpns = SSUM( iim, airescb ,1 ) / airej2 + qpsn = SSUM( iim, airesch ,1 ) / airejjm + +c calcul des pentes aux points v + + DO ij=1,ip1jm + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + adyqv(ij)=abs(dyqv(ij)) + ENDDO + +c calcul des pentes aux points scalaires + + DO ij=iip2,ip1jm + dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij)) + dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) + dyqmax(ij)=pente_max*dyqmax(ij) + ENDDO + +c calcul des pentes aux poles + + DO ij=1,iip1 + dyq(ij,l)=qpns-q(ij+iip1,l) + dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn + ENDDO + +c filtrage de la derivee + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + DO ij=1,iim + dyn1=dyn1+sinlondlon(ij)*dyq(ij,l) + dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l) + dyn2=dyn2+coslondlon(ij)*dyq(ij,l) + dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l) + ENDDO + DO ij=1,iip1 + dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij) + dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij) + ENDDO + +c calcul des pentes limites aux poles + + goto 8888 + fn=1. + fs=1. + DO ij=1,iim + IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN + fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn) + ENDIF + IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN + fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs) + ENDIF + ENDDO + DO ij=1,iip1 + dyq(ij,l)=fn*dyq(ij,l) + dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l) + ENDDO +8888 continue + DO ij=1,iip1 + dyq(ij,l)=0. + dyq(ip1jm+ij,l)=0. + ENDDO + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C En memoire de dIFferents tests sur la +C limitation des pentes aux poles. +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C PRINT*,dyq(1) +C PRINT*,dyqv(iip1+1) +C apn=abs(dyq(1)/dyqv(iip1+1)) +C PRINT*,dyq(ip1jm+1) +C PRINT*,dyqv(ip1jm-iip1+1) +C aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) +C DO ij=2,iim +C apn=amax1(abs(dyq(ij)/dyqv(ij)),apn) +C aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps) +C ENDDO +C apn=min(pente_max/apn,1.) +C aps=min(pente_max/aps,1.) +C +C +C cas ou on a un extremum au pole +C +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & apn=0. +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C & aps=0. +C +C limitation des pentes aux poles +C DO ij=1,iip1 +C dyq(ij)=apn*dyq(ij) +C dyq(ip1jm+ij)=aps*dyq(ip1jm+ij) +C ENDDO +C +C test +C DO ij=1,iip1 +C dyq(iip1+ij)=0. +C dyq(ip1jm+ij-iip1)=0. +C ENDDO +C DO ij=1,ip1jmp1 +C dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) +C ENDDO +C +C changement 10 07 96 +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & THEN +C DO ij=1,iip1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=1,iip1 +C dyqmax(ij)=pente_max*abs(dyqv(ij)) +C ENDDO +C ENDIF +C +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C &THEN +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) +C ENDDO +C ENDIF +C fin changement 10 07 96 +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + +c calcul des pentes limitees + + DO ij=iip2,ip1jm + IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN + dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l)) + ELSE + dyq(ij,l)=0. + ENDIF + ENDDO + + ENDDO + + DO l=1,llm + DO ij=1,ip1jm + IF(masse_adv_v(ij,l).gt.0) THEN + qbyv(ij,l)=q(ij+iip1,l)+dyq(ij+iip1,l)* + , 0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l)) + ELSE + qbyv(ij,l)=q(ij,l)-dyq(ij,l)* + , 0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) + ENDIF + qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l) + ENDDO + ENDDO + + + DO l=1,llm + DO ij=iip2,ip1jm + newmasse=masse(ij,l) + & +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l)) + & /newmasse + masse(ij,l)=newmasse + ENDDO +c.-. ancienne version +c convpn=SSUM(iim,qbyv(1,l),1)/apoln +c convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln + + convpn=SSUM(iim,qbyv(1,l),1) + convmpn=ssum(iim,masse_adv_v(1,l),1) + massepn=ssum(iim,masse(1,l),1) + qpn=0. + do ij=1,iim + qpn=qpn+masse(ij,l)*q(ij,l) + enddo + qpn=(qpn+convpn)/(massepn+convmpn) + do ij=1,iip1 + q(ij,l)=qpn + enddo + +c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols +c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols + + convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) + convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) + masseps=ssum(iim, masse(ip1jm+1,l),1) + qps=0. + do ij = ip1jm+1,ip1jmp1-1 + qps=qps+masse(ij,l)*q(ij,l) + enddo + qps=(qps+convps)/(masseps+convmps) + do ij=ip1jm+1,ip1jmp1 + q(ij,l)=qps + enddo + +c.-. fin ancienne version + +c._. nouvelle version +c convpn=SSUM(iim,qbyv(1,l),1) +c convmpn=ssum(iim,masse_adv_v(1,l),1) +c oldmasse=ssum(iim,masse(1,l),1) +c newmasse=oldmasse+convmpn +c newq=(q(1,l)*oldmasse+convpn)/newmasse +c newmasse=newmasse/apoln +c DO ij = 1,iip1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) +c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) +c oldmasse=ssum(iim,masse(ip1jm-iim,l),1) +c newmasse=oldmasse+convmps +c newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse +c newmasse=newmasse/apols +c DO ij = ip1jm+1,ip1jmp1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c._. fin nouvelle version + ENDDO + + RETURN + END + SUBROUTINE vlz(q,pente_max,masse,w) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c dq sont des arguments de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL q(ip1jmp1,llm) + REAL w(ip1jmp1,llm+1) +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii +c + REAL wq(ip1jmp1,llm+1),newmasse + + REAL dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm),dzqmax + REAL sigw + + LOGICAL testcpu + SAVE testcpu + + REAL temps0,temps1,temps2,temps3,temps4,temps5,second + SAVE temps0,temps1,temps2,temps3,temps4,temps5 + REAL SSUM + + DATA testcpu/.false./ + DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ + +c On oriente tout dans le sens de la pression c'est a dire dans le +c sens de W + +#ifdef BIDON + IF(testcpu) THEN + temps0=second(0.) + ENDIF +#endif + DO l=2,llm + DO ij=1,ip1jmp1 + dzqw(ij,l)=q(ij,l-1)-q(ij,l) + adzqw(ij,l)=abs(dzqw(ij,l)) + ENDDO + ENDDO + + DO l=2,llm-1 + DO ij=1,ip1jmp1 +#ifdef CRAY + dzq(ij,l)=0.5* + , cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1)) +#else + IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN + dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1)) + ELSE + dzq(ij,l)=0. + ENDIF +#endif + dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1)) + dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l)) + ENDDO + ENDDO + + DO ij=1,ip1jmp1 + dzq(ij,1)=0. + dzq(ij,llm)=0. + ENDDO + +#ifdef BIDON + IF(testcpu) THEN + temps1=temps1+second(0.)-temps0 + ENDIF +#endif +c --------------------------------------------------------------- +c .... calcul des termes d'advection verticale ....... +c --------------------------------------------------------------- + +c calcul de - d( q * w )/ d(sigma) qu'on ajoute a dq pour calculer dq + + DO l = 1,llm-1 + do ij = 1,ip1jmp1 + IF(w(ij,l+1).gt.0.) THEN + sigw=w(ij,l+1)/masse(ij,l+1) + wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1)+0.5*(1.-sigw)*dzq(ij,l+1)) + ELSE + sigw=w(ij,l+1)/masse(ij,l) + wq(ij,l+1)=w(ij,l+1)*(q(ij,l)-0.5*(1.+sigw)*dzq(ij,l)) + ENDIF + ENDDO + ENDDO + + DO ij=1,ip1jmp1 + wq(ij,llm+1)=0. + wq(ij,1)=0. + ENDDO + + DO l=1,llm + DO ij=1,ip1jmp1 + newmasse=masse(ij,l)+w(ij,l+1)-w(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+wq(ij,l+1)-wq(ij,l)) + & /newmasse + masse(ij,l)=newmasse + ENDDO + ENDDO + + + RETURN + END +c SUBROUTINE minmaxq(zq,qmin,qmax,comment) +c +c#include "dimensions.h" +c#include "paramet.h" + +c CHARACTER*(*) comment +c real qmin,qmax +c real zq(ip1jmp1,llm) + +c INTEGER jadrs(ip1jmp1), jbad, k, i + + +c DO k = 1, llm +c jbad = 0 +c DO i = 1, ip1jmp1 +c IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN +c jbad = jbad + 1 +c jadrs(jbad) = i +c ENDIF +c ENDDO +c IF (jbad.GT.0) THEN +c PRINT*, comment +c DO i = 1, jbad +cc PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k) +c ENDDO +c ENDIF +c ENDDO + +c return +c end + subroutine minmaxq(zq,qmin,qmax,comment) + +#include "dimensions.h" +#include "paramet.h" + + character*20 comment + real qmin,qmax + real zq(ip1jmp1,llm) + real zzq(iip1,jjp1,llm) + + integer imin,jmin,lmin,ijlmin + integer imax,jmax,lmax,ijlmax + + integer ismin,ismax + +#ifdef isminismax + call scopy (ip1jmp1*llm,zq,1,zzq,1) + + ijlmin=ismin(ijp1llm,zq,1) + lmin=(ijlmin-1)/ip1jmp1+1 + ijlmin=ijlmin-(lmin-1.)*ip1jmp1 + jmin=(ijlmin-1)/iip1+1 + imin=ijlmin-(jmin-1.)*iip1 + zqmin=zq(ijlmin,lmin) + + ijlmax=ismax(ijp1llm,zq,1) + lmax=(ijlmax-1)/ip1jmp1+1 + ijlmax=ijlmax-(lmax-1.)*ip1jmp1 + jmax=(ijlmax-1)/iip1+1 + imax=ijlmax-(jmax-1.)*iip1 + zqmax=zq(ijlmax,lmax) + + if(zqmin.lt.qmin) +c s write(*,9999) comment, + s write(*,*) comment, + s imin,jmin,lmin,zqmin,zzq(imin,jmin,lmin) + if(zqmax.gt.qmax) +c s write(*,9999) comment, + s write(*,*) comment, + s imax,jmax,lmax,zqmax,zzq(imax,jmax,lmax) + +#endif + return +9999 format(a20,' q(',i3,',',i2,',',i2,')=',e12.5,e12.5) + end + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/vlspltqs.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/vlspltqs.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/vlspltqs.F (revision 1280) @@ -0,0 +1,775 @@ +! +! $Header$ +! + SUBROUTINE vlspltqs ( q,pente_max,masse,w,pbaru,pbarv,pdt, + , p,pk,teta ) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget, F.Codron +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c + test sur humidite specifique: Q advecte< Qsat aval +c (F. Codron, 10/99) +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c pente_max facteur de limitation des pentes: 2 en general +c 0 pour un schema amont +c pbaru,pbarv,w flux de masse en u ,v ,w +c pdt pas de temps +c +c teta temperature potentielle, p pression aux interfaces, +c pk exner au milieu des couches necessaire pour calculer Qsat +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" + +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL q(ip1jmp1,llm) + REAL w(ip1jmp1,llm),pdt + REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii +c + REAL qsat(ip1jmp1,llm) + REAL zm(ip1jmp1,llm) + REAL mu(ip1jmp1,llm) + REAL mv(ip1jm,llm) + REAL mw(ip1jmp1,llm+1) + REAL zq(ip1jmp1,llm) + REAL temps1,temps2,temps3 + REAL zzpbar, zzw + LOGICAL testcpu + SAVE testcpu + SAVE temps1,temps2,temps3 + + REAL qmin,qmax + DATA qmin,qmax/0.,1.e33/ + DATA testcpu/.false./ + DATA temps1,temps2,temps3/0.,0.,0./ + +c--pour rapport de melange saturant-- + + REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play + REAL ptarg,pdelarg,foeew,zdelta + REAL tempe(ip1jmp1) + +c fonction psat(T) + + FOEEW ( PTARG,PDELARG ) = EXP ( + * (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT) + * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) ) + + r2es = 380.11733 + r3les = 17.269 + r3ies = 21.875 + r4les = 35.86 + r4ies = 7.66 + retv = 0.6077667 + rtt = 273.16 + +c-- Calcul de Qsat en chaque point +c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2 +c pour eviter une exponentielle. + DO l = 1, llm + DO ij = 1, ip1jmp1 + tempe(ij) = teta(ij,l) * pk(ij,l) /cpp + ENDDO + DO ij = 1, ip1jmp1 + zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) ) + play = 0.5*(p(ij,l)+p(ij,l+1)) + qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play ) + qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) ) + ENDDO + ENDDO + +c PRINT*,'Debut vlsplt version debug sans vlyqs' + + zzpbar = 0.5 * pdt + zzw = pdt + DO l=1,llm + DO ij = iip2,ip1jm + mu(ij,l)=pbaru(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jm + mv(ij,l)=pbarv(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jmp1 + mw(ij,l)=w(ij,l) * zzw + ENDDO + ENDDO + + DO ij=1,ip1jmp1 + mw(ij,llm+1)=0. + ENDDO + + CALL SCOPY(ijp1llm,q,1,zq,1) + CALL SCOPY(ijp1llm,masse,1,zm,1) + +c call minmaxq(zq,qmin,qmax,'avant vlxqs ') + call vlxqs(zq,pente_max,zm,mu,qsat) + + +c call minmaxq(zq,qmin,qmax,'avant vlyqs ') + + call vlyqs(zq,pente_max,zm,mv,qsat) + + +c call minmaxq(zq,qmin,qmax,'avant vlz ') + + call vlz(zq,pente_max,zm,mw) + + +c call minmaxq(zq,qmin,qmax,'avant vlyqs ') +c call minmaxq(zm,qmin,qmax,'M avant vlyqs ') + + call vlyqs(zq,pente_max,zm,mv,qsat) + + +c call minmaxq(zq,qmin,qmax,'avant vlxqs ') +c call minmaxq(zm,qmin,qmax,'M avant vlxqs ') + + call vlxqs(zq,pente_max,zm,mu,qsat) + +c call minmaxq(zq,qmin,qmax,'apres vlxqs ') +c call minmaxq(zm,qmin,qmax,'M apres vlxqs ') + + + DO l=1,llm + DO ij=1,ip1jmp1 + q(ij,l)=zq(ij,l) + ENDDO + DO ij=1,ip1jm+1,iip1 + q(ij+iim,l)=q(ij,l) + ENDDO + ENDDO + + RETURN + END + SUBROUTINE vlxqs(q,pente_max,masse,u_m,qsat) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL u_m( ip1jmp1,llm ) + REAL q(ip1jmp1,llm) + REAL qsat(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL new_m,zu_m,zdum(ip1jmp1,llm) + REAL dxq(ip1jmp1,llm),dxqu(ip1jmp1) + REAL zz(ip1jmp1) + REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm) + REAL u_mq(ip1jmp1,llm) + + Logical first,testcpu + SAVE first,testcpu + + REAL SSUM + REAL temps0,temps1,temps2,temps3,temps4,temps5 + SAVE temps0,temps1,temps2,temps3,temps4,temps5 + + + DATA first,testcpu/.true.,.false./ + + IF(first) THEN + temps1=0. + temps2=0. + temps3=0. + temps4=0. + temps5=0. + first=.false. + ENDIF + +c calcul de la pente a droite et a gauche de la maille + + + IF (pente_max.gt.-1.e-5) THEN +c IF (pente_max.gt.10) THEN + +c calcul des pentes avec limitation, Van Leer scheme I: +c ----------------------------------------------------- + +c calcul de la pente aux points u + DO l = 1, llm + DO ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) +c IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0' +c sigu(ij)=u_m(ij,l)/masse(ij,l) + ENDDO + DO ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) +c sigu(ij)=sigu(ij-iim) + ENDDO + + DO ij=iip2,ip1jm + adxqu(ij)=abs(dxqu(ij)) + ENDDO + +c calcul de la pente maximum dans la maille en valeur absolue + + DO ij=iip2+1,ip1jm + dxqmax(ij,l)=pente_max* + , min(adxqu(ij-1),adxqu(ij)) +c limitation subtile +c , min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij))) + + + ENDDO + + DO ij=iip1+iip1,ip1jm,iip1 + dxqmax(ij-iim,l)=dxqmax(ij,l) + ENDDO + + DO ij=iip2+1,ip1jm +#ifdef CRAY + dxq(ij,l)= + , cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij)) +#else + IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN + dxq(ij,l)=dxqu(ij-1)+dxqu(ij) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF +#endif + dxq(ij,l)=0.5*dxq(ij,l) + dxq(ij,l)= + , sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l)) + ENDDO + + ENDDO ! l=1,llm + + ELSE ! (pente_max.lt.-1.e-5) + +c Pentes produits: +c ---------------- + + DO l = 1, llm + DO ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + ENDDO + DO ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) + ENDDO + + DO ij=iip2+1,ip1jm + zz(ij)=dxqu(ij-1)*dxqu(ij) + zz(ij)=zz(ij)+zz(ij) + IF(zz(ij).gt.0) THEN + dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij)) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF + ENDDO + + ENDDO + + ENDIF ! (pente_max.lt.-1.e-5) + +c bouclage de la pente en iip1: +c ----------------------------- + + DO l=1,llm + DO ij=iip1+iip1,ip1jm,iip1 + dxq(ij-iim,l)=dxq(ij,l) + ENDDO + + DO ij=1,ip1jmp1 + iadvplus(ij,l)=0 + ENDDO + + ENDDO + + +c calcul des flux a gauche et a droite + +#ifdef CRAY +c--pas encore modification sur Qsat + DO l=1,llm + DO ij=iip2,ip1jm-1 + zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l), + , 1.+u_m(ij,l)/masse(ij+1,l), + , u_m(ij,l)) + zdum(ij,l)=0.5*zdum(ij,l) + u_mq(ij,l)=cvmgp( + , q(ij,l)+zdum(ij,l)*dxq(ij,l), + , q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l), + , u_m(ij,l)) + u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l) + ENDDO + ENDDO +#else +c on cumule le flux correspondant a toutes les mailles dont la masse +c au travers de la paroi pENDant le pas de temps. +c le rapport de melange de l'air advecte est min(q_vanleer, Qsat_downwind) + DO l=1,llm + DO ij=iip2,ip1jm-1 + IF (u_m(ij,l).gt.0.) THEN + zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l) + u_mq(ij,l)=u_m(ij,l)* + $ min(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l)) + ELSE + zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l) + u_mq(ij,l)=u_m(ij,l)* + $ min(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l)) + ENDIF + ENDDO + ENDDO +#endif + + +c detection des points ou on advecte plus que la masse de la +c maille + DO l=1,llm + DO ij=iip2,ip1jm-1 + IF(zdum(ij,l).lt.0) THEN + iadvplus(ij,l)=1 + u_mq(ij,l)=0. + ENDIF + ENDDO + ENDDO + DO l=1,llm + DO ij=iip1+iip1,ip1jm,iip1 + iadvplus(ij,l)=iadvplus(ij-iim,l) + ENDDO + ENDDO + + + +c traitement special pour le cas ou on advecte en longitude plus que le +c contenu de la maille. +c cette partie est mal vectorisee. + +c pas d'influence de la pression saturante (pour l'instant) + +c calcul du nombre de maille sur lequel on advecte plus que la maille. + + n0=0 + DO l=1,llm + nl(l)=0 + DO ij=iip2,ip1jm + nl(l)=nl(l)+iadvplus(ij,l) + ENDDO + n0=n0+nl(l) + ENDDO + + IF(n0.gt.0) THEN +ccc PRINT*,'Nombre de points pour lesquels on advect plus que le' +ccc & ,'contenu de la maille : ',n0 + + DO l=1,llm + IF(nl(l).gt.0) THEN + iju=0 +c indicage des mailles concernees par le traitement special + DO ij=iip2,ip1jm + IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN + iju=iju+1 + indu(iju)=ij + ENDIF + ENDDO + niju=iju +c PRINT*,'niju,nl',niju,nl(l) + +c traitement des mailles + DO iju=1,niju + ij=indu(iju) + j=(ij-1)/iip1+1 + zu_m=u_m(ij,l) + u_mq(ij,l)=0. + IF(zu_m.gt.0.) THEN + ijq=ij + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l) + zu_m=zu_m-masse(ijq,l) + i=mod(i-2+iim,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m* + & (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l)) + ELSE + ijq=ij+1 + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(-zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l) + zu_m=zu_m+masse(ijq,l) + i=mod(i,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)- + & 0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l)) + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF ! n0.gt.0 + + + +c bouclage en latitude + + DO l=1,llm + DO ij=iip1+iip1,ip1jm,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + ENDDO + ENDDO + + +c calcul des tendances + + DO l=1,llm + DO ij=iip2+1,ip1jm + new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+ + & u_mq(ij-1,l)-u_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + ENDDO +c Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous) + DO ij=iip1+iip1,ip1jm,iip1 + q(ij-iim,l)=q(ij,l) + masse(ij-iim,l)=masse(ij,l) + ENDDO + ENDDO + +c CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1) +c CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1) + + + RETURN + END + SUBROUTINE vlyqs(q,pente_max,masse,masse_adv_v,qsat) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,masse_adv_v,w sont des arguments d'entree pour le s-pg .... +c qsat est un argument de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL masse_adv_v( ip1jm,llm) + REAL q(ip1jmp1,llm) + REAL qsat(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,ij,l +c + REAL airej2,airejjm,airescb(iim),airesch(iim) + REAL dyq(ip1jmp1,llm),dyqv(ip1jm) + REAL adyqv(ip1jm),dyqmax(ip1jmp1) + REAL qbyv(ip1jm,llm) + + REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs +c REAL newq,oldmasse + Logical first,testcpu + REAL temps0,temps1,temps2,temps3,temps4,temps5 + SAVE temps0,temps1,temps2,temps3,temps4,temps5 + SAVE first,testcpu + + REAL convpn,convps,convmpn,convmps + REAL sinlon(iip1),sinlondlon(iip1) + REAL coslon(iip1),coslondlon(iip1) + SAVE sinlon,coslon,sinlondlon,coslondlon + SAVE airej2,airejjm +c +c + REAL SSUM + + DATA first,testcpu/.true.,.false./ + DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ + + IF(first) THEN + PRINT*,'Shema Amont nouveau appele dans Vanleer ' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + ENDDO + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + airej2 = SSUM( iim, aire(iip2), 1 ) + airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) + ENDIF + +c + + + DO l = 1, llm +c +c -------------------------------- +c CALCUL EN LATITUDE +c -------------------------------- + +c On commence par calculer la valeur du traceur moyenne sur le premier cercle +c de latitude autour du pole (qpns pour le pole nord et qpsn pour +c le pole nord) qui sera utilisee pour evaluer les pentes au pole. + + DO i = 1, iim + airescb(i) = aire(i+ iip1) * q(i+ iip1,l) + airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l) + ENDDO + qpns = SSUM( iim, airescb ,1 ) / airej2 + qpsn = SSUM( iim, airesch ,1 ) / airejjm + +c calcul des pentes aux points v + + DO ij=1,ip1jm + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + adyqv(ij)=abs(dyqv(ij)) + ENDDO + +c calcul des pentes aux points scalaires + + DO ij=iip2,ip1jm + dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij)) + dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) + dyqmax(ij)=pente_max*dyqmax(ij) + ENDDO + +c calcul des pentes aux poles + + DO ij=1,iip1 + dyq(ij,l)=qpns-q(ij+iip1,l) + dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn + ENDDO + +c filtrage de la derivee + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + DO ij=1,iim + dyn1=dyn1+sinlondlon(ij)*dyq(ij,l) + dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l) + dyn2=dyn2+coslondlon(ij)*dyq(ij,l) + dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l) + ENDDO + DO ij=1,iip1 + dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij) + dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij) + ENDDO + +c calcul des pentes limites aux poles + + fn=1. + fs=1. + DO ij=1,iim + IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN + fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn) + ENDIF + IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN + fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs) + ENDIF + ENDDO + DO ij=1,iip1 + dyq(ij,l)=fn*dyq(ij,l) + dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l) + ENDDO + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C En memoire de dIFferents tests sur la +C limitation des pentes aux poles. +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C PRINT*,dyq(1) +C PRINT*,dyqv(iip1+1) +C apn=abs(dyq(1)/dyqv(iip1+1)) +C PRINT*,dyq(ip1jm+1) +C PRINT*,dyqv(ip1jm-iip1+1) +C aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) +C DO ij=2,iim +C apn=amax1(abs(dyq(ij)/dyqv(ij)),apn) +C aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps) +C ENDDO +C apn=min(pente_max/apn,1.) +C aps=min(pente_max/aps,1.) +C +C +C cas ou on a un extremum au pole +C +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & apn=0. +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C & aps=0. +C +C limitation des pentes aux poles +C DO ij=1,iip1 +C dyq(ij)=apn*dyq(ij) +C dyq(ip1jm+ij)=aps*dyq(ip1jm+ij) +C ENDDO +C +C test +C DO ij=1,iip1 +C dyq(iip1+ij)=0. +C dyq(ip1jm+ij-iip1)=0. +C ENDDO +C DO ij=1,ip1jmp1 +C dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) +C ENDDO +C +C changement 10 07 96 +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & THEN +C DO ij=1,iip1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=1,iip1 +C dyqmax(ij)=pente_max*abs(dyqv(ij)) +C ENDDO +C ENDIF +C +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C &THEN +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) +C ENDDO +C ENDIF +C fin changement 10 07 96 +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + +c calcul des pentes limitees + + DO ij=iip2,ip1jm + IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN + dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l)) + ELSE + dyq(ij,l)=0. + ENDIF + ENDDO + + ENDDO + + DO l=1,llm + DO ij=1,ip1jm + IF( masse_adv_v(ij,l).GT.0. ) THEN + qbyv(ij,l)= MIN( qsat(ij+iip1,l), q(ij+iip1,l ) + + , dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l))) + ELSE + qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l) - dyq(ij,l) * + , 0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) ) + ENDIF + qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l) + ENDDO + ENDDO + + + DO l=1,llm + DO ij=iip2,ip1jm + newmasse=masse(ij,l) + & +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l)) + & /newmasse + masse(ij,l)=newmasse + ENDDO +c.-. ancienne version + convpn=SSUM(iim,qbyv(1,l),1)/apoln + convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln + DO ij = 1,iip1 + newmasse=masse(ij,l)+convmpn*aire(ij) + q(ij,l)=(q(ij,l)*masse(ij,l)+convpn*aire(ij))/ + & newmasse + masse(ij,l)=newmasse + ENDDO + convps = -SSUM(iim,qbyv(ip1jm-iim,l),1)/apols + convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols + DO ij = ip1jm+1,ip1jmp1 + newmasse=masse(ij,l)+convmps*aire(ij) + q(ij,l)=(q(ij,l)*masse(ij,l)+convps*aire(ij))/ + & newmasse + masse(ij,l)=newmasse + ENDDO +c.-. fin ancienne version + +c._. nouvelle version +c convpn=SSUM(iim,qbyv(1,l),1) +c convmpn=ssum(iim,masse_adv_v(1,l),1) +c oldmasse=ssum(iim,masse(1,l),1) +c newmasse=oldmasse+convmpn +c newq=(q(1,l)*oldmasse+convpn)/newmasse +c newmasse=newmasse/apoln +c DO ij = 1,iip1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) +c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) +c oldmasse=ssum(iim,masse(ip1jm-iim,l),1) +c newmasse=oldmasse+convmps +c newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse +c newmasse=newmasse/apols +c DO ij = ip1jm+1,ip1jmp1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c._. fin nouvelle version + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/wrgrads.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/wrgrads.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/wrgrads.F (revision 1280) @@ -0,0 +1,133 @@ +! +! $Header$ +! + subroutine wrgrads(if,nl,field,name,titlevar) + implicit none + +c Declarations +c if indice du fichier +c nl nombre de couches +c field champ +c name petit nom +c titlevar Titre + +#include "gradsdef.h" + +c arguments + integer if,nl + real field(imx*jmx*lmx) + + integer, parameter:: wp = selected_real_kind(p=6, r=36) + real(wp) field4(imx*jmx*lmx) + + character*10 name,file + character*10 titlevar + +c local + + integer im,jm,lm,i,j,l,lnblnk,iv,iii,iji,iif,ijf + + logical writectl + + + writectl=.false. + +c print*,if,iid(if),jid(if),ifd(if),jfd(if) + iii=iid(if) + iji=jid(if) + iif=ifd(if) + ijf=jfd(if) + im=iif-iii+1 + jm=ijf-iji+1 + lm=lmd(if) + +c print*,'im,jm,lm,name,firsttime(if)' +c print*,im,jm,lm,name,firsttime(if) + + if(firsttime(if)) then + if(name.eq.var(1,if)) then + firsttime(if)=.false. + ivar(if)=1 + print*,'fin de l initialiation de l ecriture du fichier' + print*,file + print*,'fichier no: ',if + print*,'unit ',unit(if) + print*,'nvar ',nvar(if) + print*,'vars ',(var(iv,if),iv=1,nvar(if)) + else + ivar(if)=ivar(if)+1 + nvar(if)=ivar(if) + var(ivar(if),if)=name + tvar(ivar(if),if)=titlevar(1:lnblnk(titlevar)) + nld(ivar(if),if)=nl +c print*,'initialisation ecriture de ',var(ivar(if),if) +c print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if) + endif + writectl=.true. + itime(if)=1 + else + ivar(if)=mod(ivar(if),nvar(if))+1 + if (ivar(if).eq.nvar(if)) then + writectl=.true. + itime(if)=itime(if)+1 + endif + + if(var(ivar(if),if).ne.name) then + print*,'Il faut stoker la meme succession de champs a chaque' + print*,'pas de temps' + print*,'fichier no: ',if + print*,'unit ',unit(if) + print*,'nvar ',nvar(if) + print*,'vars ',(var(iv,if),iv=1,nvar(if)) + + stop + endif + endif + +c print*,'ivar(if),nvar(if),var(ivar(if),if),writectl' +c print*,ivar(if),nvar(if),var(ivar(if),if),writectl + field4(1:imd(if)*jmd(if)*nl)=field(1:imd(if)*jmd(if)*nl) + do l=1,nl + irec(if)=irec(if)+1 +c print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf, +c s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii +c s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif + write(unit(if)+1,rec=irec(if)) + s ((field4((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i) + s ,i=iii,iif),j=iji,ijf) + enddo + if (writectl) then + + file=fichier(if) +c WARNING! on reecrase le fichier .ctl a chaque ecriture + open(unit(if),file=file(1:lnblnk(file))//'.ctl' + & ,form='formatted',status='unknown') + write(unit(if),'(a5,1x,a40)') + & 'DSET ','^'//file(1:lnblnk(file))//'.dat' + + write(unit(if),'(a12)') 'UNDEF 1.0E30' + write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if) + call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF') + call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF') + call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF') + write(unit(if),'(a4,i10,a30)') + & 'TDEF ',itime(if),' LINEAR 02JAN1987 1MO ' + write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if) + do iv=1,nvar(if) +c print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)' +c print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if) + write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if) + & ,99,tvar(iv,if) + enddo + write(unit(if),'(a7)') 'ENDVARS' +c +1000 format(a5,3x,i4,i3,1x,a39) + + close(unit(if)) + + endif ! writectl + + return + + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/write_grads_dyn.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/write_grads_dyn.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/write_grads_dyn.h (revision 1280) @@ -0,0 +1,31 @@ +! +! $Header$ +! + if (callinigrads) then + + string10='dyn' + call inigrads(1,iip1 + s ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi + s ,llm,presnivs,1. + s ,dtvr*iperiod,string10,'dyn_zon ') + + callinigrads=.false. + + + endif + + string10='ps' + CALL wrgrads(1,1,ps,string10,string10) + + string10='u' + CALL wrgrads(1,llm,unat,string10,string10) + string10='v' + CALL wrgrads(1,llm,vnat,string10,string10) + string10='teta' + CALL wrgrads(1,llm,teta,string10,string10) + do iq=1,nqtot + string10='q' + write(string10(2:2),'(i1)') iq + CALL wrgrads(1,llm,q(:,:,iq),string10,string10) + enddo + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/write_paramLMDZ_dyn.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/write_paramLMDZ_dyn.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3d/write_paramLMDZ_dyn.h (revision 1280) @@ -0,0 +1,246 @@ +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +! Attention : il n'y a aucune raison pour ecrire ces constantes +! comme des champs 2D. A corriger un jour ... + +c + ndex2d = 0 + itau_w=itau_dyn+itau +c + zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(prt_level) + CALL histwrite(nid_ctesGCM, "prt_level", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(dayref) + CALL histwrite(nid_ctesGCM, "dayref", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(anneeref) + CALL histwrite(nid_ctesGCM, "anneeref", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(raz_date) + CALL histwrite(nid_ctesGCM, "raz_date", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(nday) + CALL histwrite(nid_ctesGCM, "nday", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(day_step) + CALL histwrite(nid_ctesGCM, "day_step", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iperiod) + CALL histwrite(nid_ctesGCM, "iperiod", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iapp_tracvl) + CALL histwrite(nid_ctesGCM, "iapp_tracvl", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iconser) + CALL histwrite(nid_ctesGCM, "iconser", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iecri) + CALL histwrite(nid_ctesGCM, "iecri", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=periodav + CALL histwrite(nid_ctesGCM, "periodav", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(idissip) + CALL histwrite(nid_ctesGCM, "idissip", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + IF(lstardis) THEN + zx_tmp_2d(1:iip1,1:jjp1)=1. + ELSE + zx_tmp_2d(1:iip1,1:jjp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM, "lstardis", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(nitergdiv) + CALL histwrite(nid_ctesGCM, "nitergdiv", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(nitergrot) + CALL histwrite(nid_ctesGCM, "nitergrot", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(niterh) + CALL histwrite(nid_ctesGCM, "niterh", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=tetagdiv + CALL histwrite(nid_ctesGCM, "tetagdiv", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=tetagrot + CALL histwrite(nid_ctesGCM, "tetagrot", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=tetatemp + CALL histwrite(nid_ctesGCM, "tetatemp", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=coefdis + CALL histwrite(nid_ctesGCM, "coefdis", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + IF(purmats) THEN + zx_tmp_2d(1:iip1,1:jjp1)=1. + ELSE + zx_tmp_2d(1:iip1,1:jjp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM, "purmats", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + IF(ok_guide) THEN + zx_tmp_2d(1:iip1,1:jjp1)=1. + ELSE + zx_tmp_2d(1:iip1,1:jjp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM, "ok_guide", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + if (calend == 'earth_360d') then + zx_tmp_2d(1:iip1,1:jjp1)=1. + else if (calend == 'earth_365d') then + zx_tmp_2d(1:iip1,1:jjp1)=2. + else if (calend == 'earth_366d') then + zx_tmp_2d(1:iip1,1:jjp1)=3. + endif + + CALL histwrite(nid_ctesGCM, "true_calendar", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iflag_phys) + CALL histwrite(nid_ctesGCM, "iflag_phys", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iphysiq) + CALL histwrite(nid_ctesGCM, "iphysiq", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH 2008/05/02 +! La variable cycle_diurne n'est pas vue par la dynamique +! IF(cycle_diurne) THEN +! zx_tmp_2d(1:iip1,1:jjp1)=1. +! ELSE +! zx_tmp_2d(1:iip1,1:jjp1)=0. +! ENDIF +! CALL histwrite(nid_ctesGCM, "cycle_diurne", itau_w, +! . zx_tmp_2d,iip1*jjp1,ndex2d) +! +! IF(soil_model) THEN +! zx_tmp_2d(1:iip1,1:jjp1)=1. +! ELSE +! zx_tmp_2d(1:iip1,1:jjp1)=0. +! ENDIF +! CALL histwrite(nid_ctesGCM, "soil_model", itau_w, +! . zx_tmp_2d,iip1*jjp1,ndex2d) +! +! IF(new_oliq) THEN +! zx_tmp_2d(1:iip1,1:jjp1)=1. +! ELSE +! zx_tmp_2d(1:iip1,1:jjp1)=0. +! ENDIF +! CALL histwrite(nid_ctesGCM, "new_oliq", itau_w, +! . zx_tmp_2d,iip1*jjp1,ndex2d) +! +! IF(ok_orodr) THEN +! zx_tmp_2d(1:iip1,1:jjp1)=1. +! ELSE +! zx_tmp_2d(1:iip1,1:jjp1)=0. +! ENDIF +! CALL histwrite(nid_ctesGCM, "ok_orodr", itau_w, +! . zx_tmp_2d,iip1*jjp1,ndex2d) +! +! IF(ok_orolf) THEN +! zx_tmp_2d(1:iip1,1:jjp1)=1. +! ELSE +! zx_tmp_2d(1:iip1,1:jjp1)=0. +! ENDIF +! CALL histwrite(nid_ctesGCM, "ok_orolf", itau_w, +! . zx_tmp_2d,iip1*jjp1,ndex2d) +! +! IF(ok_limitvrai) THEN +! zx_tmp_2d(1:iip1,1:jjp1)=1. +! ELSE +! zx_tmp_2d(1:iip1,1:jjp1)=0. +! ENDIF +! CALL histwrite(nid_ctesGCM, "ok_limitvrai", itau_w, +! . zx_tmp_2d,iip1*jjp1,ndex2d) +! +! zx_tmp_2d(1:iip1,1:jjp1)=nbapp_rad +! CALL histwrite(nid_ctesGCM, "nbapp_rad", itau_w, +! . zx_tmp_2d,iip1*jjp1,ndex2d) +! +! zx_tmp_2d(1:iip1,1:jjp1)=iflag_con +! CALL histwrite(nid_ctesGCM, "iflag_con", itau_w, +! . zx_tmp_2d,iip1*jjp1,ndex2d) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c + zx_tmp_2d(1:iip1,1:jjp1)=clon + CALL histwrite(nid_ctesGCM, "clon", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=clat + CALL histwrite(nid_ctesGCM, "clat", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=grossismx + CALL histwrite(nid_ctesGCM, "grossismx", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=grossismy + CALL histwrite(nid_ctesGCM, "grossismy", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + IF(fxyhypb) THEN + zx_tmp_2d(1:iip1,1:jjp1)=1. + ELSE + zx_tmp_2d(1:iip1,1:jjp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM, "fxyhypb", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=dzoomx + CALL histwrite(nid_ctesGCM, "dzoomx", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=dzoomy + CALL histwrite(nid_ctesGCM, "dzoomy", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=taux + CALL histwrite(nid_ctesGCM, "taux", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=tauy + CALL histwrite(nid_ctesGCM, "tauy", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + IF(ysinus) THEN + zx_tmp_2d(1:iip1,1:jjp1)=1. + ELSE + zx_tmp_2d(1:iip1,1:jjp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM, "ysinus", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=ip_ebil_dyn + CALL histwrite(nid_ctesGCM, "ip_ebil_dyn", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c +c================================================================= +c + if (ok_sync) then + call histsync(nid_ctesGCM) + endif +c +c================================================================= Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/PVtheta.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/PVtheta.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/PVtheta.F (revision 1280) @@ -0,0 +1,196 @@ + SUBROUTINE PVtheta(ilon,ilev,pucov,pvcov,pteta, + $ ztfi,zplay,zplev, + $ nbteta,theta,PVteta) + IMPLICIT none + +c======================================================================= +c +c Auteur: I. Musat +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c Calcul de la vorticite potentielle PVteta sur des iso-theta selon +c la methodologie du NCEP/NCAR : +c 1) on calcule la stabilite statique N**2=g/T*(dT/dz+g/cp) sur les +c niveaux du modele => N2 +c 2) on interpole les vents, la temperature et le N**2 sur des isentropes +c (en fait sur des iso-theta) lineairement en log(theta) => +c ucovteta, vcovteta, N2teta +c 3) on calcule la vorticite absolue sur des iso-theta => vorateta +c 4) on calcule la densite rho sur des iso-theta => rhoteta +c +c rhoteta = (T/theta)**(cp/R)*p0/(R*T) +c +c 5) on calcule la vorticite potentielle sur des iso-theta => PVteta +c +c PVteta = (vorateta * N2 * theta)/(g * rhoteta) ! en PVU +c +c NB: 1PVU=10**(-6) K*m**2/(s * kg) +c +c PVteta = vorateta * N2/(g**2 * rhoteta) ! en 1/(Pa*s) +c +c +c ******************************************************************* +c +c +c Variables d'entree : ilon,ilev,pucov,pvcov,pteta,ztfi,zplay,zplev,nbteta,theta +c -> sur la grille dynamique +c Variable de sortie : PVteta +c -> sur la grille physique +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +c +c variables Input +c + INTEGER ilon, ilev + REAL pvcov(iip1,jjm,ilev) + REAL pucov(iip1,jjp1,ilev) + REAL pteta(iip1,jjp1,ilev) + REAL ztfi(ilon,ilev) + REAL zplay(ilon,ilev), zplev(ilon,ilev+1) + INTEGER nbteta + REAL theta(nbteta) +c +c variable Output +c + REAL PVteta(ilon,nbteta) +c +c variables locales +c + INTEGER i, j, l, ig0 + REAL SSUM + REAL teta(ilon, ilev) + REAL ptetau(ip1jmp1, ilev), ptetav(ip1jm, ilev) + REAL ucovteta(ip1jmp1,ilev), vcovteta(ip1jm,ilev) + REAL N2(ilon,ilev-1), N2teta(ilon,nbteta) + REAL ztfiteta(ilon,nbteta) + REAL rhoteta(ilon,nbteta) + REAL vorateta(iip1,jjm,nbteta) + REAL voratetafi(ilon,nbteta), vorpol(iim) +c +#include "comgeom2.h" +#include "comconst.h" +#include "comvert.h" +c +c projection teta sur la grille physique +c + DO l=1,llm + teta(1,l) = pteta(1,1,l) + ig0 = 2 + DO j = 2, jjm + DO i = 1, iim + teta(ig0,l) = pteta(i,j,l) + ig0 = ig0 + 1 + ENDDO + ENDDO + teta(ig0,l) = pteta(1,jjp1,l) + ENDDO +c +c calcul pteta sur les grilles U et V +c + DO l=1, llm + DO j=1, jjp1 + DO i=1, iip1 + ig0=i+(j-1)*iip1 + ptetau(ig0,l)=pteta(i,j,l) + ENDDO !i + ENDDO !j + DO j=1, jjm + DO i=1, iip1 + ig0=i+(j-1)*iip1 + ptetav(ig0,l)=0.5*(pteta(i,j,l)+pteta(i,j+1,l)) + ENDDO !i + ENDDO !j + ENDDO !l +c +c projection pucov, pvcov sur une surface de theta constante +c + DO l=1, nbteta +cIM 1rout CALL tetaleveli1j1(ip1jmp1,llm,.true.,ptetau,theta(l), + CALL tetalevel(ip1jmp1,llm,.true.,ptetau,theta(l), + . pucov,ucovteta(:,l)) +cIM 1rout CALL tetaleveli1j(ip1jm,llm,.true.,ptetav,theta(l), + CALL tetalevel(ip1jm,llm,.true.,ptetav,theta(l), + . pvcov,vcovteta(:,l)) + ENDDO !l +c +c calcul vorticite absolue sur une iso-theta : vorateta +c + CALL tourabs(nbteta,vcovteta,ucovteta,vorateta) +c +c projection vorateta sur la grille physique => voratetafi +c + DO l=1,nbteta + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim + voratetafi(ig0+i+1,l) = vorateta( i ,j-1,l) * alpha4(i+1,j) + + $ vorateta(i+1,j-1,l) * alpha1(i+1,j) + + $ vorateta(i ,j ,l) * alpha3(i+1,j) + + $ vorateta(i+1,j ,l) * alpha2(i+1,j) + ENDDO + voratetafi(ig0 +1,l) = voratetafi(ig0 +1+ iim,l) + ENDDO + ENDDO +c + DO l=1,nbteta + DO i=1,iim + vorpol(i) = vorateta(i,1,l)*aire(i,1) + ENDDO + voratetafi(1,l)= SSUM(iim,vorpol,1)/apoln + ENDDO +c + DO l=1,nbteta + DO i=1,iim + vorpol(i) = vorateta(i,jjm,l)* aire(i,jjm +1) + ENDDO + voratetafi(ilon,l)= SSUM(iim,vorpol,1)/apols + ENDDO +c +c calcul N**2 sur la grille physique => N2 +c + DO l=1, llm-1 + DO i=1, ilon + N2(i,l) = (g**2 * zplay(i,l) * + $ (ztfi(i,l+1)-ztfi(i,l)) )/ + $ (R*ztfi(i,l)*ztfi(i,l)* + $ (zplev(i,l)-zplev(i,l+1)) )+ + $ (g**2)/(ztfi(i,l)*CPP) + ENDDO !i + ENDDO !l +c +c calcul N2 sur une iso-theta => N2teta +c + DO l=1, nbteta + CALL tetalevel(ilon,llm-1,.true.,teta,theta(l), + $ N2,N2teta(:,l)) + CALL tetalevel(ilon,llm,.true.,teta,theta(l), + $ ztfi,ztfiteta(:,l)) + ENDDO !l=1, nbteta +c +c calcul rho et PV sur une iso-theta : rhoteta, PVteta +c + DO l=1, nbteta + DO i=1, ilon + rhoteta(i,l)=(ztfiteta(i,l)/theta(l))**(CPP/R)* + $ (preff/(R*ztfiteta(i,l))) +c +c PVteta en PVU +c + PVteta(i,l)=(theta(l)*g*voratetafi(i,l)*N2teta(i,l))/ + $ (g**2*rhoteta(i,l)) +c +c PVteta en 1/(Pa*s) +c + PVteta(i,l)=(voratetafi(i,l)*N2teta(i,l))/ + $ (g**2*rhoteta(i,l)) + ENDDO !i + ENDDO !l +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/abort_gcm.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/abort_gcm.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/abort_gcm.F (revision 1280) @@ -0,0 +1,51 @@ +! +! $Id$ +! +c +c + SUBROUTINE abort_gcm(modname, message, ierr) + +#ifdef CPP_IOIPSL + USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin_dump + USE ioipsl_getincom +#endif + USE parallel +#include "iniprint.h" + +C +C Stops the simulation cleanly, closing files and printing various +C comments +C +C Input: modname = name of calling program +C message = stuff to print +C ierr = severity of situation ( = 0 normal ) + + character (len=*) :: modname + integer ierr + character (len=*) :: message + + write(lunout,*) 'in abort_gcm' +#ifdef CPP_IOIPSL +c$OMP MASTER + call histclo + call restclo + if (MPI_rank .eq. 0) then + call getin_dump + endif +c$OMP END MASTER +#endif +c call histclo(2) +c call histclo(3) +c call histclo(4) +c call histclo(5) + write(lunout,*) 'Stopping in ', modname + write(lunout,*) 'Reason = ',message + if (ierr .eq. 0) then + write(lunout,*) 'Everything is cool' + else + write(lunout,*) 'Houston, we have a problem ', ierr + STOP + endif + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/academic.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/academic.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/academic.h (revision 1280) @@ -0,0 +1,5 @@ +! +! $Header$ +! + real tetarappel(ip1jmp1,llm),taurappel + common/academic/tetarappel,taurappel Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/adaptdt.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/adaptdt.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/adaptdt.F (revision 1280) @@ -0,0 +1,59 @@ +! +! $Header$ +! + subroutine adaptdt(nadv,dtbon,n,pbaru, + c masse) + + IMPLICIT NONE + +#include "dimensions.h" +c#include "paramr2.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissip.h" +#include "comvert.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "control.h" +#include "ener.h" +#include "description.h" + +c---------------------------------------------------------- +c Arguments +c---------------------------------------------------------- + INTEGER n,nadv + REAL dtbon + REAL pbaru(iip1,jjp1,llm) + REAL masse(iip1,jjp1,llm) +c---------------------------------------------------------- +c Local +c---------------------------------------------------------- + INTEGER i,j,l + REAL CFLmax,aaa,bbb + + CFLmax=0. + do l=1,llm + do j=2,jjm + do i=1,iim + aaa=pbaru(i,j,l)*dtvr/masse(i,j,l) + CFLmax=max(CFLmax,aaa) + bbb=-pbaru(i,j,l)*dtvr/masse(i+1,j,l) + CFLmax=max(CFLmax,bbb) + enddo + enddo + enddo + n=int(CFLmax)+1 +c pour reproduire cas VL du code qui appele x,y,z,y,x +c if (nadv.eq.30) n=n/2 ! Pour Prather + dtbon=dtvr/n + + return + end + + + + + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/addfi_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/addfi_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/addfi_p.F (revision 1280) @@ -0,0 +1,244 @@ +! +! $Header$ +! + SUBROUTINE addfi_p(pdt, leapf, forward, + S pucov, pvcov, pteta, pq , pps , + S pdufi, pdvfi, pdhfi,pdqfi, pdpfi ) + USE parallel + USE infotrac, ONLY : nqtot + IMPLICIT NONE +c +c======================================================================= +c +c Addition of the physical tendencies +c +c Interface : +c ----------- +c +c Input : +c ------- +c pdt time step of integration +c leapf logical +c forward logical +c pucov(ip1jmp1,llm) first component of the covariant velocity +c pvcov(ip1ip1jm,llm) second component of the covariant velocity +c pteta(ip1jmp1,llm) potential temperature +c pts(ip1jmp1,llm) surface temperature +c pdufi(ip1jmp1,llm) | +c pdvfi(ip1jm,llm) | respective +c pdhfi(ip1jmp1) | tendencies +c pdtsfi(ip1jmp1) | +c +c Output : +c -------- +c pucov +c pvcov +c ph +c pts +c +c +c======================================================================= +c +c----------------------------------------------------------------------- +c +c 0. Declarations : +c ------------------ +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "serre.h" +c +c Arguments : +c ----------- +c + REAL pdt +c + REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm) + REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nqtot),pps(ip1jmp1) +c + REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm) + REAL pdqfi(ip1jmp1,llm,nqtot),pdhfi(ip1jmp1,llm),pdpfi(ip1jmp1) +c + LOGICAL leapf,forward +c +c +c Local variables : +c ----------------- +c + REAL xpn(iim),xps(iim),tpn,tps + INTEGER j,k,iq,ij + REAL qtestw, qtestt + PARAMETER ( qtestw = 1.0e-15 ) + PARAMETER ( qtestt = 1.0e-40 ) + + REAL SSUM + EXTERNAL SSUM + + INTEGER :: ijb,ije +c +c----------------------------------------------------------------------- + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt + ENDDO + ENDDO +c$OMP END DO NOWAIT + + if (pole_nord) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO ij = 1, iim + xpn(ij) = aire( ij ) * pteta( ij ,k) + ENDDO + tpn = SSUM(iim,xpn,1)/ apoln + + DO ij = 1, iip1 + pteta( ij ,k) = tpn + ENDDO + ENDDO +c$OMP END DO NOWAIT + endif + + if (pole_sud) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO ij = 1, iim + xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k) + ENDDO + tps = SSUM(iim,xps,1)/ apols + + DO ij = 1, iip1 + pteta(ij+ip1jm,k) = tps + ENDDO + ENDDO +c$OMP END DO NOWAIT + endif +c + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt + ENDDO + ENDDO +c$OMP END DO NOWAIT + + if (pole_nord) ijb=ij_begin + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c + if (pole_sud) ije=ij_end +c$OMP MASTER + DO j = ijb,ije + pps(j) = pps(j) + pdpfi(j) * pdt + ENDDO +c$OMP END MASTER + + DO iq = 1, 2 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt + pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDDO + + DO iq = 3, nqtot +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt + pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDDO + +c$OMP MASTER + if (pole_nord) then + + DO ij = 1, iim + xpn(ij) = aire( ij ) * pps( ij ) + ENDDO + + tpn = SSUM(iim,xpn,1)/apoln + + DO ij = 1, iip1 + pps ( ij ) = tpn + ENDDO + + endif + + if (pole_sud) then + + DO ij = 1, iim + xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm ) + ENDDO + + tps = SSUM(iim,xps,1)/apols + + DO ij = 1, iip1 + pps ( ij+ip1jm ) = tps + ENDDO + + endif +c$OMP END MASTER + + if (pole_nord) then + DO iq = 1, nqtot +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO ij = 1, iim + xpn(ij) = aire( ij ) * pq( ij ,k,iq) + ENDDO + tpn = SSUM(iim,xpn,1)/apoln + + DO ij = 1, iip1 + pq ( ij ,k,iq) = tpn + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDDO + endif + + if (pole_sud) then + DO iq = 1, nqtot +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO ij = 1, iim + xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq) + ENDDO + tps = SSUM(iim,xps,1)/apols + + DO ij = 1, iip1 + pq (ij+ip1jm,k,iq) = tps + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDDO + endif + + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advect_new_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advect_new_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advect_new_p.F (revision 1280) @@ -0,0 +1,284 @@ +! +! $Header$ +! + SUBROUTINE advect_new_p(ucov,vcov,teta,w,massebx,masseby, + & du,dv,dteta) + USE parallel + USE write_field_p + IMPLICIT NONE +c======================================================================= +c +c Auteurs: P. Le Van , Fr. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ************************************************************* +c .... calcul des termes d'advection vertic.pour u,v,teta,q ... +c ************************************************************* +c ces termes sont ajoutes a du,dv,dteta et dq . +c Modif F.Forget 03/94 : on retire q de advect +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "ener.h" + +c Arguments: +c ---------- + + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm) + REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm) + REAL,SAVE :: dv1(ip1jm,llm),du1(ip1jmp1,llm),dteta1(ip1jmp1,llm) + REAL,SAVE :: dv2(ip1jm,llm),du2(ip1jmp1,llm),dteta2(ip1jmp1,llm) +c Local: +c ------ + + REAL,SAVE :: uav(ip1jmp1,llm),vav(ip1jm,llm) + REAL wsur2(ip1jmp1) + REAL unsaire2(ip1jmp1), ge(ip1jmp1) + REAL deuxjour, ww, gt, uu, vv + + INTEGER ij,l,ijb,ije + + EXTERNAL SSUM + REAL SSUM + +c----------------------------------------------------------------------- +c 2. Calculs preliminaires: +c ------------------------- + + IF (conser) THEN + deuxjour = 2. * daysec + + DO 1 ij = 1, ip1jmp1 + unsaire2(ij) = unsaire(ij) * unsaire(ij) + 1 CONTINUE + END IF + + +c------------------ -yy ---------------------------------------------- +c . Calcul de u + +c$OMP MASTER + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + DO ij=ijb,ije + du2(ij,1)=0. + ENDDO + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + dv2(ij,1)=0. + ENDDO + + ijb=ij_begin + ije=ij_end + + DO ij=ijb,ije + dteta2(ij,1)=0. + ENDDO +c$OMP END MASTER + + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + +c DO ij = iip2, ip1jmp1 +c uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) ) +c ENDDO + +c DO ij = iip2, ip1jm +c uav(ij,l) = uav(ij,l) + uav(ij+iip1,l) +c ENDDO + + DO ij = ijb, ije + + uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l)) + . +0.25*(ucov(ij+iip1,l)+ucov(ij,l)) + ENDDO + + if (pole_nord) then + DO ij = 1, iip1 + uav(ij ,l) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iip1 + uav(ip1jm+ij,l) = 0. + ENDDO + endif + + ENDDO +c$OMP END DO +c call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/))) + +c------------------ -xx ---------------------------------------------- +c . Calcul de v + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + DO ij = ijb+1, ije + vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) ) + ENDDO + + DO ij = ijb,ije,iip1 + vav(ij,l) = vav(ij+iim,l) + ENDDO + + + DO ij = ijb, ije-1 + vav(ij,l) = vav(ij,l) + vav(ij+1,l) + ENDDO + + DO ij = ijb, ije, iip1 + vav(ij+iim,l) = vav(ij,l) + ENDDO + + ENDDO +c$OMP END DO +c call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/))) + +c----------------------------------------------------------------------- +c$OMP BARRIER + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 20 l = 1, llmm1 + + +c ...... calcul de - w/2. au niveau l+1 ....... + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ij_end + + DO 5 ij = ijb, ije + wsur2( ij ) = - 0.5 * w( ij,l+1 ) + 5 CONTINUE + + +c ..................... calcul pour du .................. + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + DO 6 ij = ijb ,ije-1 + ww = wsur2 ( ij ) + wsur2( ij+1 ) + uu = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) ) + du1(ij,l) = ww * ( uu - uav(ij, l ) )/massebx(ij, l ) + du2(ij,l+1)= ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1) + 6 CONTINUE + +c ................. calcul pour dv ..................... + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO 8 ij = ijb, ije + ww = wsur2( ij+iip1 ) + wsur2( ij ) + vv = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) ) + dv1(ij,l) = ww * (vv - vav(ij, l ) )/masseby(ij, l ) + dv2(ij,l+1)= ww * (vv - vav(ij,l+1) )/masseby(ij,l+1) + 8 CONTINUE + +c + +c ............................................................ +c ............... calcul pour dh ................... +c ............................................................ + +c ---z +c calcul de - d( teta * w ) qu'on ajoute a dh +c ............... + ijb=ij_begin + ije=ij_end + + DO 15 ij = ijb, ije + ww = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) ) + dteta1(ij, l ) = ww + dteta2(ij,l+1) = ww + 15 CONTINUE + +c ym ---> conser a voir plus tard + +c IF( conser) THEN +c +c DO 17 ij = 1,ip1jmp1 +c ge(ij) = wsur2(ij) * wsur2(ij) * unsaire2(ij) +c 17 CONTINUE +c gt = SSUM( ip1jmp1,ge,1 ) +c gtot(l) = deuxjour * SQRT( gt/ip1jmp1 ) +c END IF + + 20 CONTINUE +c$OMP END DO + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + du(ij,l)=du(ij,l)+du2(ij,l)-du1(ij,l) + ENDDO + + DO ij = ijb+iip1-1, ije, iip1 + du( ij, l ) = du( ij -iim, l ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + dv(ij,l)=dv(ij,l)+dv2(ij,l)-dv1(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + dteta(ij,l)=dteta(ij,l)+dteta2(ij,l)-dteta1(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advect_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advect_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advect_p.F (revision 1280) @@ -0,0 +1,219 @@ +! +! $Header$ +! + SUBROUTINE advect_p(ucov,vcov,teta,w,massebx,masseby,du,dv,dteta) + USE parallel + USE write_field_p + IMPLICIT NONE +c======================================================================= +c +c Auteurs: P. Le Van , Fr. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ************************************************************* +c .... calcul des termes d'advection vertic.pour u,v,teta,q ... +c ************************************************************* +c ces termes sont ajoutes a du,dv,dteta et dq . +c Modif F.Forget 03/94 : on retire q de advect +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "ener.h" + +c Arguments: +c ---------- + + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm) + REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm) + +c Local: +c ------ + + REAL uav(ip1jmp1,llm),vav(ip1jm,llm),wsur2(ip1jmp1) + REAL unsaire2(ip1jmp1), ge(ip1jmp1) + REAL deuxjour, ww, gt, uu, vv + + INTEGER ij,l,ijb,ije + + EXTERNAL SSUM + REAL SSUM + +c----------------------------------------------------------------------- +c 2. Calculs preliminaires: +c ------------------------- + + IF (conser) THEN + deuxjour = 2. * daysec + + DO 1 ij = 1, ip1jmp1 + unsaire2(ij) = unsaire(ij) * unsaire(ij) + 1 CONTINUE + END IF + + +c------------------ -yy ---------------------------------------------- +c . Calcul de u + + DO l=1,llm + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + +c DO ij = iip2, ip1jmp1 +c uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) ) +c ENDDO + +c DO ij = iip2, ip1jm +c uav(ij,l) = uav(ij,l) + uav(ij+iip1,l) +c ENDDO + + DO ij = ijb, ije + + uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l)) + . +0.25*(ucov(ij+iip1,l)+ucov(ij,l)) + ENDDO + + if (pole_nord) then + DO ij = 1, iip1 + uav(ij ,l) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iip1 + uav(ip1jm+ij,l) = 0. + ENDDO + endif + + ENDDO + +c call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/))) + +c------------------ -xx ---------------------------------------------- +c . Calcul de v + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO l=1,llm + + DO ij = ijb+1, ije + vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) ) + ENDDO + + DO ij = ijb,ije,iip1 + vav(ij,l) = vav(ij+iim,l) + ENDDO + + + DO ij = ijb, ije-1 + vav(ij,l) = vav(ij,l) + vav(ij+1,l) + ENDDO + + DO ij = ijb, ije, iip1 + vav(ij+iim,l) = vav(ij,l) + ENDDO + + ENDDO +c call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/))) +c----------------------------------------------------------------------- + + + + DO 20 l = 1, llmm1 + + +c ...... calcul de - w/2. au niveau l+1 ....... + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ij_end + + DO 5 ij = ijb, ije + wsur2( ij ) = - 0.5 * w( ij,l+1 ) + 5 CONTINUE + + +c ..................... calcul pour du .................. + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + DO 6 ij = ijb ,ije-1 + ww = wsur2 ( ij ) + wsur2( ij+1 ) + uu = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) ) + du(ij,l) = du(ij,l) - ww * ( uu - uav(ij, l ) )/massebx(ij, l ) + du(ij,l+1)= du(ij,l+1) + ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1) + 6 CONTINUE + +c ..... correction pour du(iip1,j,l) ........ +c ..... du(iip1,j,l)= du(1,j,l) ..... + +CDIR$ IVDEP + DO 7 ij = ijb+iip1-1, ije, iip1 + du( ij, l ) = du( ij -iim, l ) + du( ij,l+1 ) = du( ij -iim,l+1 ) + 7 CONTINUE + +c ................. calcul pour dv ..................... + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO 8 ij = ijb, ije + ww = wsur2( ij+iip1 ) + wsur2( ij ) + vv = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) ) + dv(ij,l) = dv(ij, l ) - ww * (vv - vav(ij, l ) )/masseby(ij, l ) + dv(ij,l+1)= dv(ij,l+1) + ww * (vv - vav(ij,l+1) )/masseby(ij,l+1) + 8 CONTINUE + +c + +c ............................................................ +c ............... calcul pour dh ................... +c ............................................................ + +c ---z +c calcul de - d( teta * w ) qu'on ajoute a dh +c ............... + ijb=ij_begin + ije=ij_end + + DO 15 ij = ijb, ije + ww = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) ) + dteta(ij, l ) = dteta(ij, l ) - ww + dteta(ij,l+1) = dteta(ij,l+1) + ww + 15 CONTINUE + +c ym ---> conser a voir plus tard + +c IF( conser) THEN +c +c DO 17 ij = 1,ip1jmp1 +c ge(ij) = wsur2(ij) * wsur2(ij) * unsaire2(ij) +c 17 CONTINUE +c gt = SSUM( ip1jmp1,ge,1 ) +c gtot(l) = deuxjour * SQRT( gt/ip1jmp1 ) +c END IF + + 20 CONTINUE + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advn.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advn.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advn.F (revision 1280) @@ -0,0 +1,983 @@ +! +! $Header$ +! + SUBROUTINE advn(q,masse,w,pbaru,pbarv,pdt,mode) +c +c Auteur : F. Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c pbaru,pbarv,w flux de masse en u ,v ,w +c pdt pas de temps +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +#include "iniprint.h" + +c +c Arguments: +c ---------- + integer mode + real masse(ip1jmp1,llm) + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL q(ip1jmp1,llm) + REAL w(ip1jmp1,llm),pdt +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii + integer ijlqmin,iqmin,jqmin,lqmin + integer ismin +c + real zm(ip1jmp1,llm),newmasse + real mu(ip1jmp1,llm) + real mv(ip1jm,llm) + real mw(ip1jmp1,llm+1) + real zq(ip1jmp1,llm),zz,qpn,qps + real zqg(ip1jmp1,llm),zqd(ip1jmp1,llm) + real zqs(ip1jmp1,llm),zqn(ip1jmp1,llm) + real zqh(ip1jmp1,llm),zqb(ip1jmp1,llm) + real temps0,temps1,temps2,temps3 + real ztemps1,ztemps2,ztemps3,ssum + logical testcpu + save testcpu + save temps1,temps2,temps3 + real zzpbar,zzw + +#ifdef CRAY + real second +#endif + + real qmin,qmax + data qmin,qmax/0.,1./ + data testcpu/.false./ + data temps1,temps2,temps3/0.,0.,0./ + + zzpbar = 0.5 * pdt + zzw = pdt + + DO l=1,llm + DO ij = iip2,ip1jm + mu(ij,l)=pbaru(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jm + mv(ij,l)=pbarv(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jmp1 + mw(ij,l)=w(ij,l) * zzw + ENDDO + ENDDO + + DO ij=1,ip1jmp1 + mw(ij,llm+1)=0. + ENDDO + + do l=1,llm + qpn=0. + qps=0. + do ij=1,iim + qpn=qpn+q(ij,l)*masse(ij,l) + qps=qps+q(ip1jm+ij,l)*masse(ip1jm+ij,l) + enddo + qpn=qpn/ssum(iim,masse(1,l),1) + qps=qps/ssum(iim,masse(ip1jm+1,l),1) + do ij=1,iip1 + q(ij,l)=qpn + q(ip1jm+ij,l)=qps + enddo + enddo + + do ij=1,ip1jmp1 + mw(ij,llm+1)=0. + enddo + do l=1,llm + do ij=1,ip1jmp1 + zq(ij,l)=q(ij,l) + zm(ij,l)=masse(ij,l) + enddo + enddo + +c call minmaxq(zq,qmin,qmax,'avant vlx ') + call advnqx(zq,zqg,zqd) + call advnx(zq,zqg,zqd,zm,mu,mode) + call advnqy(zq,zqs,zqn) + call advny(zq,zqs,zqn,zm,mv) + call advnqz(zq,zqh,zqb) + call advnz(zq,zqh,zqb,zm,mw) +c call vlz(zq,0.,zm,mw) + call advnqy(zq,zqs,zqn) + call advny(zq,zqs,zqn,zm,mv) + call advnqx(zq,zqg,zqd) + call advnx(zq,zqg,zqd,zm,mu,mode) +c call minmaxq(zq,qmin,qmax,'apres vlx ') + +#ifdef CRAY + if(testcpu) then + ztemps1=second(0.) + temps1=temps1+ztemps1-ztemps2 + print*,'VLSPLT X:',temps1,' Y:',temps2,' Z:',temps3 + endif +#endif + do l=1,llm + do ij=1,ip1jmp1 + q(ij,l)=zq(ij,l) + enddo + do ij=1,ip1jm+1,iip1 + q(ij+iim,l)=q(ij,l) + enddo + enddo + + RETURN + END + + SUBROUTINE advnqx(q,qg,qd) +c +c Auteurs: Calcul des valeurs de q aux point u. +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real q(ip1jmp1,llm),qg(ip1jmp1,llm),qd(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real dxqu(ip1jmp1),zqu(ip1jmp1) + real zqmax(ip1jmp1),zqmin(ip1jmp1) + logical extremum(ip1jmp1) + + integer mode + save mode + data mode/1/ + +c calcul des pentes en u: +c ----------------------- + if (mode.eq.0) then + do l=1,llm + do ij=1,ip1jm + qd(ij,l)=q(ij,l) + qg(ij,l)=q(ij,l) + enddo + enddo + else + do l = 1, llm + do ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + zqu(ij)=0.5*(q(ij+1,l)+q(ij,l)) + enddo + do ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) + zqu(ij)=zqu(ij-iim) + enddo + do ij=iip2,ip1jm-1 + zqu(ij)=zqu(ij)-dxqu(ij+1)/12. + enddo + do ij=iip1+iip1,ip1jm,iip1 + zqu(ij)=zqu(ij-iim) + enddo + do ij=iip2+1,ip1jm + zqu(ij)=zqu(ij)+dxqu(ij-1)/12. + enddo + do ij=iip1+iip1,ip1jm,iip1 + zqu(ij-iim)=zqu(ij) + enddo + +c calcul des valeurs max et min acceptees aux interfaces + + do ij=iip2,ip1jm-1 + zqmax(ij)=max(q(ij+1,l),q(ij,l)) + zqmin(ij)=min(q(ij+1,l),q(ij,l)) + enddo + do ij=iip1+iip1,ip1jm,iip1 + zqmax(ij)=zqmax(ij-iim) + zqmin(ij)=zqmin(ij-iim) + enddo + do ij=iip2+1,ip1jm + extremum(ij)=dxqu(ij)*dxqu(ij-1).le.0. + enddo + do ij=iip1+iip1,ip1jm,iip1 + extremum(ij-iim)=extremum(ij) + enddo + do ij=iip2,ip1jm + zqu(ij)=min(max(zqmin(ij),zqu(ij)),zqmax(ij)) + enddo + do ij=iip2+1,ip1jm + if(extremum(ij)) then + qg(ij,l)=q(ij,l) + qd(ij,l)=q(ij,l) + else + qd(ij,l)=zqu(ij) + qg(ij,l)=zqu(ij-1) + endif + enddo + do ij=iip1+iip1,ip1jm,iip1 + qd(ij-iim,l)=qd(ij,l) + qg(ij-iim,l)=qg(ij,l) + enddo + + goto 8888 + + do ij=iip2+1,ip1jm + if(extremum(ij).and..not.extremum(ij-1)) + s qd(ij-1,l)=q(ij,l) + enddo + + do ij=iip1+iip1,ip1jm,iip1 + qd(ij-iim,l)=qd(ij,l) + enddo + do ij=iip2,ip1jm-1 + if (extremum(ij).and..not.extremum(ij+1)) + s qg(ij+1,l)=q(ij,l) + enddo + + do ij=iip1+iip1,ip1jm,iip1 + qg(ij,l)=qg(ij-iim,l) + enddo +8888 continue + enddo + endif + RETURN + END + SUBROUTINE advnqy(q,qs,qn) +c +c Auteurs: Calcul des valeurs de q aux point v. +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real q(ip1jmp1,llm),qs(ip1jmp1,llm),qn(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real dyqv(ip1jm),zqv(ip1jm,llm) + real zqmax(ip1jm),zqmin(ip1jm) + logical extremum(ip1jmp1) + + integer mode + save mode + data mode/1/ + + if (mode.eq.0) then + do l=1,llm + do ij=1,ip1jmp1 + qn(ij,l)=q(ij,l) + qs(ij,l)=q(ij,l) + enddo + enddo + else + +c calcul des pentes en u: +c ----------------------- + do l = 1, llm + do ij=1,ip1jm + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + enddo + + do ij=iip2,ip1jm-iip1 + zqv(ij,l)=0.5*(q(ij+iip1,l)+q(ij,l)) + zqv(ij,l)=zqv(ij,l)+(dyqv(ij+iip1)-dyqv(ij-iip1))/12. + enddo + + do ij=iip2,ip1jm + extremum(ij)=dyqv(ij)*dyqv(ij-iip1).le.0. + enddo + +c Pas de pentes aux poles + do ij=1,iip1 + zqv(ij,l)=q(ij,l) + zqv(ip1jm-iip1+ij,l)=q(ip1jm+ij,l) + extremum(ij)=.true. + extremum(ip1jmp1-iip1+ij)=.true. + enddo + +c calcul des valeurs max et min acceptees aux interfaces + do ij=1,ip1jm + zqmax(ij)=max(q(ij+iip1,l),q(ij,l)) + zqmin(ij)=min(q(ij+iip1,l),q(ij,l)) + enddo + + do ij=1,ip1jm + zqv(ij,l)=min(max(zqmin(ij),zqv(ij,l)),zqmax(ij)) + enddo + + do ij=iip2,ip1jm + if(extremum(ij)) then + qs(ij,l)=q(ij,l) + qn(ij,l)=q(ij,l) +c if (.not.extremum(ij-iip1)) qs(ij-iip1,l)=q(ij,l) +c if (.not.extremum(ij+iip1)) qn(ij+iip1,l)=q(ij,l) + else + qs(ij,l)=zqv(ij,l) + qn(ij,l)=zqv(ij-iip1,l) + endif + enddo + + do ij=1,iip1 + qs(ij,l)=q(ij,l) + qn(ij,l)=q(ij,l) + qs(ip1jm+ij,l)=q(ip1jm+ij,l) + qn(ip1jm+ij,l)=q(ip1jm+ij,l) + enddo + + enddo + endif + RETURN + END + + SUBROUTINE advnqz(q,qh,qb) +c +c Auteurs: Calcul des valeurs de q aux point v. +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real q(ip1jmp1,llm),qh(ip1jmp1,llm),qb(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real dzqw(ip1jmp1,llm+1),zqw(ip1jmp1,llm+1) + real zqmax(ip1jmp1,llm),zqmin(ip1jmp1,llm) + logical extremum(ip1jmp1,llm) + + integer mode + save mode + + data mode/1/ + +c calcul des pentes en u: +c ----------------------- + + if (mode.eq.0) then + do l=1,llm + do ij=1,ip1jmp1 + qb(ij,l)=q(ij,l) + qh(ij,l)=q(ij,l) + enddo + enddo + else + do l = 2, llm + do ij=1,ip1jmp1 + dzqw(ij,l)=q(ij,l-1)-q(ij,l) + zqw(ij,l)=0.5*(q(ij,l-1)+q(ij,l)) + enddo + enddo + do ij=1,ip1jmp1 + dzqw(ij,1)=0. + dzqw(ij,llm+1)=0. + enddo + do l=2,llm + do ij=1,ip1jmp1 + zqw(ij,l)=zqw(ij,l)+(dzqw(ij,l+1)-dzqw(ij,l-1))/12. + enddo + enddo + do l=2,llm-1 + do ij=1,ip1jmp1 + extremum(ij,l)=dzqw(ij,l)*dzqw(ij,l+1).le.0. + enddo + enddo + +c Pas de pentes en bas et en haut + do ij=1,ip1jmp1 + zqw(ij,2)=q(ij,1) + zqw(ij,llm)=q(ij,llm) + extremum(ij,1)=.true. + extremum(ij,llm)=.true. + enddo + +c calcul des valeurs max et min acceptees aux interfaces + do l=2,llm + do ij=1,ip1jmp1 + zqmax(ij,l)=max(q(ij,l-1),q(ij,l)) + zqmin(ij,l)=min(q(ij,l-1),q(ij,l)) + enddo + enddo + + do l=2,llm + do ij=1,ip1jmp1 + zqw(ij,l)=min(max(zqmin(ij,l),zqw(ij,l)),zqmax(ij,l)) + enddo + enddo + + do l=2,llm-1 + do ij=1,ip1jmp1 + if(extremum(ij,l)) then + qh(ij,l)=q(ij,l) + qb(ij,l)=q(ij,l) + else + qh(ij,l)=zqw(ij,l+1) + qb(ij,l)=zqw(ij,l) + endif + enddo + enddo +c do l=2,llm-1 +c do ij=1,ip1jmp1 +c if(extremum(ij,l)) then +c if (.not.extremum(ij,l-1)) qh(ij,l-1)=q(ij,l) +c if (.not.extremum(ij,l+1)) qb(ij,l+1)=q(ij,l) +c endif +c enddo +c enddo + + do ij=1,ip1jmp1 + qb(ij,1)=q(ij,1) + qh(ij,1)=q(ij,1) + qb(ij,llm)=q(ij,llm) + qh(ij,llm)=q(ij,llm) + enddo + + endif + + RETURN + END + + SUBROUTINE advnx(q,qg,qd,masse,u_m,mode) +c +c Auteur : F. Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + integer mode + real masse(ip1jmp1,llm) + real u_m( ip1jmp1,llm ) + real q(ip1jmp1,llm),qd(ip1jmp1,llm),qg(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,j,ij,l,indu(ip1jmp1),niju,iju,ijq + integer n0,nl(llm) +c + real new_m,zu_m,zdq,zz + real zsigg(ip1jmp1,llm),zsigd(ip1jmp1,llm),zsig + real u_mq(ip1jmp1,llm) + + real zm,zq,zsigm,zsigp,zqm,zqp,zu + + logical ladvplus(ip1jmp1,llm) + + real prec + save prec + +#ifdef CRAY + data prec/1.e-24/ +#else + data prec/1.e-15/ +#endif + + do l=1,llm + do ij=iip2,ip1jm + zdq=qd(ij,l)-qg(ij,l) +c if((qd(ij,l)-q(ij,l))*(q(ij,l)-qg(ij,l)).lt.0.) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,qd(ij,l),q(ij,l),qg(ij,l) +c qd(ij,l)=q(ij,l) +c qg(ij,l)=q(ij,l) +c endif + if(abs(zdq).gt.prec) then + zsigd(ij,l)=(q(ij,l)-qg(ij,l))/zdq + zsigg(ij,l)=1.-zsigd(ij,l) +c if(.not.(zsigd(ij,l).ge.0..and.zsigd(ij,l).le.1. .and. +c s zsigg(ij,l).ge.0..or.zsigg(ij,l).le.1.) ) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,'sigg=',zsigg(ij,l),' sigd=',zsigd(ij,l) +c print*,'q d,c,g ',qd(ij,l),q(ij,l),qg(ij,l),zdq +c stop +c endif + else + zsigd(ij,l)=0.5 + zsigg(ij,l)=0.5 + qd(ij,l)=q(ij,l) + qg(ij,l)=q(ij,l) + endif + enddo + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do l=1,llm + do ij=iip2,ip1jm-1 + if (u_m(ij,l).ge.0.) then + zsigp=zsigd(ij,l) + zsigm=zsigg(ij,l) + zqp=qd(ij,l) + zqm=qg(ij,l) + zm=masse(ij,l) + zq=q(ij,l) + else + zsigm=zsigd(ij+1,l) + zsigp=zsigg(ij+1,l) + zqm=qd(ij+1,l) + zqp=qg(ij+1,l) + zm=masse(ij+1,l) + zq=q(ij+1,l) + endif + zu=abs(u_m(ij,l)) + ladvplus(ij,l)=zu.gt.zm + zsig=zu/zm + if(zsig.eq.0.) zsigp=0.1 + if (mode.eq.1) then + if (zsig.le.zsigp) then + u_mq(ij,l)=u_m(ij,l)*zqp + else if (mode.eq.1) then + u_mq(ij,l)= + s sign(zm,u_m(ij,l))*(zsigp*zqp+(zsig-zsigp)*zqm) + endif + else + if (zsig.le.zsigp) then + u_mq(ij,l)=u_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) + else + zz=0.5*(zsig-zsigp)/zsigm + u_mq(ij,l)=sign(zm,u_m(ij,l))*( 0.5*(zq+zqp)*zsigp + s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) + endif + endif +c if(zsig.lt.0.) then +c print*,'au point ij=',ij,' l=',l,' sig=',zsig +c stop +c endif + enddo + enddo + + do l=1,llm + do ij=iip1+iip1,ip1jm,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + ladvplus(ij,l)=ladvplus(ij-iim,l) + enddo + enddo + +c================================================================= +C SCHEMA SEMI-LAGRAGIEN EN X DANS LES REGIONS POLAIRES +c================================================================= +c tris des regions a traiter + n0=0 + do l=1,llm + nl(l)=0 + do ij=iip2,ip1jm + if(ladvplus(ij,l)) then + nl(l)=nl(l)+1 + u_mq(ij,l)=0. + endif + enddo + n0=n0+nl(l) + enddo + + if(n0.gt.1) then + IF (prt_level > 9) WRITE(lunout,*) + & 'Nombre de points pour lesquels on advect plus que le' + & ,'contenu de la maille : ',n0 + + do l=1,llm + if(nl(l).gt.0) then + iju=0 +c indicage des mailles concernees par le traitement special + do ij=iip2,ip1jm + if(ladvplus(ij,l).and.mod(ij,iip1).ne.0) then + iju=iju+1 + indu(iju)=ij + endif + enddo + niju=iju +c print*,'niju,nl',niju,nl(l) + +c traitement des mailles + do iju=1,niju + ij=indu(iju) + j=(ij-1)/iip1+1 + zu_m=u_m(ij,l) + u_mq(ij,l)=0. + if(zu_m.gt.0.) then + ijq=ij + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l) + zu_m=zu_m-masse(ijq,l) + i=mod(i-2+iim,iim)+1 + ijq=(j-1)*iip1+i + enddo +c MODIFS SPECIFIQUES DU SCHEMA +c ajout de la maille non completement advectee + zsig=zu_m/masse(ijq,l) + if(zsig.le.zsigd(ijq,l)) then + u_mq(ij,l)=u_mq(ij,l)+zu_m*(qd(ijq,l) + s -0.5*zsig/zsigd(ijq,l)*(qd(ijq,l)-q(ijq,l))) + else +c u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l) +c goto 8888 + zz=0.5*(zsig-zsigd(ijq,l))/zsigg(ijq,l) + if(.not.(zz.gt.0..and.zz.le.0.5)) then + WRITE(lunout,*)'probleme2 au point ij=',ij, + s ' l=',l + WRITE(lunout,*)'zz=',zz + stop + endif + u_mq(ij,l)=u_mq(ij,l)+masse(ijq,l)*( + s 0.5*(q(ijq,l)+qd(ijq,l))*zsigd(ijq,l) + s +(zsig-zsigd(ijq,l))*(q(ijq,l)+zz*(qg(ijq,l)-q(ijq,l))) ) + endif + else + ijq=ij+1 + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(-zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l) + zu_m=zu_m+masse(ijq,l) + i=mod(i,iim)+1 + ijq=(j-1)*iip1+i + enddo +c ajout de la maille non completement advectee +c 2eme MODIF SPECIFIQUE + zsig=-zu_m/masse(ij+1,l) + if(zsig.le.zsigg(ijq,l)) then + u_mq(ij,l)=u_mq(ij,l)+zu_m*(qg(ijq,l) + s -0.5*zsig/zsigg(ijq,l)*(qg(ijq,l)-q(ijq,l))) + else +c u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l) +c goto 9999 + zz=0.5*(zsig-zsigg(ijq,l))/zsigd(ijq,l) + if(.not.(zz.gt.0..and.zz.le.0.5)) then + WRITE(lunout,*)'probleme22 au point ij=',ij + s ,' l=',l + WRITE(lunout,*)'zz=',zz + stop + endif + u_mq(ij,l)=u_mq(ij,l)-masse(ijq,l)*( + s 0.5*(q(ijq,l)+qg(ijq,l))*zsigg(ijq,l) + s +(zsig-zsigg(ijq,l))* + s (q(ijq,l)+zz*(qd(ijq,l)-q(ijq,l))) ) + endif +c fin de la modif + endif + enddo + endif + enddo + endif ! n0.gt.0 + +c bouclage en latitude + do l=1,llm + do ij=iip1+iip1,ip1jm,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + enddo + enddo + +c================================================================= +c CALCUL DE LA CONVERGENCE DES FLUX +c================================================================= + + do l=1,llm + do ij=iip2+1,ip1jm + new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+ + & u_mq(ij-1,l)-u_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + enddo +c Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous) + do ij=iip1+iip1,ip1jm,iip1 + q(ij-iim,l)=q(ij,l) + masse(ij-iim,l)=masse(ij,l) + enddo + enddo + + RETURN + END + SUBROUTINE advny(q,qs,qn,masse,v_m) +c +c Auteur : F. Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real masse(ip1jmp1,llm) + real v_m( ip1jm,llm ) + real q(ip1jmp1,llm),qn(ip1jmp1,llm),qs(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real new_m,zdq,zz + real zsigs(ip1jmp1),zsign(ip1jmp1),zsig + real v_mq(ip1jm,llm) + real convpn,convps,convmpn,convmps,massen,masses + real zm,zq,zsigm,zsigp,zqm,zqp + real ssum + real prec + save prec + +#ifdef CRAY + data prec/1.e-24/ +#else + data prec/1.e-15/ +#endif + do l=1,llm + do ij=1,ip1jmp1 + zdq=qn(ij,l)-qs(ij,l) +c if((qn(ij,l)-q(ij,l))*(q(ij,l)-qs(ij,l)).lt.0.) then +c print*,'probleme au point ij=',ij,' l=',l,' advnqx' +c print*,qn(ij,l),q(ij,l),qs(ij,l) +c qn(ij,l)=q(ij,l) +c qs(ij,l)=q(ij,l) +c endif + if(abs(zdq).gt.prec) then + zsign(ij)=(q(ij,l)-qs(ij,l))/zdq + zsigs(ij)=1.-zsign(ij) +c if(.not.(zsign(ij).ge.0..and.zsign(ij).le.1. .and. +c s zsigs(ij).ge.0..or.zsigs(ij).le.1.) ) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,'sigs=',zsigs(ij),' sign=',zsign(ij) +c stop +c endif + else + zsign(ij)=0.5 + zsigs(ij)=0.5 + endif + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do ij=1,ip1jm + if (v_m(ij,l).ge.0.) then + zsigp=zsign(ij+iip1) + zsigm=zsigs(ij+iip1) + zqp=qn(ij+iip1,l) + zqm=qs(ij+iip1,l) + zm=masse(ij+iip1,l) + zq=q(ij+iip1,l) + else + zsigm=zsign(ij) + zsigp=zsigs(ij) + zqm=qn(ij,l) + zqp=qs(ij,l) + zm=masse(ij,l) + zq=q(ij,l) + endif + zsig=abs(v_m(ij,l))/zm + if(zsig.eq.0.) zsigp=0.1 + if (zsig.le.zsigp) then + v_mq(ij,l)=v_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) + else + zz=0.5*(zsig-zsigp)/zsigm + v_mq(ij,l)=sign(zm,v_m(ij,l))*( 0.5*(zq+zqp)*zsigp + s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) + endif + enddo + enddo + + do l=1,llm + do ij=iip2,ip1jm + new_m=masse(ij,l) + & +v_m(ij,l)-v_m(ij-iip1,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+v_mq(ij,l)-v_mq(ij-iip1,l)) + & /new_m + masse(ij,l)=new_m + enddo +c.-. ancienne version + convpn=SSUM(iim,v_mq(1,l),1) + convmpn=ssum(iim,v_m(1,l),1) + massen=ssum(iim,masse(1,l),1) + new_m=massen+convmpn + q(1,l)=(q(1,l)*massen+convpn)/new_m + do ij = 1,iip1 + q(ij,l)=q(1,l) + masse(ij,l)=new_m*aire(ij)/apoln + enddo + + convps=-SSUM(iim,v_mq(ip1jm-iim,l),1) + convmps=-ssum(iim,v_m(ip1jm-iim,l),1) + masses=ssum(iim,masse(ip1jm+1,l),1) + new_m=masses+convmps + q(ip1jm+1,l)=(q(ip1jm+1,l)*masses+convps)/new_m + do ij = ip1jm+1,ip1jmp1 + q(ij,l)=q(ip1jm+1,l) + masse(ij,l)=new_m*aire(ij)/apols + enddo + enddo + + RETURN + END + SUBROUTINE advnz(q,qh,qb,masse,w_m) +c +c Auteurs: F.Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c b designe le bas et h le haut +c il y a une correspondance entre le b en z et le d en x +c ******************************************************************** +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real masse(ip1jmp1,llm) + real w_m( ip1jmp1,llm+1) + real q(ip1jmp1,llm),qb(ip1jmp1,llm),qh(ip1jmp1,llm) + +c +c Local +c --------- +c + INTEGER ij,l +c + real new_m,zdq,zz + real zsigh(ip1jmp1,llm),zsigb(ip1jmp1,llm),zsig + real w_mq(ip1jmp1,llm+1) + real zm,zq,zsigm,zsigp,zqm,zqp + real prec + save prec + +#ifdef CRAY + data prec/1.e-24/ +#else + data prec/1.e-13/ +#endif + + do l=1,llm + do ij=1,ip1jmp1 + zdq=qb(ij,l)-qh(ij,l) +c if((qh(ij,l)-q(ij,l))*(q(ij,l)-qb(ij,l)).lt.0.) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,qh(ij,l),q(ij,l),qb(ij,l) +c qh(ij,l)=q(ij,l) +c qb(ij,l)=q(ij,l) +c endif + + if(abs(zdq).gt.prec) then + zsigb(ij,l)=(q(ij,l)-qh(ij,l))/zdq + zsigh(ij,l)=1.-zsigb(ij,l) + zsigb(ij,l)=min(max(zsigb(ij,l),0.),1.) + else + zsigb(ij,l)=0.5 + zsigh(ij,l)=0.5 + endif + enddo + enddo + +c print*,'ok1' +c calcul de la pente maximum dans la maille en valeur absolue + do l=2,llm + do ij=1,ip1jmp1 + if (w_m(ij,l).ge.0.) then + zsigp=zsigb(ij,l) + zsigm=zsigh(ij,l) + zqp=qb(ij,l) + zqm=qh(ij,l) + zm=masse(ij,l) + zq=q(ij,l) + else + zsigm=zsigb(ij,l-1) + zsigp=zsigh(ij,l-1) + zqm=qb(ij,l-1) + zqp=qh(ij,l-1) + zm=masse(ij,l-1) + zq=q(ij,l-1) + endif + zsig=abs(w_m(ij,l))/zm + if(zsig.eq.0.) zsigp=0.1 + if (zsig.le.zsigp) then + w_mq(ij,l)=w_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) + else + zz=0.5*(zsig-zsigp)/zsigm + w_mq(ij,l)=sign(zm,w_m(ij,l))*( 0.5*(zq+zqp)*zsigp + s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) + endif + enddo + enddo + + do ij=1,ip1jmp1 + w_mq(ij,llm+1)=0. + w_mq(ij,1)=0. + enddo + + do l=1,llm + do ij=1,ip1jmp1 + new_m=masse(ij,l)+w_m(ij,l+1)-w_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+w_mq(ij,l+1)-w_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + enddo + enddo +c print*,'ok3' + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advtrac_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advtrac_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advtrac_p.F (revision 1280) @@ -0,0 +1,502 @@ +! +! $Header$ +! +c +c + SUBROUTINE advtrac_p(pbaru,pbarv , + * p, masse,q,iapptrac,teta, + * flxw, + * pk ) + +c Auteur : F. Hourdin +c +c Modif. P. Le Van (20/12/97) +c F. Codron (10/99) +c D. Le Croller (07/2001) +c M.A Filiberti (04/2002) +c + USE parallel + USE Write_Field_p + USE Bands + USE mod_hallo + USE Vampir + USE times + USE infotrac + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comdissip.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "control.h" +#include "ener.h" +#include "description.h" + +c------------------------------------------------------------------- +c Arguments +c------------------------------------------------------------------- +c Ajout PPM +c-------------------------------------------------------- + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm) +c-------------------------------------------------------- + INTEGER iapptrac + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL q(ip1jmp1,llm,nqtot),masse(ip1jmp1,llm) + REAL p( ip1jmp1,llmp1 ),teta(ip1jmp1,llm) + REAL pk(ip1jmp1,llm) + REAL :: flxw(ip1jmp1,llm) + +c------------------------------------------------------------- +c Variables locales +c------------------------------------------------------------- + + REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm) + REAL massem(ip1jmp1,llm),zdp(ip1jmp1) + REAL,SAVE::pbarug(ip1jmp1,llm),pbarvg(ip1jm,llm),wg(ip1jmp1,llm) + REAL (kind=kind(1.d0)) :: t_initial, t_final, tps_cpu + INTEGER iadvtr + INTEGER ij,l,iq,iiq + REAL zdpmin, zdpmax + SAVE iadvtr, massem, pbaruc, pbarvc + DATA iadvtr/0/ +c$OMP THREADPRIVATE(iadvtr) +c---------------------------------------------------------- +c Rajouts pour PPM +c---------------------------------------------------------- + INTEGER indice,n + REAL dtbon ! Pas de temps adaptatif pour que CFL<1 + REAL CFLmaxz,aaa,bbb ! CFL maximum + REAL psppm(iim,jjp1) ! pression au sol + REAL unatppm(iim,jjp1,llm),vnatppm(iim,jjp1,llm) + REAL qppm(iim*jjp1,llm,nqtot) + REAL fluxwppm(iim,jjp1,llm) + REAL apppm(llmp1), bpppm(llmp1) + LOGICAL dum,fill + DATA fill/.true./ + DATA dum/.true./ + REAL,SAVE :: finmasse(ip1jmp1,llm) + integer ijb,ije,ijb_u,ijb_v,ije_u,ije_v,j + type(Request) :: Request_vanleer + REAL,SAVE :: p_tmp( ip1jmp1,llmp1 ) + REAL,SAVE :: teta_tmp(ip1jmp1,llm) + REAL,SAVE :: pk_tmp(ip1jmp1,llm) + + ijb_u=ij_begin + ije_u=ij_end + + ijb_v=ij_begin-iip1 + ije_v=ij_end + if (pole_nord) ijb_v=ij_begin + if (pole_sud) ije_v=ij_end-iip1 + + IF(iadvtr.EQ.0) THEN +c CALL initial0(ijp1llm,pbaruc) +c CALL initial0(ijmllm,pbarvc) +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + pbaruc(ijb_u:ije_u,l)=0. + pbarvc(ijb_v:ije_v,l)=0. + ENDDO +c$OMP END DO NOWAIT + ENDIF + +c accumulation des flux de masse horizontaux +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij = ijb_u,ije_u + pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l) + ENDDO + DO ij = ijb_v,ije_v + pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c selection de la masse instantannee des mailles avant le transport. + IF(iadvtr.EQ.0) THEN + +c CALL SCOPY(ip1jmp1*llm,masse,1,massem,1) + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + massem(ijb:ije,l)=masse(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +ccc CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 ) +c + ENDIF + + iadvtr = iadvtr+1 + +c$OMP MASTER + iapptrac = iadvtr +c$OMP END MASTER + +c Test pour savoir si on advecte a ce pas de temps + + IF ( iadvtr.EQ.iapp_tracvl ) THEN +c$OMP MASTER + call suspend_timer(timer_caldyn) +c$OMP END MASTER + + ijb=ij_begin + ije=ij_end + + +cc .. Modif P.Le Van ( 20/12/97 ) .... +cc + +c traitement des flux de masse avant advection. +c 1. calcul de w +c 2. groupement des mailles pres du pole. + + CALL groupe_p( massem, pbaruc,pbarvc, pbarug,pbarvg,wg ) + +c$OMP BARRIER + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llmp1 + p_tmp(ijb:ije,l)=p(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + pk_tmp(ijb:ije,l)=pk(ijb:ije,l) + teta_tmp(ijb:ije,l)=teta(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + + call Register_SwapFieldHallo(pbarug,pbarug,ip1jmp1,llm, + * jj_Nb_vanleer,0,0,Request_vanleer) + call Register_SwapFieldHallo(pbarvg,pbarvg,ip1jm,llm, + * jj_Nb_vanleer,1,0,Request_vanleer) + call Register_SwapFieldHallo(massem,massem,ip1jmp1,llm, + * jj_Nb_vanleer,0,0,Request_vanleer) + call Register_SwapFieldHallo(wg,wg,ip1jmp1,llm, + * jj_Nb_vanleer,0,0,Request_vanleer) + call Register_SwapFieldHallo(teta_tmp,teta_tmp,ip1jmp1,llm, + * jj_Nb_vanleer,1,1,Request_vanleer) + call Register_SwapFieldHallo(p_tmp,p_tmp,ip1jmp1,llmp1, + * jj_Nb_vanleer,1,1,Request_vanleer) + call Register_SwapFieldHallo(pk_tmp,pk_tmp,ip1jmp1,llm, + * jj_Nb_vanleer,1,1,Request_vanleer) + do j=1,nqtot + call Register_SwapFieldHallo(q(1,1,j),q(1,1,j),ip1jmp1,llm, + * jj_nb_vanleer,0,0,Request_vanleer) + enddo + + call SendRequest(Request_vanleer) +c$OMP BARRIER + call WaitRequest(Request_vanleer) + + +c$OMP BARRIER +c$OMP MASTER + call SetDistrib(jj_nb_vanleer) + call VTe(VTHallo) + call VTb(VTadvection) + call start_timer(timer_vanleer) +c$OMP END MASTER +c$OMP BARRIER + + ! ... Flux de masse diaganostiques traceurs + ijb=ij_begin + ije=ij_end + flxw(ijb:ije,1:llm)=wg(ijb:ije,1:llm)/FLOAT(iapp_tracvl) + +c test sur l'eventuelle creation de valeurs negatives de la masse + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm-1 + DO ij = ijb+1,ije + zdp(ij) = pbarug(ij-1,l) - pbarug(ij,l) + s - pbarvg(ij-iip1,l) + pbarvg(ij,l) + s + wg(ij,l+1) - wg(ij,l) + ENDDO + +c CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 ) +c ym ---> pourquoi jjm-1 et non jjm ? a cause du pole ? + + do ij=ijb,ije-iip1+1,iip1 + zdp(ij)=zdp(ij+iip1-1) + enddo + + DO ij = ijb,ije + zdp(ij)= zdp(ij)*dtvr/ massem(ij,l) + ENDDO + + +c CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax ) +c ym ---> eventuellement a revoir + CALL minmax ( ije-ijb+1, zdp(ijb), zdpmin,zdpmax ) + + IF(MAX(ABS(zdpmin),ABS(zdpmax)).GT.0.5) THEN + PRINT*,'WARNING DP/P l=',l,' MIN:',zdpmin, + s ' MAX:', zdpmax + ENDIF + + ENDDO +c$OMP END DO NOWAIT + +c------------------------------------------------------------------- +c Advection proprement dite (Modification Le Croller (07/2001) +c------------------------------------------------------------------- + +c---------------------------------------------------- +c Calcul des moyennes basées sur la masse +c---------------------------------------------------- + +cym ----> Normalement, inutile pour les schémas classiques +cym ----> Revérifier lors de la parallélisation des autres schemas + +cym call massbar_p(massem,massebx,masseby) + + call vlspltgen_p( q,iadv, 2., massem, wg , + * pbarug,pbarvg,dtvr,p_tmp,pk_tmp,teta_tmp ) + + + GOTO 1234 +c----------------------------------------------------------- +c Appel des sous programmes d'advection +c----------------------------------------------------------- + do iq=1,nqtot +c call clock(t_initial) + if(iadv(iq) == 0) cycle +c ---------------------------------------------------------------- +c Schema de Van Leer I MUSCL +c ---------------------------------------------------------------- + if(iadv(iq).eq.10) THEN + + call vlsplt_p(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr) + +c ---------------------------------------------------------------- +c Schema "pseudo amont" + test sur humidite specifique +C pour la vapeur d'eau. F. Codron +c ---------------------------------------------------------------- + else if(iadv(iq).eq.14) then +c +cym stop 'advtrac : appel à vlspltqs :schema non parallelise' + CALL vlspltqs_p( q(1,1,1), 2., massem, wg , + * pbarug,pbarvg,dtvr,p_tmp,pk_tmp,teta_tmp ) +c ---------------------------------------------------------------- +c Schema de Frederic Hourdin +c ---------------------------------------------------------------- + else if(iadv(iq).eq.12) then + stop 'advtrac : schema non parallelise' +c Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', + s dtvr,'n=',n + endif + do indice=1,n + call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1) + end do + else if(iadv(iq).eq.13) then + stop 'advtrac : schema non parallelise' +c Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', + s dtvr,'n=',n + endif + do indice=1,n + call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2) + end do +c ---------------------------------------------------------------- +c Schema de pente SLOPES +c ---------------------------------------------------------------- + else if (iadv(iq).eq.20) then + stop 'advtrac : schema non parallelise' + + call pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0) + +c ---------------------------------------------------------------- +c Schema de Prather +c ---------------------------------------------------------------- + else if (iadv(iq).eq.30) then + stop 'advtrac : schema non parallelise' +c Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', + s dtvr,'n=',n + endif + call prather(q(1,1,iq),wg,massem,pbarug,pbarvg, + s n,dtbon) +c ---------------------------------------------------------------- +c Schemas PPM Lin et Rood +c ---------------------------------------------------------------- + else if (iadv(iq).eq.11.OR.(iadv(iq).GE.16.AND. + s iadv(iq).LE.18)) then + + stop 'advtrac : schema non parallelise' + +c Test sur le flux horizontal +c Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', + s dtvr,'n=',n + endif +c Test sur le flux vertical + CFLmaxz=0. + do l=2,llm + do ij=iip2,ip1jm + aaa=wg(ij,l)*dtvr/massem(ij,l) + CFLmaxz=max(CFLmaxz,aaa) + bbb=-wg(ij,l)*dtvr/massem(ij,l-1) + CFLmaxz=max(CFLmaxz,bbb) + enddo + enddo + if (CFLmaxz.GE.1) then + write(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz + endif + +c----------------------------------------------------------- +c Ss-prg interface LMDZ.4->PPM3d +c----------------------------------------------------------- + + call interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem, + s apppm,bpppm,massebx,masseby,pbarug,pbarvg, + s unatppm,vnatppm,psppm) + + do indice=1,n +c--------------------------------------------------------------------- +c VL (version PPM) horiz. et PPM vert. +c--------------------------------------------------------------------- + if (iadv(iq).eq.11) then +c Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), + s psppm,psppm, + s unatppm,vnatppm,fluxwppm,dtbon,2,2,2,1, + s iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, + s fill,dum,220.) + +c---------------------------------------------------------------------- +c Monotonic PPM +c---------------------------------------------------------------------- + else if (iadv(iq).eq.16) then +c Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), + s psppm,psppm, + s unatppm,vnatppm,fluxwppm,dtbon,3,3,3,1, + s iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, + s fill,dum,220.) +c--------------------------------------------------------------------- + +c--------------------------------------------------------------------- +c Semi Monotonic PPM +c--------------------------------------------------------------------- + else if (iadv(iq).eq.17) then +c Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), + s psppm,psppm, + s unatppm,vnatppm,fluxwppm,dtbon,4,4,4,1, + s iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, + s fill,dum,220.) +c--------------------------------------------------------------------- + +c--------------------------------------------------------------------- +c Positive Definite PPM +c--------------------------------------------------------------------- + else if (iadv(iq).eq.18) then +c Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), + s psppm,psppm, + s unatppm,vnatppm,fluxwppm,dtbon,5,5,5,1, + s iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, + s fill,dum,220.) +c--------------------------------------------------------------------- + endif + enddo +c----------------------------------------------------------------- +c Ss-prg interface PPM3d-LMDZ.4 +c----------------------------------------------------------------- + call interpost(q(1,1,iq),qppm(1,1,iq)) + endif +c---------------------------------------------------------------------- + +c----------------------------------------------------------------- +c On impose une seule valeur du traceur au pôle Sud j=jjm+1=jjp1 +c et Nord j=1 +c----------------------------------------------------------------- + +c call traceurpole(q(1,1,iq),massem) + +c calcul du temps cpu pour un schema donne + +c call clock(t_final) +cym tps_cpu=t_final-t_initial +cym cpuadv(iq)=cpuadv(iq)+tps_cpu + + end DO + +1234 CONTINUE +c$OMP BARRIER + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije + finmasse(ij,l) = p(ij,l) - p(ij,l+1) + ENDDO + ENDDO +c$OMP END DO + + CALL qminimum_p( q, 2, finmasse ) + +c------------------------------------------------------------------ +c on reinitialise a zero les flux de masse cumules +c--------------------------------------------------- +c iadvtr=0 + +c$OMP MASTER + call VTe(VTadvection) + call stop_timer(timer_vanleer) + call VTb(VThallo) +c$OMP END MASTER + + do j=1,nqtot + call Register_SwapFieldHallo(q(1,1,j),q(1,1,j),ip1jmp1,llm, + * jj_nb_caldyn,0,0,Request_vanleer) + enddo + + call Register_SwapFieldHallo(flxw,flxw,ip1jmp1,llm, + * jj_nb_caldyn,0,0,Request_vanleer) + + call SendRequest(Request_vanleer) +c$OMP BARRIER + call WaitRequest(Request_vanleer) + +c$OMP BARRIER +c$OMP MASTER + call SetDistrib(jj_nb_caldyn) + call VTe(VThallo) + call resume_timer(timer_caldyn) +c$OMP END MASTER +c$OMP BARRIER + iadvtr=0 + ENDIF ! if iadvtr.EQ.iapp_tracvl + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advx.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advx.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advx.F (revision 1280) @@ -0,0 +1,497 @@ +! +! $Header$ +! + SUBROUTINE advx(limit,dtx,pbaru,sm,s0, + $ sx,sy,sz,lati,latf) + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C first-order moments (FOM) advection of tracer in X direction C +C C +C Source : Pascal Simon (Meteo,CNRM) C +C Adaptation : A.Armengaud (LGGE) juin 94 C +C C +C limit,dtx,pbaru,pbarv,sm,s0,sx,sy,sz C +C sont des arguments d'entree pour le s-pg... C +C C +C sm,s0,sx,sy,sz C +C sont les arguments de sortie pour le s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" + +C Arguments : +C ----------- +C dtx : frequence fictive d'appel du transport +C pbaru, pbarv : flux de masse en x et y en Pa.m2.s-1 + + INTEGER ntra + PARAMETER (ntra = 1) + +C ATTENTION partout ou on trouve ntra, insertion de boucle +C possible dans l'avenir. + + REAL dtx + REAL pbaru ( iip1,jjp1,llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm),S0(iip1,jjp1,llm,ntra) + REAL sx(iip1,jjp1,llm,ntra) + $ ,sy(iip1,jjp1,llm,ntra) + REAL sz(iip1,jjp1,llm,ntra) + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL UGRI(iip1,jjp1,llm) + +C Rem : VGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en x uniquement ) +C +C Ti are the moments for the current latitude and level +C + REAL TM(iim) + REAL T0(iim,ntra),TX(iim,ntra) + REAL TY(iim,ntra),TZ(iim,ntra) + REAL TEMPTM ! just a temporary variable +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C + REAL FM(iim) + REAL F0(iim,ntra),FX(iim,ntra) + REAL FY(iim,ntra),FZ(iim,ntra) +C +C work arrays +C + REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim) +C + REAL SMNEW(iim),UEXT(iim) +C + REAL sqi,sqf + + LOGICAL LIMIT + INTEGER NUM(jjp1),LONK,NUMK + INTEGER lon,lati,latf,niv + INTEGER i,i2,i3,j,jv,l,k,itrac + + lon = iim + niv = llm + +C *** Test de passage d'arguments ****** + + +C ------------------------------------- + DO 300 j = 1,jjp1 + NUM(j) = 1 + 300 CONTINUE + sqi = 0. + sqf = 0. + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqi = sqi + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVX - ENTREE ---------' + PRINT*,'sqi=',sqi + + +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C --------------------------------------------------------- +C Conversion des flux de masses en kg/s +C pbaru est en N/s d'ou : +C ugri est en kg/s + + DO 500 l = 1,llm + DO 500 j = 1,jjm+1 + DO 500 i = 1,iip1 +C ugri (i,j,llm+1-l) = pbaru (i,j,l) * ( dsig(l) / g ) + ugri (i,j,llm+1-l) = pbaru (i,j,l) + 500 CONTINUE + + +C --------------------------------------------------------- +C --------------------------------------------------------- +C --------------------------------------------------------- + +C start here +C +C boucle principale sur les niveaux et les latitudes +C + DO 1 L=1,NIV + DO 1 K=lati,latf +C +C initialisation +C +C program assumes periodic boundaries in X +C + DO 10 I=2,LON + SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX + 10 CONTINUE + SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX +C +C modifications for extended polar zones +C + NUMK=NUM(K) + LONK=LON/NUMK +C + IF(NUMK.GT.1) THEN +C + DO 111 I=1,LON + TM(I)=0. + 111 CONTINUE + DO 112 JV=1,NTRA + DO 1120 I=1,LON + T0(I,JV)=0. + TX(I,JV)=0. + TY(I,JV)=0. + TZ(I,JV)=0. + 1120 CONTINUE + 112 CONTINUE +C + DO 11 I2=1,NUMK +C + DO 113 I=1,LONK + I3=(I-1)*NUMK+I2 + TM(I)=TM(I)+SM(I3,K,L) + ALF(I)=SM(I3,K,L)/TM(I) + ALF1(I)=1.-ALF(I) + 113 CONTINUE +C + DO JV=1,NTRA + DO I=1,LONK + I3=(I-1)*NUMK+I2 + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I) + $ *S0(I3,K,L,JV) + T0(I,JV)=T0(I,JV)+S0(I3,K,L,JV) + TX(I,JV)=ALF(I) *sx(I3,K,L,JV)+ + $ ALF1(I)*TX(I,JV) +3.*TEMPTM + TY(I,JV)=TY(I,JV)+sy(I3,K,L,JV) + TZ(I,JV)=TZ(I,JV)+sz(I3,K,L,JV) + ENDDO + ENDDO +C + 11 CONTINUE +C + ELSE +C + DO 115 I=1,LON + TM(I)=SM(I,K,L) + 115 CONTINUE + DO 116 JV=1,NTRA + DO 1160 I=1,LON + T0(I,JV)=S0(I,K,L,JV) + TX(I,JV)=sx(I,K,L,JV) + TY(I,JV)=sy(I,K,L,JV) + TZ(I,JV)=sz(I,K,L,JV) + 1160 CONTINUE + 116 CONTINUE +C + ENDIF +C + DO 117 I=1,LONK + UEXT(I)=UGRI(I*NUMK,K,L) + 117 CONTINUE +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 13 +C + DO 12 JV=1,NTRA + DO 120 I=1,LONK + TX(I,JV)=SIGN(AMIN1(AMAX1(T0(I,JV),0.),ABS(TX(I,JV))),TX(I,JV)) + 120 CONTINUE + 12 CONTINUE +C + 13 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from IP to I if U(I).lt.0 +C + DO 140 I=1,LONK-1 + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(I+1) + TM(I+1)=TM(I+1)-FM(I) + ENDIF + 140 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(1) + TM(1)=TM(1)-FM(I) + ENDIF +C +C flux from I to IP if U(I).gt.0 +C + DO 141 I=1,LONK + IF(UEXT(I).GE.0.) THEN + FM(I)=UEXT(I)*DTX + ALF(I)=FM(I)/TM(I) + TM(I)=TM(I)-FM(I) + ENDIF + 141 CONTINUE +C + DO 142 I=1,LONK + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + 142 CONTINUE +C + DO 150 JV=1,NTRA + DO 1500 I=1,LONK-1 +C + IF(UEXT(I).LT.0.) THEN +C + F0(I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)*TX(I+1,JV) ) + FX(I,JV)=ALFQ(I)*TX(I+1,JV) + FY(I,JV)=ALF (I)*TY(I+1,JV) + FZ(I,JV)=ALF (I)*TZ(I+1,JV) +C + T0(I+1,JV)=T0(I+1,JV)-F0(I,JV) + TX(I+1,JV)=ALF1Q(I)*TX(I+1,JV) + TY(I+1,JV)=TY(I+1,JV)-FY(I,JV) + TZ(I+1,JV)=TZ(I+1,JV)-FZ(I,JV) +C + ENDIF +C + 1500 CONTINUE + 150 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN +C + DO 151 JV=1,NTRA +C + F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)*TX(1,JV) ) + FX (I,JV)=ALFQ(I)*TX(1,JV) + FY (I,JV)=ALF (I)*TY(1,JV) + FZ (I,JV)=ALF (I)*TZ(1,JV) +C + T0(1,JV)=T0(1,JV)-F0(I,JV) + TX(1,JV)=ALF1Q(I)*TX(1,JV) + TY(1,JV)=TY(1,JV)-FY(I,JV) + TZ(1,JV)=TZ(1,JV)-FZ(I,JV) +C + 151 CONTINUE +C + ENDIF +C + DO 152 JV=1,NTRA + DO 1520 I=1,LONK +C + IF(UEXT(I).GE.0.) THEN +C + F0(I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)*TX(I,JV) ) + FX(I,JV)=ALFQ(I)*TX(I,JV) + FY(I,JV)=ALF (I)*TY(I,JV) + FZ(I,JV)=ALF (I)*TZ(I,JV) +C + T0(I,JV)=T0(I,JV)-F0(I,JV) + TX(I,JV)=ALF1Q(I)*TX(I,JV) + TY(I,JV)=TY(I,JV)-FY(I,JV) + TZ(I,JV)=TZ(I,JV)-FZ(I,JV) +C + ENDIF +C + 1520 CONTINUE + 152 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 160 I=1,LONK + IF(UEXT(I).LT.0.) THEN + TM(I)=TM(I)+FM(I) + ALF(I)=FM(I)/TM(I) + ENDIF + 160 CONTINUE +C + DO 161 I=1,LONK-1 + IF(UEXT(I).GE.0.) THEN + TM(I+1)=TM(I+1)+FM(I) + ALF(I)=FM(I)/TM(I+1) + ENDIF + 161 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + TM(1)=TM(1)+FM(I) + ALF(I)=FM(I)/TM(1) + ENDIF +C + DO 162 I=1,LONK + ALF1(I)=1.-ALF(I) + 162 CONTINUE +C + DO 170 JV=1,NTRA + DO 1700 I=1,LONK +C + IF(UEXT(I).LT.0.) THEN +C + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV) + T0(I,JV)=T0(I,JV)+F0(I,JV) + TX(I,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM + TY(I,JV)=TY(I,JV)+FY(I,JV) + TZ(I,JV)=TZ(I,JV)+FZ(I,JV) +C + ENDIF +C + 1700 CONTINUE + 170 CONTINUE +C + DO 171 JV=1,NTRA + DO 1710 I=1,LONK-1 +C + IF(UEXT(I).GE.0.) THEN +C + TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV) + T0(I+1,JV)=T0(I+1,JV)+F0(I,JV) + TX(I+1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I+1,JV)+3.*TEMPTM + TY(I+1,JV)=TY(I+1,JV)+FY(I,JV) + TZ(I+1,JV)=TZ(I+1,JV)+FZ(I,JV) +C + ENDIF +C + 1710 CONTINUE + 171 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + DO 172 JV=1,NTRA + TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV) + T0(1,JV)=T0(1,JV)+F0(I,JV) + TX(1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM + TY(1,JV)=TY(1,JV)+FY(I,JV) + TZ(1,JV)=TZ(1,JV)+FZ(I,JV) + 172 CONTINUE + ENDIF +C +C retour aux mailles d'origine (passage des Tij aux Sij) +C + IF(NUMK.GT.1) THEN +C + DO 180 I2=1,NUMK +C + DO 180 I=1,LONK +C + I3=I2+(I-1)*NUMK + SM(I3,K,L)=SMNEW(I3) + ALF(I)=SMNEW(I3)/TM(I) + TM(I)=TM(I)-SMNEW(I3) +C + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) +C + 180 CONTINUE +C + DO JV=1,NTRA + DO I=1,LONK +C + I3=I2+(I-1)*NUMK + S0(I3,K,L,JV)=ALF (I) + $ * (T0(I,JV)-ALF1(I)*TX(I,JV)) + sx(I3,K,L,JV)=ALFQ(I)*TX(I,JV) + sy(I3,K,L,JV)=ALF (I)*TY(I,JV) + sz(I3,K,L,JV)=ALF (I)*TZ(I,JV) +C +C reajusts moments remaining in the box +C + T0(I,JV)=T0(I,JV)-S0(I3,K,L,JV) + TX(I,JV)=ALF1Q(I)*TX(I,JV) + TY(I,JV)=TY(I,JV)-sy(I3,K,L,JV) + TZ(I,JV)=TZ(I,JV)-sz(I3,K,L,JV) + ENDDO + ENDDO +C +C + ELSE +C + DO 190 I=1,LON + SM(I,K,L)=TM(I) + 190 CONTINUE + DO 191 JV=1,NTRA + DO 1910 I=1,LON + S0(I,K,L,JV)=T0(I,JV) + sx(I,K,L,JV)=TX(I,JV) + sy(I,K,L,JV)=TY(I,JV) + sz(I,K,L,JV)=TZ(I,JV) + 1910 CONTINUE + 191 CONTINUE +C + ENDIF +C + 1 CONTINUE +C +C ----------- AA Test en fin de ADVX ------ Controle des S* +c OK +c DO 9998 l = 1, llm +c DO 9998 j = 1, jjp1 +c DO 9998 i = 1, iip1 +c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN +c PRINT*, '-------------------' +c PRINT*, 'En fin de ADVX' +c PRINT*,'SM(',i,j,l,')=',SM(i,j,l) +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra) +c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra) +c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra) +c WRITE (*,*) 'On arrete !! - pbl en fin de ADVX1' +cc STOP +c ENDIF +c 9998 CONTINUE +c +C ---------- bouclage cyclique + DO itrac=1,ntra + DO l = 1,llm + DO j = lati,latf + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,itrac) = S0(1,j,l,itrac) + sx(iip1,j,l,itrac) = sx(1,j,l,itrac) + sy(iip1,j,l,itrac) = sy(1,j,l,itrac) + sz(iip1,j,l,itrac) = sz(1,j,l,itrac) + END DO + END DO + ENDDO + +c ----------- qqtite totale de traceur dans tte l'atmosphere + DO l = 1, llm + DO j = 1, jjp1 + DO i = 1, iim + sqf = sqf + S0(i,j,l,ntra) + END DO + END DO + END DO +c + PRINT*,'------ DIAG DANS ADVX - SORTIE -----' + PRINT*,'sqf=',sqf +c------------- + + RETURN + END +C_________________________________________________________________ +C_________________________________________________________________ Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advxp.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advxp.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advxp.F (revision 1280) @@ -0,0 +1,650 @@ +! +! $Header$ +! + SUBROUTINE ADVXP(LIMIT,DTX,PBARU,SM,S0,SSX,SY,SZ + . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra) + IMPLICIT NONE +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C second-order moments (SOM) advection of tracer in X direction C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" + + INTEGER ntra +c PARAMETER (ntra = 1) +C +C definition de la grille du modele +C + REAL dtx + REAL pbaru ( iip1,jjp1,llm ) +C +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C Sij 2nd order moment in i and j directions +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL SSX(iip1,jjp1,llm,ntra) + + ,SY(iip1,jjp1,llm,ntra) + + ,SZ(iip1,jjp1,llm,ntra) + REAL SSXX(iip1,jjp1,llm,ntra) + + ,SSXY(iip1,jjp1,llm,ntra) + + ,SSXZ(iip1,jjp1,llm,ntra) + + ,SYY(iip1,jjp1,llm,ntra) + + ,SYZ(iip1,jjp1,llm,ntra) + + ,SZZ(iip1,jjp1,llm,ntra) + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL UGRI(iip1,jjp1,llm) + +C Rem : VGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en x uniquement ) +C +C +C Tij are the moments for the current latitude and level +C + REAL TM (iim) + REAL T0 (iim,NTRA),TX (iim,NTRA) + REAL TY (iim,NTRA),TZ (iim,NTRA) + REAL TXX(iim,NTRA),TXY(iim,NTRA) + REAL TXZ(iim,NTRA),TYY(iim,NTRA) + REAL TYZ(iim,NTRA),TZZ(iim,NTRA) +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C + REAL FM (iim) + REAL F0 (iim,NTRA),FX (iim,NTRA) + REAL FY (iim,NTRA),FZ (iim,NTRA) + REAL FXX(iim,NTRA),FXY(iim,NTRA) + REAL FXZ(iim,NTRA),FYY(iim,NTRA) + REAL FYZ(iim,NTRA),FZZ(iim,NTRA) +C +C work arrays +C + REAL ALF (iim),ALF1(iim),ALFQ(iim),ALF1Q(iim) + REAL ALF2(iim),ALF3(iim),ALF4(iim) +C + REAL SMNEW(iim),UEXT(iim) + REAL sqi,sqf + REAL TEMPTM + REAL SLPMAX + REAL S1MAX,S1NEW,S2NEW + + LOGICAL LIMIT + INTEGER NUM(jjp1),LONK,NUMK + INTEGER lon,lati,latf,niv + INTEGER i,i2,i3,j,jv,l,k,iter + + lon = iim + lati=2 + latf = jjm + niv = llm + +C *** Test de passage d'arguments ****** + +c DO 399 l = 1, llm +c DO 399 j = 1, jjp1 +c DO 399 i = 1, iip1 +c IF (S0(i,j,l,ntra) .lt. 0. ) THEN +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra) +c print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra) +c print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra) +c PRINT*, 'AIE !! debut ADVXP - pbl arg. passage dans ADVXP' +cc STOP +c ENDIF +c 399 CONTINUE + +C *** Test : diagnostique de la qtite totale de traceur +C dans l'atmosphere avant l'advection +c + sqi =0. + sqf =0. +c + DO l = 1, llm + DO j = 1, jjp1 + DO i = 1, iim + sqi = sqi + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'------ DIAG DANS ADVX2 - ENTREE -----' + PRINT*,'sqi=',sqi +c test +c ------------------------------------- + DO 300 j =1,jjp1 + NUM(j) =1 + 300 CONTINUE +c DO l=1,llm +c NUM(2,l)=6 +c NUM(3,l)=6 +c NUM(jjm-1,l)=6 +c NUM(jjm,l)=6 +c ENDDO +c DO j=2,6 +c NUM(j)=12 +c ENDDO +c DO j=jjm-5,jjm-1 +c NUM(j)=12 +c ENDDO + +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C --------------------------------------------------------- +C Conversion des flux de masses en kg/s +C pbaru est en N/s d'ou : +C ugri est en kg/s + + DO 500 l = 1,llm + DO 500 j = 1,jjp1 + DO 500 i = 1,iip1 + ugri (i,j,llm+1-l) =pbaru (i,j,l) + 500 CONTINUE + +C --------------------------------------------------------- +C start here +C +C boucle principale sur les niveaux et les latitudes +C + DO 1 L=1,NIV + DO 1 K=lati,latf + +C +C initialisation +C +C program assumes periodic boundaries in X +C + DO 10 I=2,LON + SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX + 10 CONTINUE + SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX +C +C modifications for extended polar zones +C + NUMK=NUM(K) + LONK=LON/NUMK +C + IF(NUMK.GT.1) THEN +C + DO 111 I=1,LON + TM(I)=0. + 111 CONTINUE + DO 112 JV=1,NTRA + DO 1120 I=1,LON + T0 (I,JV)=0. + TX (I,JV)=0. + TY (I,JV)=0. + TZ (I,JV)=0. + TXX(I,JV)=0. + TXY(I,JV)=0. + TXZ(I,JV)=0. + TYY(I,JV)=0. + TYZ(I,JV)=0. + TZZ(I,JV)=0. + 1120 CONTINUE + 112 CONTINUE +C + DO 11 I2=1,NUMK +C + DO 113 I=1,LONK + I3=(I-1)*NUMK+I2 + TM(I)=TM(I)+SM(I3,K,L) + ALF(I)=SM(I3,K,L)/TM(I) + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALF1(I) + 113 CONTINUE +C + DO 114 JV=1,NTRA + DO 1140 I=1,LONK + I3=(I-1)*NUMK+I2 + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*S0(I3,K,L,JV) + T0 (I,JV)=T0(I,JV)+S0(I3,K,L,JV) + TXX(I,JV)=ALFQ(I)*SSXX(I3,K,L,JV)+ALF1Q(I)*TXX(I,JV) + + +5.*( ALF3(I)*(SSX(I3,K,L,JV)-TX(I,JV))+ALF2(I)*TEMPTM ) + TX (I,JV)=ALF(I)*SSX(I3,K,L,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM + TXY(I,JV)=ALF (I)*SSXY(I3,K,L,JV)+ALF1(I)*TXY(I,JV) + + +3.*(ALF1(I)*SY (I3,K,L,JV)-ALF (I)*TY (I,JV)) + TXZ(I,JV)=ALF (I)*SSXZ(I3,K,L,JV)+ALF1(I)*TXZ(I,JV) + + +3.*(ALF1(I)*SZ (I3,K,L,JV)-ALF (I)*TZ (I,JV)) + TY (I,JV)=TY (I,JV)+SY (I3,K,L,JV) + TZ (I,JV)=TZ (I,JV)+SZ (I3,K,L,JV) + TYY(I,JV)=TYY(I,JV)+SYY(I3,K,L,JV) + TYZ(I,JV)=TYZ(I,JV)+SYZ(I3,K,L,JV) + TZZ(I,JV)=TZZ(I,JV)+SZZ(I3,K,L,JV) + 1140 CONTINUE + 114 CONTINUE +C + 11 CONTINUE +C + ELSE +C + DO 115 I=1,LON + TM(I)=SM(I,K,L) + 115 CONTINUE + DO 116 JV=1,NTRA + DO 1160 I=1,LON + T0 (I,JV)=S0 (I,K,L,JV) + TX (I,JV)=SSX (I,K,L,JV) + TY (I,JV)=SY (I,K,L,JV) + TZ (I,JV)=SZ (I,K,L,JV) + TXX(I,JV)=SSXX(I,K,L,JV) + TXY(I,JV)=SSXY(I,K,L,JV) + TXZ(I,JV)=SSXZ(I,K,L,JV) + TYY(I,JV)=SYY(I,K,L,JV) + TYZ(I,JV)=SYZ(I,K,L,JV) + TZZ(I,JV)=SZZ(I,K,L,JV) + 1160 CONTINUE + 116 CONTINUE +C + ENDIF +C + DO 117 I=1,LONK + UEXT(I)=UGRI(I*NUMK,K,L) + 117 CONTINUE +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 13 +C + DO 12 JV=1,NTRA + DO 120 I=1,LONK + IF(T0(I,JV).GT.0.) THEN + SLPMAX=T0(I,JV) + S1MAX=1.5*SLPMAX + S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,TX(I,JV))) + S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , + + AMAX1(ABS(S1NEW)-SLPMAX,TXX(I,JV)) ) + TX (I,JV)=S1NEW + TXX(I,JV)=S2NEW + TXY(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXY(I,JV))) + TXZ(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXZ(I,JV))) + ELSE + TX (I,JV)=0. + TXX(I,JV)=0. + TXY(I,JV)=0. + TXZ(I,JV)=0. + ENDIF + 120 CONTINUE + 12 CONTINUE +C + 13 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from IP to I if U(I).lt.0 +C + DO 140 I=1,LONK-1 + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(I+1) + TM(I+1)=TM(I+1)-FM(I) + ENDIF + 140 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(1) + TM(1)=TM(1)-FM(I) + ENDIF +C +C flux from I to IP if U(I).gt.0 +C + DO 141 I=1,LONK + IF(UEXT(I).GE.0.) THEN + FM(I)=UEXT(I)*DTX + ALF(I)=FM(I)/TM(I) + TM(I)=TM(I)-FM(I) + ENDIF + 141 CONTINUE +C + DO 142 I=1,LONK + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALFQ(I) + ALF4(I)=ALF1(I)*ALF1Q(I) + 142 CONTINUE +C + DO 150 JV=1,NTRA + DO 1500 I=1,LONK-1 +C + IF(UEXT(I).LT.0.) THEN +C + F0 (I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)* + + ( TX(I+1,JV)-ALF2(I)*TXX(I+1,JV) ) ) + FX (I,JV)=ALFQ(I)*(TX(I+1,JV)-3.*ALF1(I)*TXX(I+1,JV)) + FXX(I,JV)=ALF3(I)*TXX(I+1,JV) + FY (I,JV)=ALF (I)*(TY(I+1,JV)-ALF1(I)*TXY(I+1,JV)) + FZ (I,JV)=ALF (I)*(TZ(I+1,JV)-ALF1(I)*TXZ(I+1,JV)) + FXY(I,JV)=ALFQ(I)*TXY(I+1,JV) + FXZ(I,JV)=ALFQ(I)*TXZ(I+1,JV) + FYY(I,JV)=ALF (I)*TYY(I+1,JV) + FYZ(I,JV)=ALF (I)*TYZ(I+1,JV) + FZZ(I,JV)=ALF (I)*TZZ(I+1,JV) +C + T0 (I+1,JV)=T0(I+1,JV)-F0(I,JV) + TX (I+1,JV)=ALF1Q(I)*(TX(I+1,JV)+3.*ALF(I)*TXX(I+1,JV)) + TXX(I+1,JV)=ALF4(I)*TXX(I+1,JV) + TY (I+1,JV)=TY (I+1,JV)-FY (I,JV) + TZ (I+1,JV)=TZ (I+1,JV)-FZ (I,JV) + TYY(I+1,JV)=TYY(I+1,JV)-FYY(I,JV) + TYZ(I+1,JV)=TYZ(I+1,JV)-FYZ(I,JV) + TZZ(I+1,JV)=TZZ(I+1,JV)-FZZ(I,JV) + TXY(I+1,JV)=ALF1Q(I)*TXY(I+1,JV) + TXZ(I+1,JV)=ALF1Q(I)*TXZ(I+1,JV) +C + ENDIF +C + 1500 CONTINUE + 150 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN +C + DO 151 JV=1,NTRA +C + F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)* + + ( TX(1,JV)-ALF2(I)*TXX(1,JV) ) ) + FX (I,JV)=ALFQ(I)*(TX(1,JV)-3.*ALF1(I)*TXX(1,JV)) + FXX(I,JV)=ALF3(I)*TXX(1,JV) + FY (I,JV)=ALF (I)*(TY(1,JV)-ALF1(I)*TXY(1,JV)) + FZ (I,JV)=ALF (I)*(TZ(1,JV)-ALF1(I)*TXZ(1,JV)) + FXY(I,JV)=ALFQ(I)*TXY(1,JV) + FXZ(I,JV)=ALFQ(I)*TXZ(1,JV) + FYY(I,JV)=ALF (I)*TYY(1,JV) + FYZ(I,JV)=ALF (I)*TYZ(1,JV) + FZZ(I,JV)=ALF (I)*TZZ(1,JV) +C + T0 (1,JV)=T0(1,JV)-F0(I,JV) + TX (1,JV)=ALF1Q(I)*(TX(1,JV)+3.*ALF(I)*TXX(1,JV)) + TXX(1,JV)=ALF4(I)*TXX(1,JV) + TY (1,JV)=TY (1,JV)-FY (I,JV) + TZ (1,JV)=TZ (1,JV)-FZ (I,JV) + TYY(1,JV)=TYY(1,JV)-FYY(I,JV) + TYZ(1,JV)=TYZ(1,JV)-FYZ(I,JV) + TZZ(1,JV)=TZZ(1,JV)-FZZ(I,JV) + TXY(1,JV)=ALF1Q(I)*TXY(1,JV) + TXZ(1,JV)=ALF1Q(I)*TXZ(1,JV) +C + 151 CONTINUE +C + ENDIF +C + DO 152 JV=1,NTRA + DO 1520 I=1,LONK +C + IF(UEXT(I).GE.0.) THEN +C + F0 (I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)* + + ( TX(I,JV)+ALF2(I)*TXX(I,JV) ) ) + FX (I,JV)=ALFQ(I)*(TX(I,JV)+3.*ALF1(I)*TXX(I,JV)) + FXX(I,JV)=ALF3(I)*TXX(I,JV) + FY (I,JV)=ALF (I)*(TY(I,JV)+ALF1(I)*TXY(I,JV)) + FZ (I,JV)=ALF (I)*(TZ(I,JV)+ALF1(I)*TXZ(I,JV)) + FXY(I,JV)=ALFQ(I)*TXY(I,JV) + FXZ(I,JV)=ALFQ(I)*TXZ(I,JV) + FYY(I,JV)=ALF (I)*TYY(I,JV) + FYZ(I,JV)=ALF (I)*TYZ(I,JV) + FZZ(I,JV)=ALF (I)*TZZ(I,JV) +C + T0 (I,JV)=T0(I,JV)-F0(I,JV) + TX (I,JV)=ALF1Q(I)*(TX(I,JV)-3.*ALF(I)*TXX(I,JV)) + TXX(I,JV)=ALF4(I)*TXX(I,JV) + TY (I,JV)=TY (I,JV)-FY (I,JV) + TZ (I,JV)=TZ (I,JV)-FZ (I,JV) + TYY(I,JV)=TYY(I,JV)-FYY(I,JV) + TYZ(I,JV)=TYZ(I,JV)-FYZ(I,JV) + TZZ(I,JV)=TZZ(I,JV)-FZZ(I,JV) + TXY(I,JV)=ALF1Q(I)*TXY(I,JV) + TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV) +C + ENDIF +C + 1520 CONTINUE + 152 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 160 I=1,LONK + IF(UEXT(I).LT.0.) THEN + TM(I)=TM(I)+FM(I) + ALF(I)=FM(I)/TM(I) + ENDIF + 160 CONTINUE +C + DO 161 I=1,LONK-1 + IF(UEXT(I).GE.0.) THEN + TM(I+1)=TM(I+1)+FM(I) + ALF(I)=FM(I)/TM(I+1) + ENDIF + 161 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + TM(1)=TM(1)+FM(I) + ALF(I)=FM(I)/TM(1) + ENDIF +C + DO 162 I=1,LONK + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALF1(I) + 162 CONTINUE +C + DO 170 JV=1,NTRA + DO 1700 I=1,LONK +C + IF(UEXT(I).LT.0.) THEN +C + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV) + T0 (I,JV)=T0(I,JV)+F0(I,JV) + TXX(I,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I,JV) + + +5.*( ALF3(I)*(FX(I,JV)-TX(I,JV))+ALF2(I)*TEMPTM ) + TX (I,JV)=ALF (I)*FX (I,JV)+ALF1(I)*TX (I,JV)+3.*TEMPTM + TXY(I,JV)=ALF (I)*FXY(I,JV)+ALF1(I)*TXY(I,JV) + + +3.*(ALF1(I)*FY (I,JV)-ALF (I)*TY (I,JV)) + TXZ(I,JV)=ALF (I)*FXZ(I,JV)+ALF1(I)*TXZ(I,JV) + + +3.*(ALF1(I)*FZ (I,JV)-ALF (I)*TZ (I,JV)) + TY (I,JV)=TY (I,JV)+FY (I,JV) + TZ (I,JV)=TZ (I,JV)+FZ (I,JV) + TYY(I,JV)=TYY(I,JV)+FYY(I,JV) + TYZ(I,JV)=TYZ(I,JV)+FYZ(I,JV) + TZZ(I,JV)=TZZ(I,JV)+FZZ(I,JV) +C + ENDIF +C + 1700 CONTINUE + 170 CONTINUE +C + DO 171 JV=1,NTRA + DO 1710 I=1,LONK-1 +C + IF(UEXT(I).GE.0.) THEN +C + TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV) + T0 (I+1,JV)=T0(I+1,JV)+F0(I,JV) + TXX(I+1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I+1,JV) + + +5.*( ALF3(I)*(TX(I+1,JV)-FX(I,JV))-ALF2(I)*TEMPTM ) + TX (I+1,JV)=ALF(I)*FX (I ,JV)+ALF1(I)*TX (I+1,JV)+3.*TEMPTM + TXY(I+1,JV)=ALF(I)*FXY(I ,JV)+ALF1(I)*TXY(I+1,JV) + + +3.*(ALF(I)*TY (I+1,JV)-ALF1(I)*FY (I ,JV)) + TXZ(I+1,JV)=ALF(I)*FXZ(I ,JV)+ALF1(I)*TXZ(I+1,JV) + + +3.*(ALF(I)*TZ (I+1,JV)-ALF1(I)*FZ (I ,JV)) + TY (I+1,JV)=TY (I+1,JV)+FY (I,JV) + TZ (I+1,JV)=TZ (I+1,JV)+FZ (I,JV) + TYY(I+1,JV)=TYY(I+1,JV)+FYY(I,JV) + TYZ(I+1,JV)=TYZ(I+1,JV)+FYZ(I,JV) + TZZ(I+1,JV)=TZZ(I+1,JV)+FZZ(I,JV) +C + ENDIF +C + 1710 CONTINUE + 171 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + DO 172 JV=1,NTRA + TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV) + T0 (1,JV)=T0(1,JV)+F0(I,JV) + TXX(1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(1,JV) + + +5.*( ALF3(I)*(TX(1,JV)-FX(I,JV))-ALF2(I)*TEMPTM ) + TX (1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM + TXY(1,JV)=ALF(I)*FXY(I,JV)+ALF1(I)*TXY(1,JV) + + +3.*(ALF(I)*TY (1,JV)-ALF1(I)*FY (I,JV)) + TXZ(1,JV)=ALF(I)*FXZ(I,JV)+ALF1(I)*TXZ(1,JV) + + +3.*(ALF(I)*TZ (1,JV)-ALF1(I)*FZ (I,JV)) + TY (1,JV)=TY (1,JV)+FY (I,JV) + TZ (1,JV)=TZ (1,JV)+FZ (I,JV) + TYY(1,JV)=TYY(1,JV)+FYY(I,JV) + TYZ(1,JV)=TYZ(1,JV)+FYZ(I,JV) + TZZ(1,JV)=TZZ(1,JV)+FZZ(I,JV) + 172 CONTINUE + ENDIF +C +C retour aux mailles d'origine (passage des Tij aux Sij) +C + IF(NUMK.GT.1) THEN +C + DO 18 I2=1,NUMK +C + DO 180 I=1,LONK +C + I3=I2+(I-1)*NUMK + SM(I3,K,L)=SMNEW(I3) + ALF(I)=SMNEW(I3)/TM(I) + TM(I)=TM(I)-SMNEW(I3) +C + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALFQ(I) + ALF4(I)=ALF1(I)*ALF1Q(I) +C + 180 CONTINUE +C + DO 181 JV=1,NTRA + DO 181 I=1,LONK +C + I3=I2+(I-1)*NUMK + S0 (I3,K,L,JV)=ALF (I)* ( T0(I,JV)-ALF1(I)* + + ( TX(I,JV)-ALF2(I)*TXX(I,JV) ) ) + SSX (I3,K,L,JV)=ALFQ(I)*(TX(I,JV)-3.*ALF1(I)*TXX(I,JV)) + SSXX(I3,K,L,JV)=ALF3(I)*TXX(I,JV) + SY (I3,K,L,JV)=ALF (I)*(TY(I,JV)-ALF1(I)*TXY(I,JV)) + SZ (I3,K,L,JV)=ALF (I)*(TZ(I,JV)-ALF1(I)*TXZ(I,JV)) + SSXY(I3,K,L,JV)=ALFQ(I)*TXY(I,JV) + SSXZ(I3,K,L,JV)=ALFQ(I)*TXZ(I,JV) + SYY(I3,K,L,JV)=ALF (I)*TYY(I,JV) + SYZ(I3,K,L,JV)=ALF (I)*TYZ(I,JV) + SZZ(I3,K,L,JV)=ALF (I)*TZZ(I,JV) +C +C reajusts moments remaining in the box +C + T0 (I,JV)=T0(I,JV)-S0(I3,K,L,JV) + TX (I,JV)=ALF1Q(I)*(TX(I,JV)+3.*ALF(I)*TXX(I,JV)) + TXX(I,JV)=ALF4 (I)*TXX(I,JV) + TY (I,JV)=TY (I,JV)-SY (I3,K,L,JV) + TZ (I,JV)=TZ (I,JV)-SZ (I3,K,L,JV) + TYY(I,JV)=TYY(I,JV)-SYY(I3,K,L,JV) + TYZ(I,JV)=TYZ(I,JV)-SYZ(I3,K,L,JV) + TZZ(I,JV)=TZZ(I,JV)-SZZ(I3,K,L,JV) + TXY(I,JV)=ALF1Q(I)*TXY(I,JV) + TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV) +C + 181 CONTINUE +C + 18 CONTINUE +C + ELSE +C + DO 190 I=1,LON + SM(I,K,L)=TM(I) + 190 CONTINUE + DO 191 JV=1,NTRA + DO 1910 I=1,LON + S0 (I,K,L,JV)=T0 (I,JV) + SSX (I,K,L,JV)=TX (I,JV) + SY (I,K,L,JV)=TY (I,JV) + SZ (I,K,L,JV)=TZ (I,JV) + SSXX(I,K,L,JV)=TXX(I,JV) + SSXY(I,K,L,JV)=TXY(I,JV) + SSXZ(I,K,L,JV)=TXZ(I,JV) + SYY(I,K,L,JV)=TYY(I,JV) + SYZ(I,K,L,JV)=TYZ(I,JV) + SZZ(I,K,L,JV)=TZZ(I,JV) + 1910 CONTINUE + 191 CONTINUE +C + ENDIF +C + 1 CONTINUE +C +C ----------- AA Test en fin de ADVX ------ Controle des S* + +c DO 9999 l = 1, llm +c DO 9999 j = 1, jjp1 +c DO 9999 i = 1, iip1 +c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN +c PRINT*, '-------------------' +c PRINT*, 'En fin de ADVXP' +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra) +c print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra) +c print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra) +c WRITE (*,*) 'On arrete !! - pbl en fin de ADVXP' +c STOP +c ENDIF +c 9999 CONTINUE +c ---------- bouclage cyclique + + DO l = 1,llm + DO j = 1,jjp1 + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,ntra) = S0(1,j,l,ntra) + SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra) + SY(iip1,j,l,ntra) = SY(1,j,l,ntra) + SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra) + END DO + END DO + +C ----------- qqtite totale de traceur dans tte l'atmosphere + DO l = 1, llm + DO j = 1, jjp1 + DO i = 1, iim + sqf = sqf + S0(i,j,l,ntra) + END DO + END DO + END DO + + PRINT*,'------ DIAG DANS ADVX2 - SORTIE -----' + PRINT*,'sqf=',sqf +c------------------------------------------------------------- + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advy.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advy.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advy.F (revision 1280) @@ -0,0 +1,422 @@ +! +! $Header$ +! + SUBROUTINE advy(limit,dty,pbarv,sm,s0,sx,sy,sz) + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C first-order moments (SOM) advection of tracer in Y direction C +C C +C Source : Pascal Simon ( Meteo, CNRM ) C +C Adaptation : A.A. (LGGE) C +C Derniere Modif : 15/12/94 LAST +C C +C sont les arguments d'entree pour le s-pg C +C C +C argument de sortie du s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Rem : Probleme aux poles il faut reecrire ce cas specifique +C Attention au sens de l'indexation +C +C parametres principaux du modele +C +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +C Arguments : +C ---------- +C dty : frequence fictive d'appel du transport +C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 + + INTEGER lon,lat,niv + INTEGER i,j,jv,k,kp,l + INTEGER ntra + PARAMETER (ntra = 1) + + REAL dty + REAL pbarv ( iip1,jjm, llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL sx(iip1,jjp1,llm,ntra) + + ,sy(iip1,jjp1,llm,ntra) + + ,sz(iip1,jjp1,llm,ntra) + + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL VGRI(iip1,0:jjp1,llm) + +C Rem : UGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en y uniquement ) +C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C + REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1) + REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra) + REAL FZ(iim,jjm,ntra) + REAL S00(ntra) + REAL SM0 ! Just temporal variable +C +C work arrays +C + REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1) + REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1) + REAL TEMPTM ! Just temporal variable +c +C Special pour poles +c + REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn + REAL sns0(ntra),snsz(ntra),snsm + REAL s1v(llm),slatv(llm) + REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra) + REAL cx1(llm,ntra), cxLAT(llm,ntra) + REAL cy1(llm,ntra), cyLAT(llm,ntra) + REAL z1(iim), zcos(iim), zsin(iim) + real smpn,smps,s0pn,s0ps + REAL SSUM + EXTERNAL SSUM +C + REAL sqi,sqf + LOGICAL LIMIT + + lon = iim ! rem : Il est possible qu'un pbl. arrive ici + lat = jjp1 ! a cause des dim. differentes entre les + niv=llm + +C +C the moments Fi are used as temporary storage for +C portions of the grid boxes in transit at the current level +C +C work arrays +C + + DO l = 1,llm + DO j = 1,jjm + DO i = 1,iip1 + vgri (i,j,llm+1-l)=-1.*pbarv(i,j,l) + enddo + enddo + do i=1,iip1 + vgri(i,0,l) = 0. + vgri(i,jjp1,l) = 0. + enddo + enddo + + DO 1 L=1,NIV +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 11 +C + DO 10 JV=1,NTRA + DO 10 K=1,LAT + DO 100 I=1,LON + sy(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.), + + ABS(sy(I,K,L,JV))),sy(I,K,L,JV)) + 100 CONTINUE + 10 CONTINUE +C + 11 CONTINUE +C +C le flux a travers le pole Nord est traite separement +C + SM0=0. + DO 20 JV=1,NTRA + S00(JV)=0. + 20 CONTINUE +C + DO 21 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN + FM(I,0)=-VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM(I,1,L) + SM(I,1,L)=SM(I,1,L)-FM(I,0) + SM0=SM0+FM(I,0) + ENDIF +C + ALFQ(I,0)=ALF(I,0)*ALF(I,0) + ALF1(I,0)=1.-ALF(I,0) + ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) +C + 21 CONTINUE +C + DO 22 JV=1,NTRA + DO 220 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN +C + F0(I,0,JV)=ALF(I,0)* + + ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) ) +C + S00(JV)=S00(JV)+F0(I,0,JV) + S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV) + sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV) + sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV) + sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV) +C + ENDIF +C + 220 CONTINUE + 22 CONTINUE +C + DO 23 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + FM(I,0)=VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM0 + ENDIF + 23 CONTINUE +C + DO 24 JV=1,NTRA + DO 240 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + F0(I,0,JV)=ALF(I,0)*S00(JV) + ENDIF + 240 CONTINUE + 24 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 25 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN + SM(I,1,L)=SM(I,1,L)+FM(I,0) + ALF(I,0)=FM(I,0)/SM(I,1,L) + ENDIF +C + ALF1(I,0)=1.-ALF(I,0) +C + 25 CONTINUE +C + DO 26 JV=1,NTRA + DO 260 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN +C + TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV) + S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV) + sy(I,1,L,JV)=ALF1(I,0)*sy(I,1,L,JV)+3.*TEMPTM +C + ENDIF +C + 260 CONTINUE + 26 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0 +C + DO 30 K=1,LAT-1 + KP=K+1 + DO 300 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,KP,L) + SM(I,KP,L)=SM(I,KP,L)-FM(I,K) + ELSE + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) +C + 300 CONTINUE + 30 CONTINUE +C + DO 31 JV=1,NTRA + DO 31 K=1,LAT-1 + KP=K+1 + DO 310 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + F0(I,K,JV)=ALF (I,K)* + + ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) ) + FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV) + FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV) + FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV) +C + S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV) + sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV) + sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV) + sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV) +C + ELSE +C + F0(I,K,JV)=ALF (I,K)* + + ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) ) + FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV) + FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV) + FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV) +C + S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV) + sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV) + sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV) + sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV) +C + ENDIF +C + 310 CONTINUE + 31 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 32 K=1,LAT-1 + KP=K+1 + DO 320 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ELSE + SM(I,KP,L)=SM(I,KP,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,KP,L) + ENDIF +C + ALF1(I,K)=1.-ALF(I,K) +C + 320 CONTINUE + 32 CONTINUE +C + DO 33 JV=1,NTRA + DO 33 K=1,LAT-1 + KP=K+1 + DO 330 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + sy(I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,K,L,JV) + + +3.*TEMPTM + sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,K,JV) + sz(I,K,L,JV)=sz(I,K,L,JV)+FZ(I,K,JV) +C + ELSE +C + TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV) + S0(I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV) + sy(I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,KP,L,JV) + + +3.*TEMPTM + sx(I,KP,L,JV)=sx(I,KP,L,JV)+FX(I,K,JV) + sz(I,KP,L,JV)=sz(I,KP,L,JV)+FZ(I,K,JV) +C + ENDIF +C + 330 CONTINUE + 33 CONTINUE +C +C traitement special pour le pole Sud (idem pole Nord) +C + K=LAT +C + SM0=0. + DO 40 JV=1,NTRA + S00(JV)=0. + 40 CONTINUE +C + DO 41 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + SM0=SM0+FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) +C + 41 CONTINUE +C + DO 42 JV=1,NTRA + DO 420 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + F0 (I,K,JV)=ALF(I,K)* + + ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) ) + S00(JV)=S00(JV)+F0(I,K,JV) +C + S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) + sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV) + sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV) + sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV) + ENDIF +C + 420 CONTINUE + 42 CONTINUE +C + DO 43 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM0 + ENDIF + 43 CONTINUE +C + DO 44 JV=1,NTRA + DO 440 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + F0(I,K,JV)=ALF(I,K)*S00(JV) + ENDIF + 440 CONTINUE + 44 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 45 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ENDIF +C + ALF1(I,K)=1.-ALF(I,K) +C + 45 CONTINUE +C + DO 46 JV=1,NTRA + DO 460 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + sy(I,K,L,JV)=ALF1(I,K)*sy(I,K,L,JV)+3.*TEMPTM +C + ENDIF +C + 460 CONTINUE + 46 CONTINUE +C + 1 CONTINUE +C + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advyp.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advyp.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advyp.F (revision 1280) @@ -0,0 +1,653 @@ +! +! $Header$ +! + SUBROUTINE ADVYP(LIMIT,DTY,PBARV,SM,S0,SSX,SY,SZ + . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra ) + IMPLICIT NONE +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C second-order moments (SOM) advection of tracer in Y direction C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Source : Pascal Simon ( Meteo, CNRM ) C +C Adaptation : A.A. (LGGE) C +C Derniere Modif : 19/10/95 LAST +C C +C sont les arguments d'entree pour le s-pg C +C C +C argument de sortie du s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Rem : Probleme aux poles il faut reecrire ce cas specifique +C Attention au sens de l'indexation +C +C parametres principaux du modele +C +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" + +C Arguments : +C ---------- +C dty : frequence fictive d'appel du transport +C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 + + INTEGER lon,lat,niv + INTEGER i,j,jv,k,kp,l + INTEGER ntra +C PARAMETER (ntra = 1) + + REAL dty + REAL pbarv ( iip1,jjm, llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL SSX(iip1,jjp1,llm,ntra) + + ,SY(iip1,jjp1,llm,ntra) + + ,SZ(iip1,jjp1,llm,ntra) + + ,SSXX(iip1,jjp1,llm,ntra) + + ,SSXY(iip1,jjp1,llm,ntra) + + ,SSXZ(iip1,jjp1,llm,ntra) + + ,SYY(iip1,jjp1,llm,ntra) + + ,SYZ(iip1,jjp1,llm,ntra) + + ,SZZ(iip1,jjp1,llm,ntra) +C +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL VGRI(iip1,0:jjp1,llm) + +C Rem : UGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en y uniquement ) +C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C +C the moments Fij are used as temporary storage for +C portions of the grid boxes in transit at the current level +C +C work arrays +C +C + REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1) + REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra) + REAL FZ(iim,jjm,ntra) + REAL FXX(iim,jjm,ntra),FXY(iim,jjm,ntra) + REAL FXZ(iim,jjm,ntra),FYY(iim,jjm,ntra) + REAL FYZ(iim,jjm,ntra),FZZ(iim,jjm,ntra) + REAL S00(ntra) + REAL SM0 ! Just temporal variable +C +C work arrays +C + REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1) + REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1) + REAL ALF2(iim,0:jjp1),ALF3(iim,0:jjp1) + REAL ALF4(iim,0:jjp1) + REAL TEMPTM ! Just temporal variable + REAL SLPMAX,S1MAX,S1NEW,S2NEW +c +C Special pour poles +c + REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn + REAL sns0(ntra),snsz(ntra),snsm + REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra) + REAL cx1(llm,ntra), cxLAT(llm,ntra) + REAL cy1(llm,ntra), cyLAT(llm,ntra) + REAL z1(iim), zcos(iim), zsin(iim) + REAL SSUM + EXTERNAL SSUM +C + REAL sqi,sqf + LOGICAL LIMIT + + lon = iim ! rem : Il est possible qu'un pbl. arrive ici + lat = jjp1 ! a cause des dim. differentes entre les + niv = llm ! tab. S et VGRI + +c----------------------------------------------------------------- +C initialisations + + sbms = 0. + sfms = 0. + sfzs = 0. + sbmn = 0. + sfmn = 0. + sfzn = 0. + +c----------------------------------------------------------------- +C *** Test : diag de la qtite totale de traceur dans +C l'atmosphere avant l'advection en Y +c + sqi = 0. + sqf = 0. + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqi = sqi + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'---------- DIAG DANS ADVY - ENTREE --------' + PRINT*,'sqi=',sqi + +c----------------------------------------------------------------- +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C Conversion des flux de masses en kg +C-AA 20/10/94 le signe -1 est necessaire car indexation opposee + + DO 500 l = 1,llm + DO 500 j = 1,jjm + DO 500 i = 1,iip1 + vgri (i,j,llm+1-l)=-1.*pbarv (i,j,l) + 500 CONTINUE + +CAA Initialisation de flux fictifs aux bords sup. des boites pol. + + DO l = 1,llm + DO i = 1,iip1 + vgri(i,0,l) = 0. + vgri(i,jjp1,l) = 0. + ENDDO + ENDDO +c +c----------------- START HERE ----------------------- +C boucle sur les niveaux +C + DO 1 L=1,NIV +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 11 +C + DO 10 JV=1,NTRA + DO 10 K=1,LAT + DO 100 I=1,LON + IF(S0(I,K,L,JV).GT.0.) THEN + SLPMAX=AMAX1(S0(I,K,L,JV),0.) + S1MAX=1.5*SLPMAX + S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,SY(I,K,L,JV))) + S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , + + AMAX1(ABS(S1NEW)-SLPMAX,SYY(I,K,L,JV)) ) + SY (I,K,L,JV)=S1NEW + SYY(I,K,L,JV)=S2NEW + SSXY(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXY(I,K,L,JV))) + SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV))) + ELSE + SY (I,K,L,JV)=0. + SYY(I,K,L,JV)=0. + SSXY(I,K,L,JV)=0. + SYZ(I,K,L,JV)=0. + ENDIF + 100 CONTINUE + 10 CONTINUE +C + 11 CONTINUE +C +C le flux a travers le pole Nord est traite separement +C + SM0=0. + DO 20 JV=1,NTRA + S00(JV)=0. + 20 CONTINUE +C + DO 21 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN + FM(I,0)=-VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM(I,1,L) + SM(I,1,L)=SM(I,1,L)-FM(I,0) + SM0=SM0+FM(I,0) + ENDIF +C + ALFQ(I,0)=ALF(I,0)*ALF(I,0) + ALF1(I,0)=1.-ALF(I,0) + ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) + ALF2(I,0)=ALF1(I,0)-ALF(I,0) + ALF3(I,0)=ALF(I,0)*ALFQ(I,0) + ALF4(I,0)=ALF1(I,0)*ALF1Q(I,0) +C + 21 CONTINUE +c print*,'ADVYP 21' +C + DO 22 JV=1,NTRA + DO 220 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN +C + F0(I,0,JV)=ALF(I,0)* ( S0(I,1,L,JV)-ALF1(I,0)* + + ( SY(I,1,L,JV)-ALF2(I,0)*SYY(I,1,L,JV) ) ) +C + S00(JV)=S00(JV)+F0(I,0,JV) + S0 (I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV) + SY (I,1,L,JV)=ALF1Q(I,0)* + + (SY(I,1,L,JV)+3.*ALF(I,0)*SYY(I,1,L,JV)) + SYY(I,1,L,JV)=ALF4 (I,0)*SYY(I,1,L,JV) + SSX (I,1,L,JV)=ALF1 (I,0)* + + (SSX(I,1,L,JV)+ALF(I,0)*SSXY(I,1,L,JV) ) + SZ (I,1,L,JV)=ALF1 (I,0)* + + (SZ(I,1,L,JV)+ALF(I,0)*SSXZ(I,1,L,JV) ) + SSXX(I,1,L,JV)=ALF1 (I,0)*SSXX(I,1,L,JV) + SSXZ(I,1,L,JV)=ALF1 (I,0)*SSXZ(I,1,L,JV) + SZZ(I,1,L,JV)=ALF1 (I,0)*SZZ(I,1,L,JV) + SSXY(I,1,L,JV)=ALF1Q(I,0)*SSXY(I,1,L,JV) + SYZ(I,1,L,JV)=ALF1Q(I,0)*SYZ(I,1,L,JV) +C + ENDIF +C + 220 CONTINUE + 22 CONTINUE +C + DO 23 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + FM(I,0)=VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM0 + ENDIF + 23 CONTINUE +C + DO 24 JV=1,NTRA + DO 240 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + F0(I,0,JV)=ALF(I,0)*S00(JV) + ENDIF + 240 CONTINUE + 24 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C +c print*,'av ADVYP 25' + DO 25 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN + SM(I,1,L)=SM(I,1,L)+FM(I,0) + ALF(I,0)=FM(I,0)/SM(I,1,L) + ENDIF +C + ALFQ(I,0)=ALF(I,0)*ALF(I,0) + ALF1(I,0)=1.-ALF(I,0) + ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) + ALF2(I,0)=ALF1(I,0)-ALF(I,0) + ALF3(I,0)=ALF1(I,0)*ALF(I,0) +C + 25 CONTINUE +c print*,'av ADVYP 25' +C + DO 26 JV=1,NTRA + DO 260 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN +C + TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV) + S0 (I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV) + SYY(I,1,L,JV)=ALF1Q(I,0)*SYY(I,1,L,JV) + + +5.*( ALF3 (I,0)*SY (I,1,L,JV)-ALF2(I,0)*TEMPTM ) + SY (I,1,L,JV)=ALF1 (I,0)*SY (I,1,L,JV)+3.*TEMPTM + SSXY(I,1,L,JV)=ALF1 (I,0)*SSXY(I,1,L,JV)+3.*ALF(I,0)*SSX(I,1,L,JV) + SYZ(I,1,L,JV)=ALF1 (I,0)*SYZ(I,1,L,JV)+3.*ALF(I,0)*SZ(I,1,L,JV) +C + ENDIF +C + 260 CONTINUE + 26 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0 +C +c print*,'av ADVYP 30' + DO 30 K=1,LAT-1 + KP=K+1 + DO 300 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,KP,L) + SM(I,KP,L)=SM(I,KP,L)-FM(I,K) + ELSE + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF(I,K)*ALFQ(I,K) + ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K) +C + 300 CONTINUE + 30 CONTINUE +c print*,'ap ADVYP 30' +C + DO 31 JV=1,NTRA + DO 31 K=1,LAT-1 + KP=K+1 + DO 310 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + F0 (I,K,JV)=ALF (I,K)* ( S0(I,KP,L,JV)-ALF1(I,K)* + + ( SY(I,KP,L,JV)-ALF2(I,K)*SYY(I,KP,L,JV) ) ) + FY (I,K,JV)=ALFQ(I,K)* + + (SY(I,KP,L,JV)-3.*ALF1(I,K)*SYY(I,KP,L,JV)) + FYY(I,K,JV)=ALF3(I,K)*SYY(I,KP,L,JV) + FX (I,K,JV)=ALF (I,K)* + + (SSX(I,KP,L,JV)-ALF1(I,K)*SSXY(I,KP,L,JV)) + FZ (I,K,JV)=ALF (I,K)* + + (SZ(I,KP,L,JV)-ALF1(I,K)*SYZ(I,KP,L,JV)) + FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,KP,L,JV) + FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,KP,L,JV) + FXX(I,K,JV)=ALF (I,K)*SSXX(I,KP,L,JV) + FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,KP,L,JV) + FZZ(I,K,JV)=ALF (I,K)*SZZ(I,KP,L,JV) +C + S0 (I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV) + SY (I,KP,L,JV)=ALF1Q(I,K)* + + (SY(I,KP,L,JV)+3.*ALF(I,K)*SYY(I,KP,L,JV)) + SYY(I,KP,L,JV)=ALF4(I,K)*SYY(I,KP,L,JV) + SSX (I,KP,L,JV)=SSX (I,KP,L,JV)-FX (I,K,JV) + SZ (I,KP,L,JV)=SZ (I,KP,L,JV)-FZ (I,K,JV) + SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)-FXX(I,K,JV) + SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)-FXZ(I,K,JV) + SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)-FZZ(I,K,JV) + SSXY(I,KP,L,JV)=ALF1Q(I,K)*SSXY(I,KP,L,JV) + SYZ(I,KP,L,JV)=ALF1Q(I,K)*SYZ(I,KP,L,JV) +C + ELSE +C + F0 (I,K,JV)=ALF (I,K)* ( S0(I,K,L,JV)+ALF1(I,K)* + + ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) ) + FY (I,K,JV)=ALFQ(I,K)* + + (SY(I,K,L,JV)+3.*ALF1(I,K)*SYY(I,K,L,JV)) + FYY(I,K,JV)=ALF3(I,K)*SYY(I,K,L,JV) + FX (I,K,JV)=ALF (I,K)*(SSX(I,K,L,JV)+ALF1(I,K)*SSXY(I,K,L,JV)) + FZ (I,K,JV)=ALF (I,K)*(SZ(I,K,L,JV)+ALF1(I,K)*SYZ(I,K,L,JV)) + FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,K,L,JV) + FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,K,L,JV) + FXX(I,K,JV)=ALF (I,K)*SSXX(I,K,L,JV) + FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,K,L,JV) + FZZ(I,K,JV)=ALF (I,K)*SZZ(I,K,L,JV) +C + S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) + SY (I,K,L,JV)=ALF1Q(I,K)* + + (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV)) + SYY(I,K,L,JV)=ALF4(I,K)*SYY(I,K,L,JV) + SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,K,JV) + SZ (I,K,L,JV)=SZ (I,K,L,JV)-FZ (I,K,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,K,JV) + SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)-FXZ(I,K,JV) + SZZ(I,K,L,JV)=SZZ(I,K,L,JV)-FZZ(I,K,JV) + SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV) +C + ENDIF +C + 310 CONTINUE + 31 CONTINUE +c print*,'ap ADVYP 31' +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 32 K=1,LAT-1 + KP=K+1 + DO 320 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ELSE + SM(I,KP,L)=SM(I,KP,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,KP,L) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF1(I,K)*ALF(I,K) +C + 320 CONTINUE + 32 CONTINUE +c print*,'ap ADVYP 32' +C + DO 33 JV=1,NTRA + DO 33 K=1,LAT-1 + KP=K+1 + DO 330 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + SYY(I,K,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,K,L,JV) + + +5.*( ALF3(I,K)*(FY(I,K,JV)-SY(I,K,L,JV))+ALF2(I,K)*TEMPTM ) + SY (I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,K,L,JV) + + +3.*TEMPTM + SSXY(I,K,L,JV)=ALF (I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,K,L,JV) + + +3.*(ALF1(I,K)*FX (I,K,JV)-ALF (I,K)*SSX (I,K,L,JV)) + SYZ(I,K,L,JV)=ALF (I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,K,L,JV) + + +3.*(ALF1(I,K)*FZ (I,K,JV)-ALF (I,K)*SZ (I,K,L,JV)) + SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,K,JV) + SZ (I,K,L,JV)=SZ (I,K,L,JV)+FZ (I,K,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,K,JV) + SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)+FXZ(I,K,JV) + SZZ(I,K,L,JV)=SZZ(I,K,L,JV)+FZZ(I,K,JV) +C + ELSE +C + TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV) + S0 (I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV) + SYY(I,KP,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,KP,L,JV) + + +5.*( ALF3(I,K)*(SY(I,KP,L,JV)-FY(I,K,JV))-ALF2(I,K)*TEMPTM ) + SY (I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,KP,L,JV) + + +3.*TEMPTM + SSXY(I,KP,L,JV)=ALF(I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,KP,L,JV) + + +3.*(ALF(I,K)*SSX(I,KP,L,JV)-ALF1(I,K)*FX(I,K,JV)) + SYZ(I,KP,L,JV)=ALF(I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,KP,L,JV) + + +3.*(ALF(I,K)*SZ(I,KP,L,JV)-ALF1(I,K)*FZ(I,K,JV)) + SSX (I,KP,L,JV)=SSX (I,KP,L,JV)+FX (I,K,JV) + SZ (I,KP,L,JV)=SZ (I,KP,L,JV)+FZ (I,K,JV) + SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)+FXX(I,K,JV) + SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)+FXZ(I,K,JV) + SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)+FZZ(I,K,JV) +C + ENDIF +C + 330 CONTINUE + 33 CONTINUE +c print*,'ap ADVYP 33' +C +C traitement special pour le pole Sud (idem pole Nord) +C + K=LAT +C + SM0=0. + DO 40 JV=1,NTRA + S00(JV)=0. + 40 CONTINUE +C + DO 41 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + SM0=SM0+FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF(I,K)*ALFQ(I,K) + ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K) +C + 41 CONTINUE +c print*,'ap ADVYP 41' +C + DO 42 JV=1,NTRA + DO 420 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + F0 (I,K,JV)=ALF(I,K)* ( S0(I,K,L,JV)+ALF1(I,K)* + + ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) ) + S00(JV)=S00(JV)+F0(I,K,JV) +C + S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) + SY (I,K,L,JV)=ALF1Q(I,K)* + + (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV)) + SYY(I,K,L,JV)=ALF4 (I,K)*SYY(I,K,L,JV) + SSX (I,K,L,JV)=ALF1(I,K)*(SSX(I,K,L,JV)-ALF(I,K)*SSXY(I,K,L,JV)) + SZ (I,K,L,JV)=ALF1(I,K)*(SZ(I,K,L,JV)-ALF(I,K)*SYZ(I,K,L,JV)) + SSXX(I,K,L,JV)=ALF1 (I,K)*SSXX(I,K,L,JV) + SSXZ(I,K,L,JV)=ALF1 (I,K)*SSXZ(I,K,L,JV) + SZZ(I,K,L,JV)=ALF1 (I,K)*SZZ(I,K,L,JV) + SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV) + ENDIF +C + 420 CONTINUE + 42 CONTINUE +c print*,'ap ADVYP 42' +C + DO 43 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM0 + ENDIF + 43 CONTINUE +c print*,'ap ADVYP 43' +C + DO 44 JV=1,NTRA + DO 440 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + F0(I,K,JV)=ALF(I,K)*S00(JV) + ENDIF + 440 CONTINUE + 44 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 45 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF1(I,K)*ALF(I,K) +C + 45 CONTINUE +c print*,'ap ADVYP 45' +C + DO 46 JV=1,NTRA + DO 460 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + SYY(I,K,L,JV)=ALF1Q(I,K)*SYY(I,K,L,JV) + + +5.*(-ALF3 (I,K)*SY (I,K,L,JV)+ALF2(I,K)*TEMPTM ) + SY (I,K,L,JV)=ALF1(I,K)*SY (I,K,L,JV)+3.*TEMPTM + SSXY(I,K,L,JV)=ALF1(I,K)*SSXY(I,K,L,JV)-3.*ALF(I,K)*SSX(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1(I,K)*SYZ(I,K,L,JV)-3.*ALF(I,K)*SZ(I,K,L,JV) +C + ENDIF +C + 460 CONTINUE + 46 CONTINUE +c print*,'ap ADVYP 46' +C + 1 CONTINUE + +c-------------------------------------------------- +C bouclage cyclique horizontal . + + DO l = 1,llm + DO jv = 1,ntra + DO j = 1,jjp1 + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,jv) = S0(1,j,l,jv) + SSX(iip1,j,l,jv) = SSX(1,j,l,jv) + SY(iip1,j,l,jv) = SY(1,j,l,jv) + SZ(iip1,j,l,jv) = SZ(1,j,l,jv) + END DO + END DO + END DO + +c ------------------------------------------------------------------- +C *** Test negativite: + +c DO jv = 1,ntra +c DO l = 1,llm +c DO j = 1,jjp1 +c DO i = 1,iip1 +c IF (s0( i,j,l,jv ).lt.0.) THEN +c PRINT*, '------ S0 < 0 en FIN ADVYP ---' +c PRINT*, 'S0(',i,j,l,jv,')=', S0(i,j,l,jv) +cc STOP +c ENDIF +c ENDDO +c ENDDO +c ENDDO +c ENDDO + + +c ------------------------------------------------------------------- +C *** Test : diag de la qtite totale de traceur dans +C l'atmosphere avant l'advection en Y + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqf = sqf + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'---------- DIAG DANS ADVY - SORTIE --------' + PRINT*,'sqf=',sqf +c print*,'ap ADVYP fin' + +c----------------------------------------------------------------- +C + RETURN + END + + + + + + + + + + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advz.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advz.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advz.F (revision 1280) @@ -0,0 +1,320 @@ +! +! $Header$ +! + SUBROUTINE advz(limit,dtz,w,sm,s0,sx,sy,sz) + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C first-order moments (FOM) advection of tracer in Z direction C +C C +C Source : Pascal Simon (Meteo,CNRM) C +C Adaptation : A.Armengaud (LGGE) juin 94 C +C C +C C +C sont des arguments d'entree pour le s-pg... C +C C +C dq est l'argument de sortie pour le s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" + +C #include "traceur.h" + +C Arguments : +C ----------- +C dtz : frequence fictive d'appel du transport +C w : flux de masse en z en Pa.m2.s-1 + + INTEGER ntra + PARAMETER (ntra = 1) + + REAL dtz + REAL w ( iip1,jjp1,llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL sx(iip1,jjp1,llm,ntra) + + ,sy(iip1,jjp1,llm,ntra) + + ,sz(iip1,jjp1,llm,ntra) + + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL WGRI(iip1,jjp1,0:llm) + +C +C the moments F are used as temporary storage for +C portions of grid boxes in transit at the current latitude +C + REAL FM(iim,llm) + REAL F0(iim,llm,ntra),FX(iim,llm,ntra) + REAL FY(iim,llm,ntra),FZ(iim,llm,ntra) +C +C work arrays +C + REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim) + REAL TEMPTM ! Just temporal variable + REAL sqi,sqf +C + LOGICAL LIMIT + INTEGER lon,lat,niv + INTEGER i,j,jv,k,l,lp + + lon = iim + lat = jjp1 + niv = llm + +C *** Test de passage d'arguments ****** + +c DO 399 l = 1, llm +c DO 399 j = 1, jjp1 +c DO 399 i = 1, iip1 +c IF (S0(i,j,l,ntra) .lt. 0. ) THEN +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra) +c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra) +c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra) +c PRINT*, 'AIE !! debut ADVZ - pbl arg. passage dans ADVZ' +c STOP +c ENDIF + 399 CONTINUE + +C----------------------------------------------------------------- +C *** Test : diag de la qqtite totale de traceur +C dans l'atmosphere avant l'advection en z + sqi = 0. + sqf = 0. + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqi = sqi + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVZ - ENTREE ---------' + PRINT*,'sqi=',sqi + +C----------------------------------------------------------------- +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C Conversion du flux de masse en kg.s-1 + + DO 500 l = 1,llm + DO 500 j = 1,jjp1 + DO 500 i = 1,iip1 +c wgri (i,j,llm+1-l) = w (i,j,l) / g + wgri (i,j,llm+1-l) = w (i,j,l) +c wgri (i,j,0) = 0. ! a detruire ult. +c wgri (i,j,l) = 0.1 ! w (i,j,l) +c wgri (i,j,llm) = 0. ! a detruire ult. + 500 CONTINUE + DO j = 1,jjp1 + DO i = 1,iip1 + wgri(i,j,0)=0. + enddo + enddo + +C----------------------------------------------------------------- + +C start here +C boucle sur les latitudes +C + DO 1 K=1,LAT +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 101 +C + DO 10 JV=1,NTRA + DO 10 L=1,NIV + DO 100 I=1,LON + sz(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.), + + ABS(sz(I,K,L,JV))),sz(I,K,L,JV)) + 100 CONTINUE + 10 CONTINUE +C + 101 CONTINUE +C +C boucle sur les niveaux intercouches de 1 a NIV-1 +C (flux nul au sommet L=0 et a la base L=NIV) +C +C calculate flux and moments between adjacent boxes +C (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0) +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C + DO 11 L=1,NIV-1 + LP=L+1 +C + DO 110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + FM(I,L)=-WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,LP) + SM(I,K,LP)=SM(I,K,LP)-FM(I,L) + ELSE + FM(I,L)=WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,L) + ENDIF +C + ALFQ (I)=ALF(I)*ALF(I) + ALF1 (I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) +C + 110 CONTINUE +C + DO 111 JV=1,NTRA + DO 1110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + F0(I,L,JV)=ALF (I)*( S0(I,K,LP,JV)-ALF1(I)*sz(I,K,LP,JV) ) + FZ(I,L,JV)=ALFQ(I)*sz(I,K,LP,JV) + FX(I,L,JV)=ALF (I)*sx(I,K,LP,JV) + FY(I,L,JV)=ALF (I)*sy(I,K,LP,JV) +C + S0(I,K,LP,JV)=S0(I,K,LP,JV)-F0(I,L,JV) + sz(I,K,LP,JV)=ALF1Q(I)*sz(I,K,LP,JV) + sx(I,K,LP,JV)=sx(I,K,LP,JV)-FX(I,L,JV) + sy(I,K,LP,JV)=sy(I,K,LP,JV)-FY(I,L,JV) +C + ELSE +C + F0(I,L,JV)=ALF (I)*(S0(I,K,L,JV)+ALF1(I)*sz(I,K,L,JV) ) + FZ(I,L,JV)=ALFQ(I)*sz(I,K,L,JV) + FX(I,L,JV)=ALF (I)*sx(I,K,L,JV) + FY(I,L,JV)=ALF (I)*sy(I,K,L,JV) +C + S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,L,JV) + sz(I,K,L,JV)=ALF1Q(I)*sz(I,K,L,JV) + sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,L,JV) + sy(I,K,L,JV)=sy(I,K,L,JV)-FY(I,L,JV) +C + ENDIF +C + 1110 CONTINUE + 111 CONTINUE +C + 11 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 12 L=1,NIV-1 + LP=L+1 +C + DO 120 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,L) + ELSE + SM(I,K,LP)=SM(I,K,LP)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,LP) + ENDIF +C + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) +C + 120 CONTINUE +C + DO 121 JV=1,NTRA + DO 1210 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV) + S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV) + sz(I,K,L,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,L,JV)+3.*TEMPTM + sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,L,JV) + sy(I,K,L,JV)=sy(I,K,L,JV)+FY(I,L,JV) +C + ELSE +C + TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV) + S0(I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV) + sz(I,K,LP,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,LP,JV) + + +3.*TEMPTM + sx(I,K,LP,JV)=sx(I,K,LP,JV)+FX(I,L,JV) + sy(I,K,LP,JV)=sy(I,K,LP,JV)+FY(I,L,JV) +C + ENDIF +C + 1210 CONTINUE + 121 CONTINUE +C + 12 CONTINUE +C +C fin de la boucle principale sur les latitudes +C + 1 CONTINUE +C +C------------------------------------------------------------- +C +C ----------- AA Test en fin de ADVX ------ Controle des S* + +c DO 9999 l = 1, llm +c DO 9999 j = 1, jjp1 +c DO 9999 i = 1, iip1 +c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN +c PRINT*, '-------------------' +c PRINT*, 'En fin de ADVZ' +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra) +c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra) +c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra) +c WRITE (*,*) 'On arrete !! - pbl en fin de ADVZ1' +c STOP +c ENDIF + 9999 CONTINUE + +C *** ------------------- bouclage cyclique en X ------------ + +c DO l = 1,llm +c DO j = 1,jjp1 +c SM(iip1,j,l) = SM(1,j,l) +c S0(iip1,j,l,ntra) = S0(1,j,l,ntra) +C sx(iip1,j,l,ntra) = sx(1,j,l,ntra) +c sy(iip1,j,l,ntra) = sy(1,j,l,ntra) +c sz(iip1,j,l,ntra) = sz(1,j,l,ntra) +c ENDDO +c ENDDO + +C------------------------------------------------------------- +C *** Test : diag de la qqtite totale de traceur +C dans l'atmosphere avant l'advection en z + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqf = sqf + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------' + PRINT*,'sqf=', sqf + +C------------------------------------------------------------- + RETURN + END +C_______________________________________________________________ +C_______________________________________________________________ Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advzp.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advzp.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/advzp.F (revision 1280) @@ -0,0 +1,378 @@ +! +! $Header$ +! + SUBROUTINE ADVZP(LIMIT,DTZ,W,SM,S0,SSX,SY,SZ + . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra ) + + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C second-order moments (SOM) advection of tracer in Z direction C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Source : Pascal Simon ( Meteo, CNRM ) C +C Adaptation : A.A. (LGGE) C +C Derniere Modif : 19/11/95 LAST C +C C +C sont les arguments d'entree pour le s-pg C +C C +C argument de sortie du s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Rem : Probleme aux poles il faut reecrire ce cas specifique +C Attention au sens de l'indexation +C + +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +C +C Arguments : +C ---------- +C dty : frequence fictive d'appel du transport +C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 +c + INTEGER lon,lat,niv + INTEGER i,j,jv,k,kp,l,lp + INTEGER ntra +c PARAMETER (ntra = 1) +c + REAL dtz + REAL w ( iip1,jjp1,llm ) +c +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL SSX(iip1,jjp1,llm,ntra) + + ,SY(iip1,jjp1,llm,ntra) + + ,SZ(iip1,jjp1,llm,ntra) + + ,SSXX(iip1,jjp1,llm,ntra) + + ,SSXY(iip1,jjp1,llm,ntra) + + ,SSXZ(iip1,jjp1,llm,ntra) + + ,SYY(iip1,jjp1,llm,ntra) + + ,SYZ(iip1,jjp1,llm,ntra) + + ,SZZ(iip1,jjp1,llm,ntra) +C +C Local : +C ------- +C +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : +C + REAL WGRI(iip1,jjp1,0:llm) + +C Rem : UGRI et VGRI ne sont pas utilises dans +C cette subroutine ( advection en z uniquement ) +C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv +C attention a celui de WGRI +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C +C the moments Fij are used as temporary storage for +C portions of the grid boxes in transit at the current level +C +C work arrays +C +C + REAL F0(iim,llm,ntra),FM(iim,llm) + REAL FX(iim,llm,ntra),FY(iim,llm,ntra) + REAL FZ(iim,llm,ntra) + REAL FXX(iim,llm,ntra),FXY(iim,llm,ntra) + REAL FXZ(iim,llm,ntra),FYY(iim,llm,ntra) + REAL FYZ(iim,llm,ntra),FZZ(iim,llm,ntra) + REAL S00(ntra) + REAL SM0 ! Just temporal variable +C +C work arrays +C + REAL ALF(iim),ALF1(iim) + REAL ALFQ(iim),ALF1Q(iim) + REAL ALF2(iim),ALF3(iim) + REAL ALF4(iim) + REAL TEMPTM ! Just temporal variable + REAL SLPMAX,S1MAX,S1NEW,S2NEW +c + REAL sqi,sqf + LOGICAL LIMIT + + lon = iim ! rem : Il est possible qu'un pbl. arrive ici + lat = jjp1 ! a cause des dim. differentes entre les + niv = llm ! tab. S et VGRI + +c----------------------------------------------------------------- +C *** Test : diag de la qtite totale de traceur dans +C l'atmosphere avant l'advection en Y +c + sqi = 0. + sqf = 0. +c + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqi = sqi + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'---------- DIAG DANS ADVZP - ENTREE --------' + PRINT*,'sqi=',sqi + +c----------------------------------------------------------------- +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C Conversion des flux de masses en kg + + DO 500 l = 1,llm + DO 500 j = 1,jjp1 + DO 500 i = 1,iip1 + wgri (i,j,llm+1-l) = w (i,j,l) + 500 CONTINUE + do j=1,jjp1 + do i=1,iip1 + wgri(i,j,0)=0. + enddo + enddo +c +cAA rem : Je ne suis pas sur du signe +cAA Je ne suis pas sur pour le 0:llm +c +c----------------------------------------------------------------- +C---------------------- START HERE ------------------------------- +C +C boucle sur les latitudes +C + DO 1 K=1,LAT +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 101 +C + DO 10 JV=1,NTRA + DO 10 L=1,NIV + DO 100 I=1,LON + IF(S0(I,K,L,JV).GT.0.) THEN + SLPMAX=S0(I,K,L,JV) + S1MAX =1.5*SLPMAX + S1NEW =AMIN1(S1MAX,AMAX1(-S1MAX,SZ(I,K,L,JV))) + S2NEW =AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , + + AMAX1(ABS(S1NEW)-SLPMAX,SZZ(I,K,L,JV)) ) + SZ (I,K,L,JV)=S1NEW + SZZ(I,K,L,JV)=S2NEW + SSXZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXZ(I,K,L,JV))) + SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV))) + ELSE + SZ (I,K,L,JV)=0. + SZZ(I,K,L,JV)=0. + SSXZ(I,K,L,JV)=0. + SYZ(I,K,L,JV)=0. + ENDIF + 100 CONTINUE + 10 CONTINUE +C + 101 CONTINUE +C +C boucle sur les niveaux intercouches de 1 a NIV-1 +C (flux nul au sommet L=0 et a la base L=NIV) +C +C calculate flux and moments between adjacent boxes +C (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0) +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C + DO 11 L=1,NIV-1 + LP=L+1 +C + DO 110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + FM(I,L)=-WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,LP) + SM(I,K,LP)=SM(I,K,LP)-FM(I,L) + ELSE + FM(I,L)=WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,L) + ENDIF +C + ALFQ (I)=ALF(I)*ALF(I) + ALF1 (I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2 (I)=ALF1(I)-ALF(I) + ALF3 (I)=ALF(I)*ALFQ(I) + ALF4 (I)=ALF1(I)*ALF1Q(I) +C + 110 CONTINUE +C + DO 111 JV=1,NTRA + DO 1110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + F0 (I,L,JV)=ALF (I)* ( S0(I,K,LP,JV)-ALF1(I)* + + ( SZ(I,K,LP,JV)-ALF2(I)*SZZ(I,K,LP,JV) ) ) + FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,LP,JV)-3.*ALF1(I)*SZZ(I,K,LP,JV)) + FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,LP,JV) + FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,LP,JV) + FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,LP,JV) + FX (I,L,JV)=ALF (I)*(SSX(I,K,LP,JV)-ALF1(I)*SSXZ(I,K,LP,JV)) + FY (I,L,JV)=ALF (I)*(SY(I,K,LP,JV)-ALF1(I)*SYZ(I,K,LP,JV)) + FXX(I,L,JV)=ALF (I)*SSXX(I,K,LP,JV) + FXY(I,L,JV)=ALF (I)*SSXY(I,K,LP,JV) + FYY(I,L,JV)=ALF (I)*SYY(I,K,LP,JV) +C + S0 (I,K,LP,JV)=S0 (I,K,LP,JV)-F0 (I,L,JV) + SZ (I,K,LP,JV)=ALF1Q(I) + + *(SZ(I,K,LP,JV)+3.*ALF(I)*SZZ(I,K,LP,JV)) + SZZ(I,K,LP,JV)=ALF4 (I)*SZZ(I,K,LP,JV) + SSXZ(I,K,LP,JV)=ALF1Q(I)*SSXZ(I,K,LP,JV) + SYZ(I,K,LP,JV)=ALF1Q(I)*SYZ(I,K,LP,JV) + SSX (I,K,LP,JV)=SSX (I,K,LP,JV)-FX (I,L,JV) + SY (I,K,LP,JV)=SY (I,K,LP,JV)-FY (I,L,JV) + SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)-FXX(I,L,JV) + SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)-FXY(I,L,JV) + SYY(I,K,LP,JV)=SYY(I,K,LP,JV)-FYY(I,L,JV) +C + ELSE +C + F0 (I,L,JV)=ALF (I)*(S0(I,K,L,JV) + + +ALF1(I) * (SZ(I,K,L,JV)+ALF2(I)*SZZ(I,K,L,JV)) ) + FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,L,JV)+3.*ALF1(I)*SZZ(I,K,L,JV)) + FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,L,JV) + FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,L,JV) + FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,L,JV) + FX (I,L,JV)=ALF (I)*(SSX(I,K,L,JV)+ALF1(I)*SSXZ(I,K,L,JV)) + FY (I,L,JV)=ALF (I)*(SY(I,K,L,JV)+ALF1(I)*SYZ(I,K,L,JV)) + FXX(I,L,JV)=ALF (I)*SSXX(I,K,L,JV) + FXY(I,L,JV)=ALF (I)*SSXY(I,K,L,JV) + FYY(I,L,JV)=ALF (I)*SYY(I,K,L,JV) +C + S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0(I,L,JV) + SZ (I,K,L,JV)=ALF1Q(I)*(SZ(I,K,L,JV)-3.*ALF(I)*SZZ(I,K,L,JV)) + SZZ(I,K,L,JV)=ALF4 (I)*SZZ(I,K,L,JV) + SSXZ(I,K,L,JV)=ALF1Q(I)*SSXZ(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1Q(I)*SYZ(I,K,L,JV) + SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,L,JV) + SY (I,K,L,JV)=SY (I,K,L,JV)-FY (I,L,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,L,JV) + SSXY(I,K,L,JV)=SSXY(I,K,L,JV)-FXY(I,L,JV) + SYY(I,K,L,JV)=SYY(I,K,L,JV)-FYY(I,L,JV) +C + ENDIF +C + 1110 CONTINUE + 111 CONTINUE +C + 11 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 12 L=1,NIV-1 + LP=L+1 +C + DO 120 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,L) + ELSE + SM(I,K,LP)=SM(I,K,LP)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,LP) + ENDIF +C + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF(I)*ALF1(I) + ALF3(I)=ALF1(I)-ALF(I) +C + 120 CONTINUE +C + DO 121 JV=1,NTRA + DO 1210 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV) + S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV) + SZZ(I,K,L,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,L,JV) + + +5.*( ALF2(I)*(FZ(I,L,JV)-SZ(I,K,L,JV))+ALF3(I)*TEMPTM ) + SZ (I,K,L,JV)=ALF (I)*FZ (I,L,JV)+ALF1 (I)*SZ (I,K,L,JV) + + +3.*TEMPTM + SSXZ(I,K,L,JV)=ALF (I)*FXZ(I,L,JV)+ALF1 (I)*SSXZ(I,K,L,JV) + + +3.*(ALF1(I)*FX (I,L,JV)-ALF (I)*SSX (I,K,L,JV)) + SYZ(I,K,L,JV)=ALF (I)*FYZ(I,L,JV)+ALF1 (I)*SYZ(I,K,L,JV) + + +3.*(ALF1(I)*FY (I,L,JV)-ALF (I)*SY (I,K,L,JV)) + SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,L,JV) + SY (I,K,L,JV)=SY (I,K,L,JV)+FY (I,L,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,L,JV) + SSXY(I,K,L,JV)=SSXY(I,K,L,JV)+FXY(I,L,JV) + SYY(I,K,L,JV)=SYY(I,K,L,JV)+FYY(I,L,JV) +C + ELSE +C + TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV) + S0 (I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV) + SZZ(I,K,LP,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,LP,JV) + + +5.*( ALF2(I)*(SZ(I,K,LP,JV)-FZ(I,L,JV))-ALF3(I)*TEMPTM ) + SZ (I,K,LP,JV)=ALF (I)*FZ(I,L,JV)+ALF1(I)*SZ(I,K,LP,JV) + + +3.*TEMPTM + SSXZ(I,K,LP,JV)=ALF(I)*FXZ(I,L,JV)+ALF1(I)*SSXZ(I,K,LP,JV) + + +3.*(ALF(I)*SSX(I,K,LP,JV)-ALF1(I)*FX(I,L,JV)) + SYZ(I,K,LP,JV)=ALF(I)*FYZ(I,L,JV)+ALF1(I)*SYZ(I,K,LP,JV) + + +3.*(ALF(I)*SY(I,K,LP,JV)-ALF1(I)*FY(I,L,JV)) + SSX (I,K,LP,JV)=SSX (I,K,LP,JV)+FX (I,L,JV) + SY (I,K,LP,JV)=SY (I,K,LP,JV)+FY (I,L,JV) + SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)+FXX(I,L,JV) + SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)+FXY(I,L,JV) + SYY(I,K,LP,JV)=SYY(I,K,LP,JV)+FYY(I,L,JV) +C + ENDIF +C + 1210 CONTINUE + 121 CONTINUE +C + 12 CONTINUE +C +C fin de la boucle principale sur les latitudes +C + 1 CONTINUE +C + DO l = 1,llm + DO j = 1,jjp1 + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,ntra) = S0(1,j,l,ntra) + SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra) + SY(iip1,j,l,ntra) = SY(1,j,l,ntra) + SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra) + ENDDO + ENDDO +c C------------------------------------------------------------- +C *** Test : diag de la qqtite totale de tarceur +C dans l'atmosphere avant l'advection en z + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqf = sqf + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------' + PRINT*,'sqf=', sqf + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/bands.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/bands.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/bands.F90 (revision 1280) @@ -0,0 +1,439 @@ +! +! $Id$ +! + module Bands + + integer, parameter :: bands_caldyn=1 + integer, parameter :: bands_vanleer=2 + integer, parameter :: bands_dissip=3 + + INTEGER,dimension(:),allocatable :: jj_Nb_Caldyn + INTEGER,dimension(:),allocatable :: jj_Nb_vanleer + INTEGER,dimension(:),allocatable :: jj_Nb_vanleer2 + INTEGER,dimension(:),allocatable :: jj_Nb_dissip + INTEGER,dimension(:),allocatable :: jj_Nb_physic + INTEGER,dimension(:),allocatable :: jj_Nb_physic_bis + INTEGER,dimension(:),allocatable :: distrib_phys + + contains + + subroutine AllocateBands + use parallel + implicit none + + allocate(jj_Nb_Caldyn(0:MPI_Size-1)) + allocate(jj_Nb_vanleer(0:MPI_Size-1)) + allocate(jj_Nb_vanleer2(0:MPI_Size-1)) + allocate(jj_Nb_dissip(0:MPI_Size-1)) + allocate(jj_Nb_physic(0:MPI_Size-1)) + allocate(jj_Nb_physic_bis(0:MPI_Size-1)) + allocate(distrib_phys(0:MPI_Size-1)) + + end subroutine AllocateBands + + subroutine Read_distrib + use parallel + implicit none + + include "dimensions.h" + integer :: i,j + character (len=4) :: siim,sjjm,sllm,sproc + character (len=255) :: filename + integer :: unit_number=10 + integer :: ierr + + call AllocateBands + write(siim,'(i3)') iim + write(sjjm,'(i3)') jjm + write(sllm,'(i3)') llm + write(sproc,'(i3)') mpi_size + filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_' & + //TRIM(ADJUSTL(sproc))//'prc.dat' + + OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='old',FORM='formatted',IOSTAT=ierr) + + if (ierr==0) then + + do i=0,mpi_size-1 + read (unit_number,*) j,jj_nb_caldyn(i) + enddo + + do i=0,mpi_size-1 + read (unit_number,*) j,jj_nb_vanleer(i) + enddo + + do i=0,mpi_size-1 + read (unit_number,*) j,jj_nb_dissip(i) + enddo + + do i=0,mpi_size-1 + read (unit_number,*) j,distrib_phys(i) + enddo + + CLOSE(unit_number) + + else + do i=0,mpi_size-1 + jj_nb_caldyn(i)=(jjm+1)/mpi_size + if (ivalue(j)) then + tmpvalue=value(i) + value(i)=value(j) + value(j)=tmpvalue + + tmpindex=index(i) + index(i)=index(j) + index(j)=tmpindex + endif + enddo + enddo + + maxvalue=value(mpi_size-1) + max_proc=index(mpi_size-1) + + do i=0,mpi_size-2 + minvalue=value(i) + min_proc=index(i) + if (jj_nb_caldyn(max_proc)>3) then + if (timer_iteration(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)<=1 ) then + jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1 + jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1 + exit + else + if (timer_average(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc) & + -timer_delta(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc) < maxvalue) then + jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1 + jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1 + exit + endif + endif + endif + enddo + + deallocate(value) + deallocate(index) + + end subroutine AdjustBands_caldyn + + subroutine AdjustBands_vanleer + use times + use parallel + implicit none + + real :: minvalue,maxvalue + integer :: min_proc,max_proc + integer :: i,j + real,allocatable,dimension(:) :: value + integer,allocatable,dimension(:) :: index + real :: tmpvalue + integer :: tmpindex + + allocate(value(0:mpi_size-1)) + allocate(index(0:mpi_size-1)) + + + call allgather_timer_average + + do i=0,mpi_size-1 + value(i)=timer_average(jj_nb_vanleer(i),timer_vanleer,i) + index(i)=i + enddo + + do i=0,mpi_size-2 + do j=i+1,mpi_size-1 + if (value(i)>value(j)) then + tmpvalue=value(i) + value(i)=value(j) + value(j)=tmpvalue + + tmpindex=index(i) + index(i)=index(j) + index(j)=tmpindex + endif + enddo + enddo + + maxvalue=value(mpi_size-1) + max_proc=index(mpi_size-1) + + do i=0,mpi_size-2 + minvalue=value(i) + min_proc=index(i) + + if (jj_nb_vanleer(max_proc)>3) then + if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc)==0. .or. & + timer_average(jj_nb_vanleer(max_proc)-1,timer_vanleer,max_proc)==0.) then + jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1 + jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1 + exit + else + if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc) < maxvalue) then + jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1 + jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1 + exit + endif + endif + endif + enddo + + deallocate(value) + deallocate(index) + + end subroutine AdjustBands_vanleer + + subroutine AdjustBands_dissip + use times + use parallel + implicit none + + real :: minvalue,maxvalue + integer :: min_proc,max_proc + integer :: i,j + real,allocatable,dimension(:) :: value + integer,allocatable,dimension(:) :: index + real :: tmpvalue + integer :: tmpindex + + allocate(value(0:mpi_size-1)) + allocate(index(0:mpi_size-1)) + + + call allgather_timer_average + + do i=0,mpi_size-1 + value(i)=timer_average(jj_nb_dissip(i),timer_dissip,i) + index(i)=i + enddo + + do i=0,mpi_size-2 + do j=i+1,mpi_size-1 + if (value(i)>value(j)) then + tmpvalue=value(i) + value(i)=value(j) + value(j)=tmpvalue + + tmpindex=index(i) + index(i)=index(j) + index(j)=tmpindex + endif + enddo + enddo + + maxvalue=value(mpi_size-1) + max_proc=index(mpi_size-1) + + do i=0,mpi_size-2 + minvalue=value(i) + min_proc=index(i) + + if (jj_nb_dissip(max_proc)>3) then + if (timer_iteration(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)<=1) then + jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1 + jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1 + exit + else + if (timer_average(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc) & + - timer_delta(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc) < maxvalue) then + jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1 + jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1 + exit + endif + endif + endif + enddo + + deallocate(value) + deallocate(index) + + end subroutine AdjustBands_dissip + + subroutine AdjustBands_physic + use times +#ifdef CPP_EARTH +! Ehouarn: what follows is only related to // physics; for now only for Earth + USE mod_phys_lmdz_para, only : klon_mpi_para_nb +#endif + USE parallel + implicit none + + integer :: i,Index + real,allocatable,dimension(:) :: value + integer,allocatable,dimension(:) :: Inc + real :: medium + integer :: NbTot,sgn + + allocate(value(0:mpi_size-1)) + allocate(Inc(0:mpi_size-1)) + + + call allgather_timer_average + + medium=0 + do i=0,mpi_size-1 + value(i)=timer_average(jj_nb_physic(i),timer_physic,i) + medium=medium+value(i) + enddo + + medium=medium/mpi_size + NbTot=0 +#ifdef CPP_EARTH +! Ehouarn: what follows is only related to // physics; for now only for Earth + do i=0,mpi_size-1 + Inc(i)=nint(klon_mpi_para_nb(i)*(medium-value(i))/value(i)) + NbTot=NbTot+Inc(i) + enddo + + if (NbTot>=0) then + Sgn=1 + else + Sgn=-1 + NbTot=-NbTot + endif + + Index=0 + do i=1,NbTot + Inc(Index)=Inc(Index)-Sgn + Index=Index+1 + if (Index>mpi_size-1) Index=0 + enddo + + do i=0,mpi_size-1 + distrib_phys(i)=klon_mpi_para_nb(i)+inc(i) + enddo +#endif + end subroutine AdjustBands_physic + + subroutine WriteBands + USE parallel + implicit none + include "dimensions.h" + + integer :: i,j + character (len=4) :: siim,sjjm,sllm,sproc + character (len=255) :: filename + integer :: unit_number=10 + integer :: ierr + + write(siim,'(i3)') iim + write(sjjm,'(i3)') jjm + write(sllm,'(i3)') llm + write(sproc,'(i3)') mpi_size + + filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_' & + //TRIM(ADJUSTL(sproc))//'prc.dat' + + OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='replace',FORM='formatted',IOSTAT=ierr) + + if (ierr==0) then + +! write (unit_number,*) '*** Bandes caldyn ***' + do i=0,mpi_size-1 + write (unit_number,*) i,jj_nb_caldyn(i) + enddo + +! write (unit_number,*) '*** Bandes vanleer ***' + do i=0,mpi_size-1 + write (unit_number,*) i,jj_nb_vanleer(i) + enddo + +! write (unit_number,*) '*** Bandes dissip ***' + do i=0,mpi_size-1 + write (unit_number,*) i,jj_nb_dissip(i) + enddo + + do i=0,mpi_size-1 + write (unit_number,*) i,distrib_phys(i) + enddo + + CLOSE(unit_number) + else + print *,'probleme lors de l ecriture des bandes' + endif + + end subroutine WriteBands + + end module Bands + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/bernoui.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/bernoui.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/bernoui.F (revision 1280) @@ -0,0 +1,58 @@ +! +! $Header$ +! + SUBROUTINE bernoui (ngrid,nlay,pphi,pecin,pbern) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c calcul de la fonction de Bernouilli aux niveaux s ..... +c phi et ecin sont des arguments d'entree pour le s-pg ....... +c bern est un argument de sortie pour le s-pg ...... +c +c fonction de Bernouilli = bern = filtre de( geopotentiel + +c energ.cinet.) +c +c======================================================================= +c +c----------------------------------------------------------------------- +c Decalrations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +c +c Arguments: +c ---------- +c + INTEGER nlay,ngrid + REAL pphi(ngrid*nlay),pecin(ngrid*nlay),pbern(ngrid*nlay) +c +c Local: +c ------ +c + INTEGER ijl +c +c----------------------------------------------------------------------- +c calcul de Bernouilli: +c --------------------- +c + DO 4 ijl = 1,ngrid*nlay + pbern( ijl ) = pphi( ijl ) + pecin( ijl ) + 4 CONTINUE +c +c----------------------------------------------------------------------- +c filtre: +c ------- +c + CALL filtreg( pbern, jjp1, llm, 2,1, .true., 1 ) +c +c----------------------------------------------------------------------- + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/bernoui_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/bernoui_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/bernoui_p.F (revision 1280) @@ -0,0 +1,74 @@ + SUBROUTINE bernoui_p (ngrid,nlay,pphi,pecin,pbern) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c calcul de la fonction de Bernouilli aux niveaux s ..... +c phi et ecin sont des arguments d'entree pour le s-pg ....... +c bern est un argument de sortie pour le s-pg ...... +c +c fonction de Bernouilli = bern = filtre de( geopotentiel + +c energ.cinet.) +c +c======================================================================= +c +c----------------------------------------------------------------------- +c Decalrations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +c +c Arguments: +c ---------- +c + INTEGER nlay,ngrid + REAL pphi(ngrid,nlay),pecin(ngrid,nlay),pbern(ngrid,nlay) +c +c Local: +c ------ +c + INTEGER ij,l,ijb,ije,jjb,jje +c +c----------------------------------------------------------------------- +c calcul de Bernouilli: +c --------------------- +c + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ij_end + + jjb=jj_begin + jje=jj_end+1 + if (pole_sud) jje=jj_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + DO 4 ij = ijb,ije + pbern( ij,l ) = pphi( ij,l ) + pecin( ij,l ) + 4 CONTINUE + + ENDDO +c$OMP END DO NOWAIT +c +c----------------------------------------------------------------------- +c filtre: +c ------- +c + + + CALL filtreg_p( pbern,jjb,jje, jjp1, llm, 2,1, .true., 1 ) +c +c----------------------------------------------------------------------- + + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/bilan_dyn_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/bilan_dyn_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/bilan_dyn_p.F (revision 1280) @@ -0,0 +1,717 @@ +! +! $Id$ +! + SUBROUTINE bilan_dyn_p (ntrac,dt_app,dt_cum, + s ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac) + +c AFAIRE +c Prevoir en champ nq+1 le diagnostique de l'energie +c en faisant Qzon=Cv T + L * ... +c vQ..A=Cp T + L * ... + +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + USE parallel + USE mod_hallo + use misc_mod + use write_field + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" +#include "temps.h" +#include "iniprint.h" + +c==================================================================== +c +c Sous-programme consacre à des diagnostics dynamiques de base +c +c +c De facon generale, les moyennes des scalaires Q sont ponderees par +c la masse. +c +c Les flux de masse sont eux simplement moyennes. +c +c==================================================================== + +c Arguments : +c =========== + + integer ntrac + real dt_app,dt_cum + real ps(iip1,jjp1) + real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm) + real flux_u(iip1,jjp1,llm) + real flux_v(iip1,jjm,llm) + real teta(iip1,jjp1,llm) + real phi(iip1,jjp1,llm) + real ucov(iip1,jjp1,llm) + real vcov(iip1,jjm,llm) + real trac(iip1,jjp1,llm,ntrac) + +c Local : +c ======= + + integer icum,ncum + logical first + real zz,zqy,zfactv(jjm,llm) + + integer nQ + parameter (nQ=7) + + +cym character*6 nom(nQ) +cym character*6 unites(nQ) + character*6,save :: nom(nQ) + character*6,save :: unites(nQ) + + character*10 file + integer ifile + parameter (ifile=4) + + integer itemp,igeop,iecin,iang,iu,iovap,iun + integer i_sortie + + save first,icum,ncum + save itemp,igeop,iecin,iang,iu,iovap,iun + save i_sortie + + real time + integer itau + save time,itau + data time,itau/0.,0/ + + data first/.true./ + data itemp,igeop,iecin,iang,iu,iovap,iun/1,2,3,4,5,6,7/ + data i_sortie/1/ + + real ww + +c variables dynamiques intermédiaires + REAL vcont(iip1,jjm,llm),ucont(iip1,jjp1,llm) + REAL ang(iip1,jjp1,llm),unat(iip1,jjp1,llm) + REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm) + REAL vorpot(iip1,jjm,llm) + REAL w(iip1,jjp1,llm),ecin(iip1,jjp1,llm),convm(iip1,jjp1,llm) + REAL bern(iip1,jjp1,llm) + +c champ contenant les scalaires advectés. + real Q(iip1,jjp1,llm,nQ) + +c champs cumulés + real ps_cum(iip1,jjp1) + real masse_cum(iip1,jjp1,llm) + real flux_u_cum(iip1,jjp1,llm) + real flux_v_cum(iip1,jjm,llm) + real Q_cum(iip1,jjp1,llm,nQ) + real flux_uQ_cum(iip1,jjp1,llm,nQ) + real flux_vQ_cum(iip1,jjm,llm,nQ) + real flux_wQ_cum(iip1,jjp1,llm,nQ) + real dQ(iip1,jjp1,llm,nQ) + + save ps_cum,masse_cum,flux_u_cum,flux_v_cum + save Q_cum,flux_uQ_cum,flux_vQ_cum + +c champs de tansport en moyenne zonale + integer ntr,itr + parameter (ntr=5) + +cym character*10 znom(ntr,nQ) +cym character*20 znoml(ntr,nQ) +cym character*10 zunites(ntr,nQ) + character*10,save :: znom(ntr,nQ) + character*20,save :: znoml(ntr,nQ) + character*10,save :: zunites(ntr,nQ) + + integer iave,itot,immc,itrs,istn + data iave,itot,immc,itrs,istn/1,2,3,4,5/ + character*3 ctrs(ntr) + data ctrs/' ','TOT','MMC','TRS','STN'/ + + real zvQ(jjm,llm,ntr,nQ),zvQtmp(jjm,llm) + real zavQ(jjm,ntr,nQ),psiQ(jjm,llm+1,nQ) + real zmasse(jjm,llm),zamasse(jjm) + + real zv(jjm,llm),psi(jjm,llm+1) + + integer i,j,l,iQ + + +c Initialisation du fichier contenant les moyennes zonales. +c --------------------------------------------------------- + + character*10 infile + + integer fileid + integer thoriid, zvertiid + save fileid + + integer ndex3d(jjm*llm) + +C Variables locales +C + integer tau0 + real zjulian + character*3 str + character*10 ctrac + integer ii,jj + integer zan, dayref +C + real rlong(jjm),rlatg(jjm) + integer :: jjb,jje,jjn,ijb,ije + type(Request) :: Req + +! definition du domaine d'ecriture pour le rebuild + + INTEGER,DIMENSION(1) :: ddid + INTEGER,DIMENSION(1) :: dsg + INTEGER,DIMENSION(1) :: dsl + INTEGER,DIMENSION(1) :: dpf + INTEGER,DIMENSION(1) :: dpl + INTEGER,DIMENSION(1) :: dhs + INTEGER,DIMENSION(1) :: dhe + + INTEGER :: bilan_dyn_domain_id + + +c===================================================================== +c Initialisation +c===================================================================== + ndex3d=0 + if (adjust) return + + time=time+dt_app + itau=itau+1 + + if (first) then + + + icum=0 +c initialisation des fichiers + first=.false. +c ncum est la frequence de stokage en pas de temps + ncum=dt_cum/dt_app + if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then + WRITE(lunout,*) + . 'Pb : le pas de cumule doit etre multiple du pas' + WRITE(lunout,*)'dt_app=',dt_app + WRITE(lunout,*)'dt_cum=',dt_cum + stop + endif + + if (i_sortie.eq.1) then + file='dynzon' + if (mpi_rank==0) then + call inigrads(ifile,1 + s ,0.,180./pi,0.,0.,jjm,rlatv,-90.,90.,180./pi + s ,llm,presnivs,1. + s ,dt_cum,file,'dyn_zon ') + endif + endif + + nom(itemp)='T' + nom(igeop)='gz' + nom(iecin)='K' + nom(iang)='ang' + nom(iu)='u' + nom(iovap)='ovap' + nom(iun)='un' + + unites(itemp)='K' + unites(igeop)='m2/s2' + unites(iecin)='m2/s2' + unites(iang)='ang' + unites(iu)='m/s' + unites(iovap)='kg/kg' + unites(iun)='un' + + +c Initialisation du fichier contenant les moyennes zonales. +c --------------------------------------------------------- + + infile='dynzon' + + zan = annee_ref + dayref = day_ref + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + rlong=0. + rlatg=rlatv*180./pi + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + IF (pole_sud) THEN + jjn=jj_nb-1 + jje=jj_end-1 + ENDIF + + ddid=(/ 2 /) + dsg=(/ jjm /) + dsl=(/ jjn /) + dpf=(/ jjb /) + dpl=(/ jje /) + dhs=(/ 0 /) + dhe=(/ 0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',bilan_dyn_domain_id) + + call histbeg(trim(infile), + . 1, rlong(jjb:jje), jjn, rlatg(jjb:jje), + . 1, 1, 1, jjn, + . tau0, zjulian, dt_cum, thoriid, fileid, + . bilan_dyn_domain_id) + +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'presnivs', 'Niveaux sigma','mb', + . llm, presnivs, zvertiid) +C +C Appels a histdef pour la definition des variables a sauvegarder + do iQ=1,nQ + do itr=1,ntr + if(itr.eq.1) then + znom(itr,iQ)=nom(iQ) + znoml(itr,iQ)=nom(iQ) + zunites(itr,iQ)=unites(iQ) + else + znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ) + znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr) + zunites(itr,iQ)='m/s * '//unites(iQ) + endif + enddo + enddo + +c Declarations des champs avec dimension verticale +c print*,'1HISTDEF' + do iQ=1,nQ + do itr=1,ntr + IF (prt_level > 5) + . WRITE(lunout,*)'var ',itr,iQ + . ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ) + call histdef(fileid,znom(itr,iQ),znoml(itr,iQ), + . zunites(itr,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + enddo +c Declarations pour les fonctions de courant +c print*,'2HISTDEF' + call histdef(fileid,'psi'//nom(iQ) + . ,'stream fn. '//znoml(itot,iQ), + . zunites(itot,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + enddo + + +c Declarations pour les champs de transport d'air +c print*,'3HISTDEF' + call histdef(fileid, 'masse', 'masse', + . 'kg', 1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', dt_cum, dt_cum) + call histdef(fileid, 'v', 'v', + . 'm/s', 1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', dt_cum, dt_cum) +c Declarations pour les fonctions de courant +c print*,'4HISTDEF' + call histdef(fileid,'psi','stream fn. MMC ','mega t/s', + . 1,jjn,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + + +c Declaration des champs 1D de transport en latitude +c print*,'5HISTDEF' + do iQ=1,nQ + do itr=2,ntr + call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ), + . zunites(itr,iQ),1,jjn,thoriid,1,1,1,-99, + . 32,'ave(X)',dt_cum,dt_cum) + enddo + enddo + + +c print*,'8HISTDEF' + CALL histend(fileid) + + + endif + + +c===================================================================== +c Calcul des champs dynamiques +c ---------------------------- + + jjb=jj_begin + jje=jj_end + +c énergie cinétique + ucont(:,jjb:jje,:)=0 + + call Register_Hallo(ucov,ip1jmp1,llm,1,1,1,1,Req) + call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,Req) + call SendRequest(Req) + call WaitRequest(Req) + + CALL covcont_p(llm,ucov,vcov,ucont,vcont) + CALL enercin_p(vcov,ucov,vcont,ucont,ecin) + +c moment cinétique + do l=1,llm + ang(:,jjb:jje,l)=ucov(:,jjb:jje,l)+constang(:,jjb:jje) + unat(:,jjb:jje,l)=ucont(:,jjb:jje,l)*cu(:,jjb:jje) + enddo + + Q(:,jjb:jje,:,itemp)=teta(:,jjb:jje,:)*pk(:,jjb:jje,:)/cpp + Q(:,jjb:jje,:,igeop)=phi(:,jjb:jje,:) + Q(:,jjb:jje,:,iecin)=ecin(:,jjb:jje,:) + Q(:,jjb:jje,:,iang)=ang(:,jjb:jje,:) + Q(:,jjb:jje,:,iu)=unat(:,jjb:jje,:) + Q(:,jjb:jje,:,iovap)=trac(:,jjb:jje,:,1) + Q(:,jjb:jje,:,iun)=1. + + +c===================================================================== +c Cumul +c===================================================================== +c + if(icum.EQ.0) then + jjb=jj_begin + jje=jj_end + + ps_cum(:,jjb:jje)=0. + masse_cum(:,jjb:jje,:)=0. + flux_u_cum(:,jjb:jje,:)=0. + Q_cum(:,jjb:jje,:,:)=0. + flux_uQ_cum(:,jjb:jje,:,:)=0. + flux_v_cum(:,jjb:jje,:)=0. + if (pole_sud) jje=jj_end-1 + flux_v_cum(:,jjb:jje,:)=0. + flux_vQ_cum(:,jjb:jje,:,:)=0. + endif + + IF (prt_level > 5) + . WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1 + icum=icum+1 + +c accumulation des flux de masse horizontaux + jjb=jj_begin + jje=jj_end + + ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)+ps(:,jjb:jje) + masse_cum(:,jjb:jje,:)=masse_cum(:,jjb:jje,:)+masse(:,jjb:jje,:) + flux_u_cum(:,jjb:jje,:)=flux_u_cum(:,jjb:jje,:) + . +flux_u(:,jjb:jje,:) + if (pole_sud) jje=jj_end-1 + flux_v_cum(:,jjb:jje,:)=flux_v_cum(:,jjb:jje,:) + . +flux_v(:,jjb:jje,:) + + jjb=jj_begin + jje=jj_end + + do iQ=1,nQ + Q_cum(:,jjb:jje,:,iQ)=Q_cum(:,jjb:jje,:,iQ) + . +Q(:,jjb:jje,:,iQ)*masse(:,jjb:jje,:) + enddo + +c===================================================================== +c FLUX ET TENDANCES +c===================================================================== + +c Flux longitudinal +c ----------------- + do iQ=1,nQ + do l=1,llm + do j=jjb,jje + do i=1,iim + flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ) + s +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ)) + enddo + flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ) + enddo + enddo + enddo + +c flux méridien +c ------------- + do iQ=1,nQ + call Register_Hallo(Q(1,1,1,iQ),ip1jmp1,llm,0,1,1,0,Req) + enddo + call SendRequest(Req) + call WaitRequest(Req) + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + do iQ=1,nQ + do l=1,llm + do j=jjb,jje + do i=1,iip1 + flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ) + s +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ)) + enddo + enddo + enddo + enddo + + +c tendances +c --------- + +c convergence horizontale + call Register_Hallo(flux_uQ_cum,ip1jmp1,llm,2,2,2,2,Req) + call Register_Hallo(flux_vQ_cum,ip1jm,llm,2,2,2,2,Req) + call SendRequest(Req) + call WaitRequest(Req) + + call convflu_p(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ) + +c calcul de la vitesse verticale + call Register_Hallo(flux_u_cum,ip1jmp1,llm,2,2,2,2,Req) + call Register_Hallo(flux_v_cum,ip1jm,llm,2,2,2,2,Req) + call SendRequest(Req) + call WaitRequest(Req) + + call convmas_p(flux_u_cum,flux_v_cum,convm) + CALL vitvert_p(convm,w) + + jjb=jj_begin + jje=jj_end + + do iQ=1,nQ + do l=1,llm-1 + do j=jjb,jje + do i=1,iip1 + ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ)) + dQ(i,j,l ,iQ)=dQ(i,j,l ,iQ)-ww + dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww + enddo + enddo + enddo + enddo + IF (prt_level > 5) + . WRITE(lunout,*)'Apres les calculs fait a chaque pas' +c===================================================================== +c PAS DE TEMPS D'ECRITURE +c===================================================================== + if (icum.eq.ncum) then +c===================================================================== + + IF (prt_level > 5) + . WRITE(lunout,*)'Pas d ecriture' + +c Normalisation + do iQ=1,nQ + Q_cum(:,jjb:jje,:,iQ)=Q_cum(:,jjb:jje,:,iQ) + . /masse_cum(:,jjb:jje,:) + enddo + zz=1./float(ncum) + + jjb=jj_begin + jje=jj_end + + ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)*zz + masse_cum(:,jjb:jje,:)=masse_cum(:,jjb:jje,:)*zz + flux_u_cum(:,jjb:jje,:)=flux_u_cum(:,jjb:jje,:)*zz + flux_uQ_cum(:,jjb:jje,:,:)=flux_uQ_cum(:,jjb:jje,:,:)*zz + dQ(:,jjb:jje,:,:)=dQ(:,jjb:jje,:,:)*zz + + IF (pole_sud) jje=jj_end-1 + flux_v_cum(:,jjb:jje,:)=flux_v_cum(:,jjb:jje,:)*zz + flux_vQ_cum(:,jjb:jje,:,:)=flux_vQ_cum(:,jjb:jje,:,:)*zz + + jjb=jj_begin + jje=jj_end + + +c A retravailler eventuellement +c division de dQ par la masse pour revenir aux bonnes grandeurs + do iQ=1,nQ + dQ(:,jjb:jje,:,iQ)=dQ(:,jjb:jje,:,iQ)/masse_cum(:,jjb:jje,:) + enddo + +c===================================================================== +c Transport méridien +c===================================================================== + +c cumul zonal des masses des mailles +c ---------------------------------- + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + zv(jjb:jje,:)=0. + zmasse(jjb:jje,:)=0. + + call Register_Hallo(masse_cum,ip1jmp1,llm,1,1,1,1,Req) + do iQ=1,nQ + call Register_Hallo(Q_cum(1,1,1,iQ),ip1jmp1,llm,0,1,1,0,Req) + enddo + + call SendRequest(Req) + call WaitRequest(Req) + + call massbar_p(masse_cum,massebx,masseby) + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + do l=1,llm + do j=jjb,jje + do i=1,iim + zmasse(j,l)=zmasse(j,l)+masseby(i,j,l) + zv(j,l)=zv(j,l)+flux_v_cum(i,j,l) + enddo + zfactv(j,l)=cv(1,j)/zmasse(j,l) + enddo + enddo + +c print*,'3OK' +c -------------------------------------------------------------- +c calcul de la moyenne zonale du transport : +c ------------------------------------------ +c +c -- +c TOT : la circulation totale [ vq ] +c +c - - +c MMC : mean meridional circulation [ v ] [ q ] +c +c ---- -- - - +c TRS : transitoires [ v'q'] = [ vq ] - [ v q ] +c +c - * - * - - - - +c STT : stationaires [ v q ] = [ v q ] - [ v ] [ q ] +c +c - - +c on utilise aussi l'intermediaire TMP : [ v q ] +c +c la variable zfactv transforme un transport meridien cumule +c en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte +c +c -------------------------------------------------------------- + + +c ---------------------------------------- +c Transport dans le plan latitude-altitude +c ---------------------------------------- + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + zvQ=0. + psiQ=0. + do iQ=1,nQ + zvQtmp=0. + do l=1,llm + do j=jjb,jje +c print*,'j,l,iQ=',j,l,iQ +c Calcul des moyennes zonales du transort total et de zvQtmp + do i=1,iim + zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ) + s +flux_vQ_cum(i,j,l,iQ) + zqy= 0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+ + s Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l)) + zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy + s /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l))) + zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy + enddo +c print*,'aOK' +c Decomposition + zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l) + zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l) + zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l) + zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l) + zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l) + zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ) + enddo + enddo +c fonction de courant meridienne pour la quantite Q + do l=llm,1,-1 + do j=jjb,jje + psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ) + enddo + enddo + enddo + +c fonction de courant pour la circulation meridienne moyenne + psi(jjb:jje,:)=0. + do l=llm,1,-1 + do j=jjb,jje + psi(j,l)=psi(j,l+1)+zv(j,l) + zv(j,l)=zv(j,l)*zfactv(j,l) + enddo + enddo + +c print*,'4OK' +c sorties proprement dites + if (i_sortie.eq.1) then + jjb=jj_begin + jje=jj_end + jjn=jj_nb + if (pole_sud) jje=jj_end-1 + if (pole_sud) jjn=jj_nb-1 + + do iQ=1,nQ + do itr=1,ntr + call histwrite(fileid,znom(itr,iQ),itau, + s zvQ(jjb:jje,:,itr,iQ) + s ,jjn*llm,ndex3d) + enddo + call histwrite(fileid,'psi'//nom(iQ), + s itau,psiQ(jjb:jje,1:llm,iQ) + s ,jjn*llm,ndex3d) + enddo + + call histwrite(fileid,'masse',itau,zmasse(jjb:jje,1:llm) + s ,jjn*llm,ndex3d) + call histwrite(fileid,'v',itau,zv(jjb:jje,1:llm) + s ,jjn*llm,ndex3d) + psi(jjb:jje,:)=psi(jjb:jje,:)*1.e-9 + call histwrite(fileid,'psi',itau,psi(jjb:jje,1:llm), + s jjn*llm,ndex3d) + + endif + + +c ----------------- +c Moyenne verticale +c ----------------- + + zamasse(jjb:jje)=0. + do l=1,llm + zamasse(jjb:jje)=zamasse(jjb:jje)+zmasse(jjb:jje,l) + enddo + + zavQ(jjb:jje,:,:)=0. + do iQ=1,nQ + do itr=2,ntr + do l=1,llm + zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ) + s +zvQ(jjb:jje,l,itr,iQ) + s *zmasse(jjb:jje,l) + enddo + zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ)/zamasse(jjb:jje) + call histwrite(fileid,'a'//znom(itr,iQ),itau, + s zavQ(jjb:jje,itr,iQ),jjn*llm,ndex3d) + enddo + enddo + +c on doit pouvoir tracer systematiquement la fonction de courant. + +c===================================================================== +c///////////////////////////////////////////////////////////////////// + icum=0 !/////////////////////////////////////// + endif ! icum.eq.ncum !/////////////////////////////////////// +c///////////////////////////////////////////////////////////////////// +c===================================================================== + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/caladvtrac_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/caladvtrac_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/caladvtrac_p.F (revision 1280) @@ -0,0 +1,137 @@ +! +! $Header$ +! +c +c + SUBROUTINE caladvtrac_p(q,pbaru,pbarv , + * p ,masse, dq , teta, + * flxw, pk, iapptrac) + USE parallel + USE infotrac +c + IMPLICIT NONE +c +c Auteurs: F.Hourdin , P.Le Van, F.Forget, F.Codron +c +c F.Codron (10/99) : ajout humidite specifique pour eau vapeur +c======================================================================= +c +c Shema de Van Leer +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "control.h" + +c Arguments: +c ---------- + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm),masse(ip1jmp1,llm) + REAL p( ip1jmp1,llmp1),q( ip1jmp1,llm,nqtot),dq( ip1jmp1,llm,2 ) + REAL teta( ip1jmp1,llm),pk( ip1jmp1,llm) + REAL :: flxw(ip1jmp1,llm) + + integer ijb,ije,jjb,jje + +c .................................................................. +c +c .. dq n'est utilise et dimensionne que pour l'eau vapeur et liqu. +c +c .................................................................. +c +c Local: +c ------ + + INTEGER ij,l, iq, iapptrac + REAL finmasse(ip1jmp1,llm), dtvrtrac + +cc +c +C initialisation +cym ijb=ij_begin +cym ije=ij_end + + +cym dq(ijb:ije,1:llm,1:2)=q(ijb:ije,1:llm,1:2) + +c test des valeurs minmax +cc CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur (a) ') +cc CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide(a) ') + +c advection +c print *,'appel a advtrac' + + CALL advtrac_p( pbaru,pbarv, + * p, masse,q,iapptrac, teta, + . flxw, pk) + + goto 9999 + IF( iapptrac.EQ.iapp_tracvl ) THEN +c +cc CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur ') +cc CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide ') + +cc .... Calcul de deltap qu'on stocke dans finmasse ... +c + DO l = 1, llm + DO ij = ijb, ije + finmasse(ij,l) = p(ij,l) - p(ij,l+1) + ENDDO + ENDDO + + if (planet_type.eq."earth") then +! Earth-specific treatment of first 2 tracers (water) + CALL qminimum_p( q, 2, finmasse ) + endif + + +cym --> le reste ne set a rien + goto 9999 + +c CALL SCOPY ( ip1jmp1*llm, masse, 1, finmasse, 1 ) + finmasse(ijb:ije,:)=masse(ijb:ije,:) + + jjb=jj_begin + jje=jj_end + CALL filtreg_p ( finmasse ,jjb,jje, jjp1, llm, + * -2, 2, .TRUE., 1 ) +c +c ***** Calcul de dq pour l'eau , pour le passer a la physique ****** +c ******************************************************************** +c + dtvrtrac = iapp_tracvl * dtvr +c + DO iq = 1 , 2 + DO l = 1 , llm + DO ij = ijb,ije + dq(ij,l,iq) = ( q(ij,l,iq) - dq(ij,l,iq) ) * finmasse(ij,l) + * / dtvrtrac + ENDDO + ENDDO + ENDDO +c + ELSE +cym --> le reste ne set a rien + goto 9999 + + DO iq = 1 , 2 + DO l = 1, llm + DO ij = ijb,ije + dq(ij,l,iq) = 0. + ENDDO + ENDDO + ENDDO + + ENDIF +c + + +c ... On appelle qminimum uniquement pour l'eau vapeur et liquide .. + + + 9999 RETURN + END + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/caldyn0.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/caldyn0.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/caldyn0.F (revision 1280) @@ -0,0 +1,89 @@ +! +! $Header$ +! + SUBROUTINE caldyn0 + $ (itau,ucov,vcov,teta,ps,masse,pk,phis , + $ phi,w,pbaru,pbarv,time ) + + IMPLICIT NONE + +c======================================================================= +c +c Auteur : P. Le Van +c +c Objet: +c ------ +c +c Calcul des tendances dynamiques. +c +c Modif 04/93 F.Forget +c======================================================================= + +c----------------------------------------------------------------------- +c 0. Declarations: +c ---------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER itau + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL pk(iip1,jjp1,llm) + REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL time + +c Local: +c ------ + + REAL ang(ip1jmp1,llm),p(ip1jmp1,llmp1) + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm) + REAL vorpot(ip1jm,llm) + REAL w(ip1jmp1,llm),ecin(ip1jmp1,llm),convm(ip1jmp1,llm) + REAL bern(ip1jmp1,llm) + REAL massebxy(ip1jm,llm), dp(ip1jmp1) + + + INTEGER ij,l + +c----------------------------------------------------------------------- +c Calcul des tendances dynamiques: +c -------------------------------- + + CALL covcont ( llm , ucov , vcov , ucont, vcont ) + CALL pression ( ip1jmp1, ap , bp , ps , p ) + CALL psextbar ( ps , psexbarxy ) + CALL massdair ( p , masse ) + CALL massbar ( masse, massebx , masseby ) + CALL massbarxy( masse, massebxy ) + CALL flumass ( massebx, masseby , vcont, ucont ,pbaru, pbarv ) + CALL convmas ( pbaru, pbarv , convm ) + + DO ij =1, ip1jmp1 + dp( ij ) = convm( ij,1 ) / airesurg( ij ) + ENDDO + + CALL vitvert ( convm , w ) + CALL tourpot ( vcov , ucov , massebxy , vorpot ) + CALL enercin ( vcov , ucov , vcont , ucont , ecin ) + CALL bernoui ( ip1jmp1, llm , phi , ecin , bern ) + + DO l=1,llm + DO ij=1,ip1jmp1 + ang(ij,l) = ucov(ij,l) + constang(ij) + ENDDO + ENDDO + + CALL sortvarc0 + $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov ) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/caldyn_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/caldyn_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/caldyn_p.F (revision 1280) @@ -0,0 +1,191 @@ +! +! $Header$ +! +c +c +#undef DEBUG_IO +c#define DEBUG_IO + + SUBROUTINE caldyn_p + $ (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , + $ phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time ) + USE parallel + USE Write_Field_p + + IMPLICIT NONE + +c======================================================================= +c +c Auteur : P. Le Van +c +c Objet: +c ------ +c +c Calcul des tendances dynamiques. +c +c Modif 04/93 F.Forget +c======================================================================= + +c----------------------------------------------------------------------- +c 0. Declarations: +c ---------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + LOGICAL conser + + INTEGER itau + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL pk(iip1,jjp1,llm),pkf(ip1jmp1,llm) + REAL,SAVE :: vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL dv(ip1jm,llm),du(ip1jmp1,llm) + REAL dteta(ip1jmp1,llm),dp(ip1jmp1) + REAL w(ip1jmp1,llm) + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL time + +c Local: +c ------ + + REAL,SAVE :: ang(ip1jmp1,llm) + REAL,SAVE :: p(ip1jmp1,llmp1) + REAL,SAVE :: massebx(ip1jmp1,llm),masseby(ip1jm,llm) + REAL,SAVE :: psexbarxy(ip1jm) + REAL,SAVE :: vorpot(ip1jm,llm) + REAL,SAVE :: ecin(ip1jmp1,llm) + REAL,SAVE :: bern(ip1jmp1,llm) + REAL,SAVE :: massebxy(ip1jm,llm) + REAL,SAVE :: convm(ip1jmp1,llm) + INTEGER ij,l,ijb,ije,ierr + +c----------------------------------------------------------------------- +c Calcul des tendances dynamiques: +c -------------------------------- + CALL covcont_p ( llm , ucov , vcov , ucont, vcont ) + CALL pression_p ( ip1jmp1, ap , bp , ps , p ) +cym CALL psextbar ( ps , psexbarxy ) +c$OMP BARRIER + CALL massdair_p ( p , masse ) + CALL massbar_p ( masse, massebx , masseby ) + call massbarxy_p( masse, massebxy ) + CALL flumass_p ( massebx, masseby , vcont, ucont ,pbaru, pbarv ) + CALL dteta1_p ( teta , pbaru , pbarv, dteta ) + CALL convmas1_p ( pbaru, pbarv , convm ) +c$OMP BARRIER + CALL convmas2_p ( convm ) +c$OMP BARRIER +#ifdef DEBUG_IO +c$OMP BARRIER +c$OMP MASTER + call WriteField_p('ucont',reshape(ucont,(/iip1,jmp1,llm/))) + call WriteField_p('vcont',reshape(vcont,(/iip1,jjm,llm/))) + call WriteField_p('p',reshape(p,(/iip1,jmp1,llmp1/))) + call WriteField_p('masse',reshape(masse,(/iip1,jmp1,llm/))) + call WriteField_p('massebx',reshape(massebx,(/iip1,jmp1,llm/))) + call WriteField_p('masseby',reshape(masseby,(/iip1,jjm,llm/))) + call WriteField_p('massebxy',reshape(massebxy,(/iip1,jjm,llm/))) + call WriteField_p('pbaru',reshape(pbaru,(/iip1,jmp1,llm/))) + call WriteField_p('pbarv',reshape(pbarv,(/iip1,jjm,llm/))) + call WriteField_p('dteta',reshape(dteta,(/iip1,jmp1,llm/))) + call WriteField_p('convm',reshape(convm,(/iip1,jmp1,llm/))) +c$OMP END MASTER +c$OMP BARRIER +#endif + +c$OMP BARRIER +c$OMP MASTER + ijb=ij_begin + ije=ij_end + + DO ij =ijb, ije + dp( ij ) = convm( ij,1 ) / airesurg( ij ) + ENDDO +c$OMP END MASTER +c$OMP BARRIER +c$OMP FLUSH + CALL vitvert_p ( convm , w ) + CALL tourpot_p ( vcov , ucov , massebxy , vorpot ) + CALL dudv1_p ( vorpot , pbaru , pbarv , du , dv ) + +#ifdef DEBUG_IO +c$OMP BARRIER +c$OMP MASTER + call WriteField_p('w',reshape(w,(/iip1,jmp1,llm/))) + call WriteField_p('vorpot',reshape(vorpot,(/iip1,jjm,llm/))) + call WriteField_p('du',reshape(du,(/iip1,jmp1,llm/))) + call WriteField_p('dv',reshape(dv,(/iip1,jjm,llm/))) +c$OMP END MASTER +c$OMP BARRIER +#endif + CALL enercin_p ( vcov , ucov , vcont , ucont , ecin ) + CALL bernoui_p ( ip1jmp1, llm , phi , ecin , bern ) + CALL dudv2_p ( teta , pkf , bern , du , dv ) + +#ifdef DEBUG_IO +c$OMP BARRIER +c$OMP MASTER + call WriteField_p('ecin',reshape(ecin,(/iip1,jmp1,llm/))) + call WriteField_p('bern',reshape(bern,(/iip1,jmp1,llm/))) + call WriteField_p('du',reshape(du,(/iip1,jmp1,llm/))) + call WriteField_p('dv',reshape(dv,(/iip1,jjm,llm/))) + call WriteField_p('pkf',reshape(pkf,(/iip1,jmp1,llm/))) +c$OMP END MASTER +c$OMP BARRIER +#endif + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + ang(ij,l) = ucov(ij,l) + constang(ij) + ENDDO + ENDDO +c$OMP END DO + + CALL advect_new_p(ang,vcov,teta,w,massebx,masseby,du,dv,dteta) + +C WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi +C probablement. Observe sur le code compile avec pgf90 3.0-1 + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije, iip1 + IF( dv(ij,l).NE.dv(ij+iim,l) ) THEN +c PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov', +c , ' dans caldyn' +c PRINT *,' l, ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l) + dv(ij+iim,l) = dv(ij,l) + endif + enddo + enddo +c$OMP END DO NOWAIT +c----------------------------------------------------------------------- +c Sorties eventuelles des variables de controle: +c ---------------------------------------------- + + IF( conser ) THEN +c ym ---> exige communication collective ( aussi dans advect) + CALL sortvarc + $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov ) + + ENDIF + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/calfis_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/calfis_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/calfis_p.F (revision 1280) @@ -0,0 +1,1054 @@ +! +! $Id$ +! +C +C + SUBROUTINE calfis_p(lafin, + $ jD_cur, jH_cur, + $ pucov, + $ pvcov, + $ pteta, + $ pq, + $ pmasse, + $ pps, + $ pp, + $ ppk, + $ pphis, + $ pphi, + $ pducov, + $ pdvcov, + $ pdteta, + $ pdq, + $ flxw, + $ clesphy0, + $ pdufi, + $ pdvfi, + $ pdhfi, + $ pdqfi, + $ pdpsfi) +#ifdef CPP_EARTH +! Ehouarn: For now, calfis_p needs Earth physics +c +c Auteur : P. Le Van, F. Hourdin +c ......... + USE dimphy + USE mod_phys_lmdz_para, mpi_root_xx=>mpi_root + USE parallel, ONLY : omp_chunk, using_mpi + USE mod_interface_dyn_phys + USE Write_Field + Use Write_field_p + USE Times + USE IOPHY + USE infotrac + + IMPLICIT NONE +c======================================================================= +c +c 1. rearrangement des tableaux et transformation +c variables dynamiques > variables physiques +c 2. calcul des termes physiques +c 3. retransformation des tendances physiques en tendances dynamiques +c +c remarques: +c ---------- +c +c - les vents sont donnes dans la physique par leurs composantes +c naturelles. +c - la variable thermodynamique de la physique est une variable +c intensive : T +c pour la dynamique on prend T * ( preff / p(l) ) **kappa +c - les deux seules variables dependant de la geometrie necessaires +c pour la physique sont la latitude pour le rayonnement et +c l'aire de la maille quand on veut integrer une grandeur +c horizontalement. +c - les points de la physique sont les points scalaires de la +c la dynamique; numerotation: +c 1 pour le pole nord +c (jjm-1)*iim pour l'interieur du domaine +c ngridmx pour le pole sud +c ---> ngridmx=2+(jjm-1)*iim +c +c Input : +c ------- +c ecritphy frequence d'ecriture (en jours)de histphy +c pucov covariant zonal velocity +c pvcov covariant meridional velocity +c pteta potential temperature +c pps surface pressure +c pmasse masse d'air dans chaque maille +c pts surface temperature (K) +c callrad clef d'appel au rayonnement +c +c Output : +c -------- +c pdufi tendency for the natural zonal velocity (ms-1) +c pdvfi tendency for the natural meridional velocity +c pdhfi tendency for the potential temperature +c pdtsfi tendency for the surface temperature +c +c pdtrad radiative tendencies \ both input +c pfluxrad radiative fluxes / and output +c +c======================================================================= +c +c----------------------------------------------------------------------- +c +c 0. Declarations : +c ------------------ + +#include "dimensions.h" +#include "paramet.h" +#include "temps.h" + + INTEGER ngridmx + PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm ) + +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" +#include "control.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif +c Arguments : +c ----------- + LOGICAL lafin + REAL heure + + REAL pvcov(iip1,jjm,llm) + REAL pucov(iip1,jjp1,llm) + REAL pteta(iip1,jjp1,llm) + REAL pmasse(iip1,jjp1,llm) + REAL pq(iip1,jjp1,llm,nqtot) + REAL pphis(iip1,jjp1) + REAL pphi(iip1,jjp1,llm) +c + REAL pdvcov(iip1,jjm,llm) + REAL pducov(iip1,jjp1,llm) + REAL pdteta(iip1,jjp1,llm) + REAL pdq(iip1,jjp1,llm,nqtot) +c + REAL pps(iip1,jjp1) + REAL pp(iip1,jjp1,llmp1) + REAL ppk(iip1,jjp1,llm) +c + REAL pdvfi(iip1,jjm,llm) + REAL pdufi(iip1,jjp1,llm) + REAL pdhfi(iip1,jjp1,llm) + REAL pdqfi(iip1,jjp1,llm,nqtot) + REAL pdpsfi(iip1,jjp1) + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + + +c Local variables : +c ----------------- + + INTEGER i,j,l,ig0,ig,iq,iiq + REAL,ALLOCATABLE,SAVE :: zpsrf(:) + REAL,ALLOCATABLE,SAVE :: zplev(:,:),zplay(:,:) + REAL,ALLOCATABLE,SAVE :: zphi(:,:),zphis(:) +c + REAL,ALLOCATABLE,SAVE :: zufi(:,:), zvfi(:,:) + REAL,ALLOCATABLE,SAVE :: ztfi(:,:),zqfi(:,:,:) +c + REAL,ALLOCATABLE,SAVE :: pcvgu(:,:), pcvgv(:,:) + REAL,ALLOCATABLE,SAVE :: pcvgt(:,:), pcvgq(:,:,:) +c + REAL,ALLOCATABLE,SAVE :: zdufi(:,:),zdvfi(:,:) + REAL,ALLOCATABLE,SAVE :: zdtfi(:,:),zdqfi(:,:,:) + REAL,ALLOCATABLE,SAVE :: zdpsrf(:) + REAL,SAVE,ALLOCATABLE :: flxwfi(:,:) ! Flux de masse verticale sur la grille physiq + +c + REAL,ALLOCATABLE,SAVE :: zplev_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zplay_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zphi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zphis_omp(:) + REAL,ALLOCATABLE,SAVE :: presnivs_omp(:) + REAL,ALLOCATABLE,SAVE :: zufi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zvfi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: ztfi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zqfi_omp(:,:,:) + REAL,ALLOCATABLE,SAVE :: zdufi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdvfi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdtfi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdqfi_omp(:,:,:) + REAL,ALLOCATABLE,SAVE :: zdpsrf_omp(:) + REAL,SAVE,ALLOCATABLE :: flxwfi_omp(:,:) ! Flux de masse verticale sur la grille physiq + +c$OMP THREADPRIVATE(zplev_omp,zplay_omp,zphi_omp,zphis_omp, +c$OMP+ presnivs_omp,zufi_omp,zvfi_omp,ztfi_omp, +c$OMP+ zqfi_omp,zdufi_omp,zdvfi_omp, +c$OMP+ zdtfi_omp,zdqfi_omp,zdpsrf_omp,flxwfi_omp) + + LOGICAL,SAVE :: first_omp=.true. +c$OMP THREADPRIVATE(first_omp) + + REAL zsin(iim),zcos(iim),z1(iim) + REAL zsinbis(iim),zcosbis(iim),z1bis(iim) + REAL unskap, pksurcp +c +cIM diagnostique PVteta, Amip2 + INTEGER ntetaSTD + PARAMETER(ntetaSTD=3) + REAL rtetaSTD(ntetaSTD) + DATA rtetaSTD/350., 380., 405./ + REAL PVteta(klon,ntetaSTD) + + REAL flxw(iip1,jjp1,llm) ! Flux de masse verticale sur la grille dynamique + + REAL SSUM + + LOGICAL firstcal, debut + DATA firstcal/.true./ + SAVE firstcal,debut +c$OMP THREADPRIVATE(firstcal,debut) + REAL, intent(in):: jD_cur, jH_cur + + REAL,SAVE,dimension(1:iim,1:llm):: du_send,du_recv,dv_send,dv_recv + INTEGER :: ierr +#ifdef CPP_MPI + INTEGER,dimension(MPI_STATUS_SIZE,4) :: Status +#else + INTEGER,dimension(1,4) :: Status +#endif + INTEGER, dimension(4) :: Req + REAL,ALLOCATABLE,SAVE:: zdufi2(:,:),zdvfi2(:,:) + integer :: k,kstart,kend + INTEGER :: offset +c +c----------------------------------------------------------------------- +c +c 1. Initialisations : +c -------------------- +c + + klon=klon_mpi + + PVteta(:,:)=0. + +c + IF ( firstcal ) THEN + debut = .TRUE. + IF (ngridmx.NE.2+(jjm-1)*iim) THEN + PRINT*,'STOP dans calfis' + PRINT*,'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim' + PRINT*,' ngridmx jjm iim ' + PRINT*,ngridmx,jjm,iim + STOP + ENDIF +c$OMP MASTER + ALLOCATE(zpsrf(klon)) + ALLOCATE(zplev(klon,llm+1),zplay(klon,llm)) + ALLOCATE(zphi(klon,llm),zphis(klon)) + ALLOCATE(zufi(klon,llm), zvfi(klon,llm)) + ALLOCATE(ztfi(klon,llm),zqfi(klon,llm,nqtot)) + ALLOCATE(pcvgu(klon,llm), pcvgv(klon,llm)) + ALLOCATE(pcvgt(klon,llm), pcvgq(klon,llm,2)) + ALLOCATE(zdufi(klon,llm),zdvfi(klon,llm)) + ALLOCATE(zdtfi(klon,llm),zdqfi(klon,llm,nqtot)) + ALLOCATE(zdpsrf(klon)) + ALLOCATE(zdufi2(klon+iim,llm),zdvfi2(klon+iim,llm)) + ALLOCATE(flxwfi(klon,llm)) +c$OMP END MASTER +c$OMP BARRIER + ELSE + debut = .FALSE. + ENDIF + +c +c +c----------------------------------------------------------------------- +c 40. transformation des variables dynamiques en variables physiques: +c --------------------------------------------------------------- + +c 41. pressions au sol (en Pascals) +c ---------------------------------- + +c$OMP MASTER + call start_timer(timer_physic) +c$OMP END MASTER + +c$OMP MASTER +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + zpsrf(ig0)=pps(i,j) + enddo +c$OMP END MASTER + + +c 42. pression intercouches : +c +c ----------------------------------------------------------------- +c .... zplev definis aux (llm +1) interfaces des couches .... +c .... zplay definis aux ( llm ) milieux des couches .... +c ----------------------------------------------------------------- + +c ... Exner = cp * ( p(l) / preff ) ** kappa .... +c + unskap = 1./ kappa +c +c print *,omp_rank,'klon--->',klon +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llmp1 +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + zplev( ig0,l ) = pp(i,j,l) + enddo + ENDDO +c$OMP END DO NOWAIT +c +c + +c 43. temperature naturelle (en K) et pressions milieux couches . +c --------------------------------------------------------------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + pksurcp = ppk(i,j,l) / cpp + zplay(ig0,l) = preff * pksurcp ** unskap + ztfi(ig0,l) = pteta(i,j,l) * pksurcp + enddo + + ENDDO +c$OMP END DO NOWAIT + +c 43.bis traceurs +c --------------- +c + + DO iq=1,nqtot + iiq=niadv(iq) +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + zqfi(ig0,l,iq) = pq(i,j,l,iiq) + enddo + ENDDO +c$OMP END DO NOWAIT + ENDDO + + +c Geopotentiel calcule par rapport a la surface locale: +c ----------------------------------------------------- + + CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,pphi,zphi) + + CALL gr_dyn_fi_p(1,iip1,jjp1,klon,pphis,zphis) + +c$OMP BARRIER + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ig=1,klon + zphi(ig,l)=zphi(ig,l)-zphis(ig) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + +c +c 45. champ u: +c ------------ + + kstart=1 + kend=klon + + if (is_north_pole) kstart=2 + if (is_south_pole) kend=klon-1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) +!CDIR SPARSE + do ig0=kstart,kend + i=index_i(ig0) + j=index_j(ig0) + if (i==1) then + zufi(ig0,l)= 0.5 *( pucov(iim,j,l)/cu(iim,j) + $ + pucov(1,j,l)/cu(1,j) ) + else + zufi(ig0,l)= 0.5*( pucov(i-1,j,l)/cu(i-1,j) + $ + pucov(i,j,l)/cu(i,j) ) + endif + enddo + ENDDO +c$OMP END DO NOWAIT + +c 46.champ v: +c ----------- + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + DO ig0=kstart,kend + i=index_i(ig0) + j=index_j(ig0) + zvfi(ig0,l)= 0.5 *( pvcov(i,j-1,l)/cv(i,j-1) + $ + pvcov(i,j,l)/cv(i,j) ) + + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c 47. champs de vents aux pole nord +c ------------------------------ +c U = 1 / pi * integrale [ v * cos(long) * d long ] +c V = 1 / pi * integrale [ v * sin(long) * d long ] + + if (is_north_pole) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + z1(1) =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1) + DO i=2,iim + z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1) + ENDDO + + DO i=1,iim + zcos(i) = COS(rlonv(i))*z1(i) + zsin(i) = SIN(rlonv(i))*z1(i) + ENDDO + + zufi(1,l) = SSUM(iim,zcos,1)/pi + zvfi(1,l) = SSUM(iim,zsin,1)/pi + + ENDDO +c$OMP END DO NOWAIT + endif + + +c 48. champs de vents aux pole sud: +c --------------------------------- +c U = 1 / pi * integrale [ v * cos(long) * d long ] +c V = 1 / pi * integrale [ v * sin(long) * d long ] + + if (is_south_pole) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + z1(1) =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm) + DO i=2,iim + z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm) + ENDDO + + DO i=1,iim + zcos(i) = COS(rlonv(i))*z1(i) + zsin(i) = SIN(rlonv(i))*z1(i) + ENDDO + + zufi(klon,l) = SSUM(iim,zcos,1)/pi + zvfi(klon,l) = SSUM(iim,zsin,1)/pi + ENDDO +c$OMP END DO NOWAIT + endif + + + IF (is_sequential) THEN +c +cIM calcul PV a teta=350, 380, 405K + CALL PVtheta(ngridmx,llm,pucov,pvcov,pteta, + $ ztfi,zplay,zplev, + $ ntetaSTD,rtetaSTD,PVteta) +c + ENDIF + +c On change de grille, dynamique vers physiq, pour le flux de masse verticale + CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,flxw,flxwfi) + +c----------------------------------------------------------------------- +c Appel de la physique: +c --------------------- + + +c$OMP BARRIER + if (first_omp) then + klon=klon_omp + + allocate(zplev_omp(klon,llm+1)) + allocate(zplay_omp(klon,llm)) + allocate(zphi_omp(klon,llm)) + allocate(zphis_omp(klon)) + allocate(presnivs_omp(llm)) + allocate(zufi_omp(klon,llm)) + allocate(zvfi_omp(klon,llm)) + allocate(ztfi_omp(klon,llm)) + allocate(zqfi_omp(klon,llm,nqtot)) + allocate(zdufi_omp(klon,llm)) + allocate(zdvfi_omp(klon,llm)) + allocate(zdtfi_omp(klon,llm)) + allocate(zdqfi_omp(klon,llm,nqtot)) + allocate(zdpsrf_omp(klon)) + allocate(flxwfi_omp(klon,llm)) + first_omp=.false. + endif + + + klon=klon_omp + offset=klon_omp_begin-1 + + do l=1,llm+1 + do i=1,klon + zplev_omp(i,l)=zplev(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zplay_omp(i,l)=zplay(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zphi_omp(i,l)=zphi(offset+i,l) + enddo + enddo + + do i=1,klon + zphis_omp(i)=zphis(offset+i) + enddo + + + do l=1,llm + presnivs_omp(l)=presnivs(l) + enddo + + do l=1,llm + do i=1,klon + zufi_omp(i,l)=zufi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zvfi_omp(i,l)=zvfi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + ztfi_omp(i,l)=ztfi(offset+i,l) + enddo + enddo + + do iq=1,nqtot + do l=1,llm + do i=1,klon + zqfi_omp(i,l,iq)=zqfi(offset+i,l,iq) + enddo + enddo + enddo + + do l=1,llm + do i=1,klon + zdufi_omp(i,l)=zdufi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zdvfi_omp(i,l)=zdvfi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zdtfi_omp(i,l)=zdtfi(offset+i,l) + enddo + enddo + + do iq=1,nqtot + do l=1,llm + do i=1,klon + zdqfi_omp(i,l,iq)=zdqfi(offset+i,l,iq) + enddo + enddo + enddo + + do i=1,klon + zdpsrf_omp(i)=zdpsrf(offset+i) + enddo + + do l=1,llm + do i=1,klon + flxwfi_omp(i,l)=flxwfi(offset+i,l) + enddo + enddo + +c$OMP BARRIER + + if (planet_type=="earth") then +#ifdef CPP_EARTH + CALL physiq (klon, + . llm, + . debut, + . lafin, + . jD_cur, + . jH_cur, + . dtphys, + . zplev_omp, + . zplay_omp, + . zphi_omp, + . zphis_omp, + . presnivs_omp, + . clesphy0, + . zufi_omp, + . zvfi_omp, + . ztfi_omp, + . zqfi_omp, +c#ifdef INCA + . flxwfi_omp, +c#endif + . zdufi_omp, + . zdvfi_omp, + . zdtfi_omp, + . zdqfi_omp, + . zdpsrf_omp, +cIM diagnostique PVteta, Amip2 + . pducov, + . PVteta) +#endif + endif !of if (planet_type=="earth") +c$OMP BARRIER + + do l=1,llm+1 + do i=1,klon + zplev(offset+i,l)=zplev_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zplay(offset+i,l)=zplay_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zphi(offset+i,l)=zphi_omp(i,l) + enddo + enddo + + + do i=1,klon + zphis(offset+i)=zphis_omp(i) + enddo + + + do l=1,llm + presnivs(l)=presnivs_omp(l) + enddo + + do l=1,llm + do i=1,klon + zufi(offset+i,l)=zufi_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zvfi(offset+i,l)=zvfi_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + ztfi(offset+i,l)=ztfi_omp(i,l) + enddo + enddo + + do iq=1,nqtot + do l=1,llm + do i=1,klon + zqfi(offset+i,l,iq)=zqfi_omp(i,l,iq) + enddo + enddo + enddo + + do l=1,llm + do i=1,klon + zdufi(offset+i,l)=zdufi_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zdvfi(offset+i,l)=zdvfi_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zdtfi(offset+i,l)=zdtfi_omp(i,l) + enddo + enddo + + do iq=1,nqtot + do l=1,llm + do i=1,klon + zdqfi(offset+i,l,iq)=zdqfi_omp(i,l,iq) + enddo + enddo + enddo + + do i=1,klon + zdpsrf(offset+i)=zdpsrf_omp(i) + enddo + + + klon=klon_mpi +500 CONTINUE +c$OMP BARRIER + +c$OMP MASTER + call stop_timer(timer_physic) +c$OMP END MASTER + + IF (using_mpi) THEN + + if (MPI_rank>0) then + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + du_send(1:iim,l)=zdufi(1:iim,l) + dv_send(1:iim,l)=zdvfi(1:iim,l) + ENDDO +c$OMP END DO NOWAIT + +c$OMP BARRIER +#ifdef CPP_MPI +c$OMP MASTER +!$OMP CRITICAL (MPI) + call MPI_ISSEND(du_send,iim*llm,MPI_REAL8,MPI_Rank-1,401, + & COMM_LMDZ,Req(1),ierr) + call MPI_ISSEND(dv_send,iim*llm,MPI_REAL8,MPI_Rank-1,402, + & COMM_LMDZ,Req(2),ierr) +!$OMP END CRITICAL (MPI) +c$OMP END MASTER +#endif +c$OMP BARRIER + + endif + + if (MPI_rank0 .and. MPI_rank< MPI_Size-1) then + call MPI_WAITALL(4,Req(1),Status,ierr) + else if (MPI_rank>0) then + call MPI_WAITALL(2,Req(1),Status,ierr) + else if (MPI_rank filtre FFT désactivé " + use_filtre_fft=.FALSE. + ENDIF + + + +!Config Key = use_mpi_alloc +!Config Desc = Utilise un buffer MPI en m�moire globale +!Config Def = false +!Config Help = permet d'activer l'utilisation d'un buffer MPI +!Config en m�moire globale a l'aide de la fonction MPI_ALLOC. +!Config Cela peut am�liorer la bande passante des transferts MPI +!Config d'un facteur 2 + use_mpi_alloc=.FALSE. + CALL getin('use_mpi_alloc',use_mpi_alloc) + +!Config Key = omp_chunk +!Config Desc = taille des blocs openmp +!Config Def = 1 +!Config Help = defini la taille des packets d'it�ration openmp +!Config distribu�e � chaque t�che lors de l'entr�e dans une +!Config boucle parall�lis�e + + omp_chunk=1 + CALL getin('omp_chunk',omp_chunk) + +!Config key = ok_strato +!Config Desc = activation de la version strato +!Config Def = .FALSE. +!Config Help = active la version stratosphérique de LMDZ de F. Lott + + ok_strato=.FALSE. + CALL getin('ok_strato',ok_strato) + +!Config Key = ok_gradsfile +!Config Desc = activation des sorties grads du guidage +!Config Def = n +!Config Help = active les sorties grads du guidage + + ok_gradsfile = .FALSE. + CALL getin('ok_gradsfile',ok_gradsfile) + + write(lunout,*)' #########################################' + write(lunout,*)' Configuration des parametres du gcm: ' + write(lunout,*)' planet_type = ', planet_type + write(lunout,*)' calend = ', calend + write(lunout,*)' dayref = ', dayref + write(lunout,*)' anneeref = ', anneeref + write(lunout,*)' nday = ', nday + write(lunout,*)' day_step = ', day_step + write(lunout,*)' iperiod = ', iperiod + write(lunout,*)' iconser = ', iconser + write(lunout,*)' iecri = ', iecri + write(lunout,*)' periodav = ', periodav + write(lunout,*)' output_grads_dyn = ', output_grads_dyn + write(lunout,*)' idissip = ', idissip + write(lunout,*)' lstardis = ', lstardis + write(lunout,*)' nitergdiv = ', nitergdiv + write(lunout,*)' nitergrot = ', nitergrot + write(lunout,*)' niterh = ', niterh + write(lunout,*)' tetagdiv = ', tetagdiv + write(lunout,*)' tetagrot = ', tetagrot + write(lunout,*)' tetatemp = ', tetatemp + write(lunout,*)' coefdis = ', coefdis + write(lunout,*)' purmats = ', purmats + write(lunout,*)' read_start = ', read_start + write(lunout,*)' iflag_phys = ', iflag_phys + write(lunout,*)' iphysiq = ', iphysiq + write(lunout,*)' clon = ', clon + write(lunout,*)' clat = ', clat + write(lunout,*)' grossismx = ', grossismx + write(lunout,*)' grossismy = ', grossismy + write(lunout,*)' fxyhypb = ', fxyhypb + write(lunout,*)' dzoomx = ', dzoomx + write(lunout,*)' dzoomy = ', dzoomy + write(lunout,*)' taux = ', taux + write(lunout,*)' tauy = ', tauy + write(lunout,*)' offline = ', offline + write(lunout,*)' config_inca = ', config_inca + write(lunout,*)' ok_dynzon = ', ok_dynzon + write(lunout,*)' use_filtre_fft = ', use_filtre_fft + write(lunout,*)' use_mpi_alloc = ', use_mpi_alloc + write(lunout,*)' omp_chunk = ', omp_chunk + write(lunout,*)' ok_strato = ', ok_strato + write(lunout,*)' ok_gradsfile = ', ok_gradsfile +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/control.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/control.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/control.h (revision 1280) @@ -0,0 +1,29 @@ +! +! $Header$ +! +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez à n'utiliser que des ! pour les commentaires +! et à bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +!----------------------------------------------------------------------- +! INCLUDE 'control.h' + + COMMON/control/nday,day_step, & + & iperiod,iapp_tracvl,iconser,iecri,idissip,iphysiq , & + & periodav,iecrimoy,dayref,anneeref, & + & raz_date,offline,ip_ebil_dyn,config_inca, & + & planet_type,output_grads_dyn,ok_dynzon + + INTEGER nday,day_step,iperiod,iapp_tracvl,iconser,iecri, & + & idissip,iphysiq,iecrimoy,dayref,anneeref, raz_date & + & ,ip_ebil_dyn + REAL periodav + logical offline + CHARACTER (len=4) :: config_inca + CHARACTER(len=10) :: planet_type ! planet type ('earth','mars',...) + LOGICAL :: output_grads_dyn ! output dynamics diagnostics in + ! binary grads file 'dyn.dat' (y/n) + LOGICAL :: ok_dynzon +!----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convflu.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convflu.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convflu.F (revision 1280) @@ -0,0 +1,62 @@ +! +! $Header$ +! + SUBROUTINE convflu( xflu,yflu,nbniv,convfl ) +c +c P. Le Van +c +c +c ******************************************************************* +c ... calcule la (convergence horiz. * aire locale)du flux ayant pour +c composantes xflu et yflu ,variables extensives . ...... +c ******************************************************************* +c xflu , yflu et nbniv sont des arguments d'entree pour le s-pg .. +c convfl est un argument de sortie pour le s-pg . +c +c njxflu est le nombre de lignes de latitude de xflu, +c ( = jjm ou jjp1 ) +c nbniv est le nombre de niveaux vert. de xflu et de yflu . +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + REAL xflu,yflu,convfl,convpn,convps + INTEGER l,ij,nbniv + DIMENSION xflu( ip1jmp1,nbniv ),yflu( ip1jm,nbniv ) , + * convfl( ip1jmp1,nbniv ) +c + REAL SSUM +c +c +#include "comgeom.h" +c + DO 5 l = 1,nbniv +c + DO 2 ij = iip2, ip1jm - 1 + convfl( ij + 1,l ) = xflu( ij,l ) - xflu( ij + 1,l ) + + * yflu(ij +1,l ) - yflu( ij -iim,l ) + 2 CONTINUE +c +c + +c .... correction pour convfl( 1,j,l) ...... +c .... convfl(1,j,l)= convfl(iip1,j,l) ... +c +CDIR$ IVDEP + DO 3 ij = iip2,ip1jm,iip1 + convfl( ij,l ) = convfl( ij + iim,l ) + 3 CONTINUE +c +c ...... calcul aux poles ....... +c + convpn = SSUM( iim, yflu( 1 ,l ), 1 ) + convps = - SSUM( iim, yflu( ip1jm-iim,l ), 1 ) + DO 4 ij = 1,iip1 + convfl( ij ,l ) = convpn * aire( ij ) / apoln + convfl( ij+ ip1jm,l ) = convps * aire( ij+ ip1jm) / apols + 4 CONTINUE +c + 5 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convflu_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convflu_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convflu_p.F (revision 1280) @@ -0,0 +1,84 @@ + SUBROUTINE convflu_p( xflu,yflu,nbniv,convfl ) +c +c P. Le Van +c +c +c ******************************************************************* +c ... calcule la (convergence horiz. * aire locale)du flux ayant pour +c composantes xflu et yflu ,variables extensives . ...... +c ******************************************************************* +c xflu , yflu et nbniv sont des arguments d'entree pour le s-pg .. +c convfl est un argument de sortie pour le s-pg . +c +c njxflu est le nombre de lignes de latitude de xflu, +c ( = jjm ou jjp1 ) +c nbniv est le nombre de niveaux vert. de xflu et de yflu . +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + REAL xflu,yflu,convfl,convpn,convps + INTEGER l,ij,nbniv + DIMENSION xflu( ip1jmp1,nbniv ),yflu( ip1jm,nbniv ) , + * convfl( ip1jmp1,nbniv ) +c + INTEGER ijb,ije + EXTERNAL SSUM + REAL SSUM +c +c +#include "comgeom.h" +c + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,nbniv +c + ijb=ij_begin + ije=ij_end+iip1 + + IF (pole_nord) ijb=ij_begin+iip1 + IF (pole_sud) ije=ij_end-iip1 + + DO 2 ij = ijb , ije - 1 + convfl(ij+1,l) = xflu(ij,l) - xflu(ij+ 1,l) + + * yflu(ij +1,l ) - yflu( ij -iim,l ) + 2 CONTINUE +c +c + +c .... correction pour convfl( 1,j,l) ...... +c .... convfl(1,j,l)= convfl(iip1,j,l) ... +c +CDIR$ IVDEP + DO 3 ij = ijb,ije,iip1 + convfl( ij,l ) = convfl( ij + iim,l ) + 3 CONTINUE +c +c ...... calcul aux poles ....... +c + IF (pole_nord) THEN + + convpn = SSUM( iim, yflu( 1 ,l ), 1 ) + + DO ij = 1,iip1 + convfl(ij,l) = convpn * aire(ij) / apoln + ENDDO + + ENDIF + + IF (pole_sud) THEN + + convps = - SSUM( iim, yflu( ip1jm-iim,l ), 1 ) + + DO ij = 1,iip1 + convfl(ij+ip1jm,l) = convps * aire(ij+ ip1jm) / apols + ENDDO + + ENDIF + + 5 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convmas.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convmas.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convmas.F (revision 1280) @@ -0,0 +1,63 @@ +! +! $Header$ +! + SUBROUTINE convmas (pbaru, pbarv, convm ) +c + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************** +c .... calcul de la convergence du flux de masse aux niveaux p ... +c ******************************************************************** +c +c +c pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c ..... convm est un argument de sortie pour le s-pg .... +c +c le calcul se fait de haut en bas, +c la convergence de masse au niveau p(llm+1) est egale a 0. et +c n'est pas stockee dans le tableau convm . +c +c +c======================================================================= +c +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "logic.h" + + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ),convm( ip1jmp1,llm ) + INTEGER l,ij + + +c----------------------------------------------------------------------- +c .... calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ...... + + CALL convflu( pbaru, pbarv, llm, convm ) + +c----------------------------------------------------------------------- +c filtrage: +c --------- + + CALL filtreg( convm, jjp1, llm, 2, 2, .true., 1 ) + +c integration de la convergence de masse de haut en bas ...... + + DO l = llmm1, 1, -1 + DO ij = 1, ip1jmp1 + convm(ij,l) = convm(ij,l) + convm(ij,l+1) + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convmas1_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convmas1_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convmas1_p.F (revision 1280) @@ -0,0 +1,62 @@ + SUBROUTINE convmas1_p (pbaru, pbarv, convm ) +c + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************** +c .... calcul de la convergence du flux de masse aux niveaux p ... +c ******************************************************************** +c +c +c pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c ..... convm est un argument de sortie pour le s-pg .... +c +c le calcul se fait de haut en bas, +c la convergence de masse au niveau p(llm+1) est egale a 0. et +c n'est pas stockee dans le tableau convm . +c +c +c======================================================================= +c +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "logic.h" + + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ) + REAL, target :: convm( ip1jmp1,llm ) + INTEGER l,ij + + INTEGER ijb,ije,jjb,jje + + +c----------------------------------------------------------------------- +c .... calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ...... + + CALL convflu_p( pbaru, pbarv, llm, convm ) + +c----------------------------------------------------------------------- +c filtrage: +c --------- + + jjb=jj_begin + jje=jj_end+1 + if (pole_sud) jje=jj_end + + CALL filtreg_p( convm, jjb, jje, jjp1, llm, 2, 2, .true., 1 ) + +c integration de la convergence de masse de haut en bas ...... +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convmas2_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convmas2_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convmas2_p.F (revision 1280) @@ -0,0 +1,56 @@ + SUBROUTINE convmas2_p ( convm ) +c + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************** +c .... calcul de la convergence du flux de masse aux niveaux p ... +c ******************************************************************** +c +c +c pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c ..... convm est un argument de sortie pour le s-pg .... +c +c le calcul se fait de haut en bas, +c la convergence de masse au niveau p(llm+1) est egale a 0. et +c n'est pas stockee dans le tableau convm . +c +c +c======================================================================= +c +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "logic.h" + + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ) + REAL :: convm( ip1jmp1,llm ) + INTEGER l,ij + INTEGER ijb,ije,jjb,jje + +c$OMP MASTER +c integration de la convergence de masse de haut en bas ...... + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ij_end + + DO l = llmm1, 1, -1 + DO ij = ijb, ije + convm(ij,l) = convm(ij,l) + convm(ij,l+1) + ENDDO + ENDDO +c +c$OMP END MASTER + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convmas_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convmas_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/convmas_p.F (revision 1280) @@ -0,0 +1,71 @@ + SUBROUTINE convmas_p (pbaru, pbarv, convm ) +c + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************** +c .... calcul de la convergence du flux de masse aux niveaux p ... +c ******************************************************************** +c +c +c pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c ..... convm est un argument de sortie pour le s-pg .... +c +c le calcul se fait de haut en bas, +c la convergence de masse au niveau p(llm+1) est egale a 0. et +c n'est pas stockee dans le tableau convm . +c +c +c======================================================================= +c +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "logic.h" + + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ) + REAL, target :: convm( ip1jmp1,llm ) + INTEGER l,ij + + INTEGER ijb,ije,jjb,jje + + +c----------------------------------------------------------------------- +c .... calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ...... + + CALL convflu_p( pbaru, pbarv, llm, convm ) + +c----------------------------------------------------------------------- +c filtrage: +c --------- + + jjb=jj_begin + jje=jj_end+1 + if (pole_sud) jje=jj_end + + CALL filtreg_p( convm, jjb, jje, jjp1, llm, 2, 2, .true., 1 ) + +c integration de la convergence de masse de haut en bas ...... + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ij_end + + DO l = llmm1, 1, -1 + DO ij = ijb, ije + convm(ij,l) = convm(ij,l) + convm(ij,l+1) + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/coordij.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/coordij.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/coordij.F (revision 1280) @@ -0,0 +1,48 @@ +! +! $Header$ +! + SUBROUTINE coordij(lon,lat,ilon,jlat) + +c======================================================================= +c +c calcul des coordonnees i et j de la maille scalaire dans +c laquelle se trouve le point (lon,lat) en radian +c +c======================================================================= + + IMPLICIT NONE + REAL lon,lat + INTEGER ilon,jlat + INTEGER i,j + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "serre.h" + + real zlon,zlat + + zlon=lon*pi/180. + zlat=lat*pi/180. + + DO i=1,iim+1 + IF (rlonu(i).GT.zlon) THEN + ilon=i + GOTO 10 + ENDIF + ENDDO +10 CONTINUE + + j=0 + DO j=1,jjm + IF(rlatv(j).LT.zlat) THEN + jlat=j + GOTO 20 + ENDIF + ENDDO +20 CONTINUE + IF(j.EQ.0) j=jjm+1 + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/covcont.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/covcont.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/covcont.F (revision 1280) @@ -0,0 +1,43 @@ +! +! $Header$ +! + SUBROUTINE covcont (klevel,ucov, vcov, ucont, vcont ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c calcul des compos. contravariantes a partir des comp.covariantes +c ******************************************************************** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL ucov( ip1jmp1,klevel ), vcov( ip1jm,klevel ) + REAL ucont( ip1jmp1,klevel ), vcont( ip1jm,klevel ) + INTEGER l,ij + + + DO 10 l = 1,klevel + + DO 2 ij = iip2, ip1jm + ucont( ij,l ) = ucov( ij,l ) * unscu2( ij ) + 2 CONTINUE + + DO 4 ij = 1,ip1jm + vcont( ij,l ) = vcov( ij,l ) * unscv2( ij ) + 4 CONTINUE + + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/covcont_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/covcont_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/covcont_p.F (revision 1280) @@ -0,0 +1,59 @@ + SUBROUTINE covcont_p (klevel,ucov, vcov, ucont, vcont ) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c calcul des compos. contravariantes a partir des comp.covariantes +c ******************************************************************** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL ucov( ip1jmp1,klevel ), vcov( ip1jm,klevel ) + REAL ucont( ip1jmp1,klevel ), vcont( ip1jm,klevel ) + INTEGER l,ij + INTEGER ijb_u,ijb_v,ije_u,ije_v + + + ijb_u=ij_begin-iip1 + ijb_v=ij_begin-iip1 + ije_u=ij_end+iip1 + ije_v=ij_end+iip1 + + if (pole_nord) then + ijb_u=ij_begin+iip1 + ijb_v=ij_begin + endif + + if (pole_sud) then + ije_u=ij_end-iip1 + ije_v=ij_end-iip1 + endif + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel + + DO 2 ij = ijb_u,ije_u + ucont( ij,l ) = ucov( ij,l ) * unscu2( ij ) + 2 CONTINUE + + DO 4 ij = ijb_v,ije_v + vcont( ij,l ) = vcov( ij,l ) * unscv2( ij ) + 4 CONTINUE + + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/covnat_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/covnat_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/covnat_p.F (revision 1280) @@ -0,0 +1,76 @@ +! +! $Header$ +! + SUBROUTINE covnat_p(klevel,ucov, vcov, unat, vnat ) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteur: F Hourdin Phu LeVan +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c calcul des compos. naturelles a partir des comp.covariantes +c ******************************************************************** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL ucov( ip1jmp1,klevel ), vcov( ip1jm,klevel ) + REAL unat( ip1jmp1,klevel ), vnat( ip1jm,klevel ) + INTEGER l,ij + INTEGER :: ijb,ije + + + ijb=ij_begin + ije=ij_end + + if (pole_nord) then + DO l = 1,klevel + DO ij = 1, iip1 + unat (ij,l) =0. + END DO + ENDDO + endif + + if (pole_sud) then + DO l = 1,klevel + DO ij = ip1jm+1, ip1jmp1 + unat (ij,l) =0. + END DO + ENDDO + endif + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO l = 1,klevel + DO ij = ijb, ije + unat( ij,l ) = ucov( ij,l ) / cu(ij) + ENDDO + END DO + + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO l = 1,klevel + DO ij = ijb,ije + vnat( ij,l ) = vcov( ij,l ) / cv(ij) + ENDDO + + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/cray.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/cray.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/cray.F (revision 1280) @@ -0,0 +1,54 @@ +! +! $Header$ +! +#ifdef CRAY + SUBROUTINE riencray + END +#else + subroutine scopy(n,sx,incx,sy,incy) +c + IMPLICIT NONE +c + integer n,incx,incy,ix,iy,i + real sx((n-1)*incx+1),sy((n-1)*incy+1) +c + if (incx.eq.1.and.incy.eq.1) then + do 10 i=1,n + sy(i)=sx(i) +10 continue + else + iy=1 + ix=1 + do 11 i=1,n + sy(iy)=sx(ix) + ix=ix+incx + iy=iy+incy +11 continue + endif +c + return + end + + function ssum(n,sx,incx) +c + IMPLICIT NONE +c + integer n,incx,i,ix + real ssum,sx((n-1)*incx+1) +c + ssum=0. + if (incx.eq.1) then + do 10 i=1,n + ssum=ssum+sx(i) +10 continue + else + ix=1 + do 11 i=1,n + ssum=ssum+sx(ix) + ix=ix+incx +11 continue + endif +c + return + end +#endif Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/create_etat0_limit.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/create_etat0_limit.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/create_etat0_limit.F (revision 1280) @@ -0,0 +1,86 @@ +! +! $Id$ +! + PROGRAM create_etat0_limit +#ifdef CPP_EARTH +! This prog. is designed to work for Earth + USE dimphy + USE comgeomphy + USE mod_phys_lmdz_para + USE mod_const_mpi + USE infotrac +#ifdef CPP_IOIPSL + use ioipsl, only: ioconf_calendar +#endif + IMPLICIT NONE +c +c +c Programme d'appel a etat0, creation des etats initiaux et limit_netcdf +c +c +c interbar = .T . si appel a interpol. barycentrique inter_barxy +c +c extrap = .T . si on fait une extrapolation de donnees , comme pour +c les SST lorsque le fichier ne contient pas uniquement des points +c oceaniques . +c +c oldice = .T. si l'on veut garder les anciennes glaces , obtenues +c par grille_m ( grid_atob ) . +c +c on cree le masque dans etat0 que l'on passe ensuite dans limit pour +c garder les coherences + + LOGICAL interbar, extrap , oldice + PARAMETER ( interbar = .true. , extrap = .FALSE. , oldice=.false.) +#include "dimensions.h" +#include "paramet.h" +#include "indicesol.h" +#include "control.h" + REAL :: masque(iip1,jjp1) +! REAL :: pctsrf(iim*(jjm-1)+2, nbsrf) + + IF (config_inca /= 'none') THEN +#ifdef INCA + call init_const_lmdz( + $ nbtr,anneeref,dayref, + $ iphysiq, day_step,nday) +#endif + print *, 'nbtr =' , nbtr + END IF + + CALL init_mpi + + + CALL Init_Phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/)) + PRINT *,'---> klon=',klon + + IF (mpi_size>1 .OR. omp_size>1) THEN + CALL abort_gcm('create_etat0_limit','In parallel mode, + & create_etat0_limit must be called only + & for 1 process and 1 task') + ENDIF + call InitComgeomphy + +#ifdef CPP_IOIPSL + call ioconf_calendar('360d') +#endif + + WRITE(6,*) ' ********************* ' + WRITE(6,*) ' interbar = ',interbar + CALL etat0_netcdf ( interbar, masque ) +c + WRITE(6,1) + WRITE(6,*) ' ********************* ' + WRITE(6,*) ' *** Limit_netcdf *** ' + WRITE(6,*) ' ********************* ' + WRITE(6,1) + +c + CALL limit_netcdf ( interbar, extrap , oldice, masque) + +1 FORMAT(//) + +#endif +! of #ifdef CPP_EARTH + STOP + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/defrun.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/defrun.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/defrun.F (revision 1280) @@ -0,0 +1,497 @@ +! +! $Header$ +! +c +c + SUBROUTINE defrun( tapedef, etatinit, clesphy0 ) +c + IMPLICIT NONE +c----------------------------------------------------------------------- +c Auteurs : L. Fairhead , P. Le Van . +c +c Arguments : +c +c tapedef : +c etatinit : = TRUE , on ne compare pas les valeurs des para- +c -metres du zoom avec celles lues sur le fichier start . +c clesphy0 : sortie . +c + LOGICAL etatinit + INTEGER tapedef + + INTEGER longcles + PARAMETER( longcles = 20 ) + REAL clesphy0( longcles ) +c +c Declarations : +c -------------- +#include "dimensions.h" +#include "paramet.h" +#include "control.h" +#include "logic.h" +#include "serre.h" +#include "comdissnew.h" +#include "clesph0.h" +c +c +c local: +c ------ + + CHARACTER ch1*72,ch2*72,ch3*72,ch4*12 + INTEGER tapeout + REAL clonn,clatt,grossismxx,grossismyy + REAL dzoomxx,dzoomyy,tauxx,tauyy + LOGICAL fxyhypbb, ysinuss + INTEGER i + +c +c ------------------------------------------------------------------- +c +c ......... Version du 29/04/97 .......... +c +c Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot, +c tetatemp ajoutes pour la dissipation . +c +c Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** +c +c Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb. +c Sinon , choix de fxynew , a derivee sinusoidale .. +c +c ...... etatinit = . TRUE. si defrun est appele dans ETAT0_LMD ou +c LIMIT_LMD pour l'initialisation de start.dat (dic) et +c de limit.dat ( dic) ........... +c Sinon etatinit = . FALSE . +c +c Donc etatinit = .F. si on veut comparer les valeurs de grossismx , +c grossismy,clon,clat, fxyhypb lues sur le fichier start avec +c celles passees par run.def , au debut du gcm, apres l'appel a +c lectba . +c Ces parmetres definissant entre autres la grille et doivent etre +c pareils et coherents , sinon il y aura divergence du gcm . +c +c----------------------------------------------------------------------- +c initialisations: +c ---------------- + + tapeout = 6 + +c----------------------------------------------------------------------- +c Parametres de controle du run: +c----------------------------------------------------------------------- + + OPEN( tapedef,file ='gcm.def',status='old',form='formatted') + + + READ (tapedef,9000) ch1,ch2,ch3 + WRITE(tapeout,9000) ch1,ch2,ch3 + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dayref + WRITE(tapeout,9001) ch1,'dayref' + WRITE(tapeout,*) dayref + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) anneeref + WRITE(tapeout,9001) ch1,'anneeref' + WRITE(tapeout,*) anneeref + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nday + WRITE(tapeout,9001) ch1,'nday' + WRITE(tapeout,*) nday + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) day_step + WRITE(tapeout,9001) ch1,'day_step' + WRITE(tapeout,*) day_step + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iperiod + WRITE(tapeout,9001) ch1,'iperiod' + WRITE(tapeout,*) iperiod + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iapp_tracvl + WRITE(tapeout,9001) ch1,'iapp_tracvl' + WRITE(tapeout,*) iapp_tracvl + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iconser + WRITE(tapeout,9001) ch1,'iconser' + WRITE(tapeout,*) iconser + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iecri + WRITE(tapeout,9001) ch1,'iecri' + WRITE(tapeout,*) iecri + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) periodav + WRITE(tapeout,9001) ch1,'periodav' + WRITE(tapeout,*) periodav + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) idissip + WRITE(tapeout,9001) ch1,'idissip' + WRITE(tapeout,*) idissip + +ccc .... P. Le Van , modif le 29/04/97 .pour la dissipation ... +ccc + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) lstardis + WRITE(tapeout,9001) ch1,'lstardis' + WRITE(tapeout,*) lstardis + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nitergdiv + WRITE(tapeout,9001) ch1,'nitergdiv' + WRITE(tapeout,*) nitergdiv + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nitergrot + WRITE(tapeout,9001) ch1,'nitergrot' + WRITE(tapeout,*) nitergrot + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) niterh + WRITE(tapeout,9001) ch1,'niterh' + WRITE(tapeout,*) niterh + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tetagdiv + WRITE(tapeout,9001) ch1,'tetagdiv' + WRITE(tapeout,*) tetagdiv + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tetagrot + WRITE(tapeout,9001) ch1,'tetagrot' + WRITE(tapeout,*) tetagrot + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tetatemp + WRITE(tapeout,9001) ch1,'tetatemp' + WRITE(tapeout,*) tetatemp + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) coefdis + WRITE(tapeout,9001) ch1,'coefdis' + WRITE(tapeout,*) coefdis +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) purmats + WRITE(tapeout,9001) ch1,'purmats' + WRITE(tapeout,*) purmats + +c ............................................................... + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iflag_phys + WRITE(tapeout,9001) ch1,'iflag_phys' + WRITE(tapeout,*) iflag_phys + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iphysiq + WRITE(tapeout,9001) ch1,'iphysiq' + WRITE(tapeout,*) iphysiq + + +ccc .... P.Le Van, ajout le 03/01/96 pour l'ecriture phys ... +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) cycle_diurne + WRITE(tapeout,9001) ch1,'cycle_diurne' + WRITE(tapeout,*) cycle_diurne + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) soil_model + WRITE(tapeout,9001) ch1,'soil_model' + WRITE(tapeout,*) soil_model + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) new_oliq + WRITE(tapeout,9001) ch1,'new_oliq' + WRITE(tapeout,*) new_oliq + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ok_orodr + WRITE(tapeout,9001) ch1,'ok_orodr' + WRITE(tapeout,*) ok_orodr + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ok_orolf + WRITE(tapeout,9001) ch1,'ok_orolf' + WRITE(tapeout,*) ok_orolf + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ok_limitvrai + WRITE(tapeout,9001) ch1,'ok_limitvrai' + WRITE(tapeout,*) ok_limitvrai + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nbapp_rad + WRITE(tapeout,9001) ch1,'nbapp_rad' + WRITE(tapeout,*) nbapp_rad + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iflag_con + WRITE(tapeout,9001) ch1,'iflag_con' + WRITE(tapeout,*) iflag_con + + DO i = 1, longcles + clesphy0(i) = 0. + ENDDO + clesphy0(1) = FLOAT( iflag_con ) + clesphy0(2) = FLOAT( nbapp_rad ) + + IF( cycle_diurne ) clesphy0(3) = 1. + IF( soil_model ) clesphy0(4) = 1. + IF( new_oliq ) clesphy0(5) = 1. + IF( ok_orodr ) clesphy0(6) = 1. + IF( ok_orolf ) clesphy0(7) = 1. + IF( ok_limitvrai ) clesphy0(8) = 1. + + +ccc .... P. Le Van , ajout le 7/03/95 .pour le zoom ... +c ......... ( modif le 17/04/96 ) ......... +c + IF( etatinit ) GO TO 100 + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clonn + WRITE(tapeout,9001) ch1,'clon' + WRITE(tapeout,*) clonn + IF( ABS(clon - clonn).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de clon passee par run.def est diffe + *rente de celle lue sur le fichier start ' + STOP + ENDIF +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clatt + WRITE(tapeout,9001) ch1,'clat' + WRITE(tapeout,*) clatt + + IF( ABS(clat - clatt).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de clat passee par run.def est diffe + *rente de celle lue sur le fichier start ' + STOP + ENDIF + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismxx + WRITE(tapeout,9001) ch1,'grossismx' + WRITE(tapeout,*) grossismxx + + IF( ABS(grossismx - grossismxx).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de grossismx passee par run.def est + , differente de celle lue sur le fichier start ' + STOP + ENDIF + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismyy + WRITE(tapeout,9001) ch1,'grossismy' + WRITE(tapeout,*) grossismyy + + IF( ABS(grossismy - grossismyy).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de grossismy passee par run.def est + , differente de celle lue sur le fichier start ' + STOP + ENDIF + + IF( grossismx.LT.1. ) THEN + WRITE(tapeout,*) ' *** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + + IF( grossismy.LT.1. ) THEN + WRITE(tapeout,*) ' *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + +c +c alphax et alphay sont les anciennes formulat. des grossissements +c +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) fxyhypbb + WRITE(tapeout,9001) ch1,'fxyhypbb' + WRITE(tapeout,*) fxyhypbb + + IF( .NOT.fxyhypb ) THEN + IF( fxyhypbb ) THEN + WRITE(tapeout,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est F' + *, ' alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.fxyhypbb ) THEN + WRITE(tapeout,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est t' + *, ' alors qu il est F sur run.def ***' + STOP + ENDIF + ENDIF +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomxx + WRITE(tapeout,9001) ch1,'dzoomx' + WRITE(tapeout,*) dzoomxx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomyy + WRITE(tapeout,9001) ch1,'dzoomy' + WRITE(tapeout,*) dzoomyy + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tauxx + WRITE(tapeout,9001) ch1,'taux' + WRITE(tapeout,*) tauxx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tauyy + WRITE(tapeout,9001) ch1,'tauy' + WRITE(tapeout,*) tauyy + + IF( fxyhypb ) THEN + + IF( ABS(dzoomx - dzoomxx).GE. 0.001 ) THEN + WRITE(tapeout,*)' La valeur de dzoomx passee par run.def est dif + *ferente de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + IF( ABS(dzoomy - dzoomyy).GE. 0.001 ) THEN + WRITE(tapeout,*)' La valeur de dzoomy passee par run.def est dif + *ferente de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + IF( ABS(taux - tauxx).GE. 0.001 ) THEN + WRITE(6,*)' La valeur de taux passee par run.def est differente + * de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + IF( ABS(tauy - tauyy).GE. 0.001 ) THEN + WRITE(6,*)' La valeur de tauy passee par run.def est differente + * de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + ENDIF + +cc + IF( .NOT.fxyhypb ) THEN + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ysinuss + WRITE(tapeout,9001) ch1,'ysinus' + WRITE(tapeout,*) ysinuss + + + IF( .NOT.ysinus ) THEN + IF( ysinuss ) THEN + WRITE(6,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)'** ysinus lu sur le fichier start est F', + * ' alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.ysinuss ) THEN + WRITE(6,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)'** ysinus lu sur le fichier start est T', + * ' alors qu il est F sur run.def ***' + STOP + ENDIF + ENDIF + ENDIF +c + WRITE(6,*) ' alphax alphay defrun ',alphax,alphay + + CLOSE(tapedef) + + RETURN +c ............................................... +c +100 CONTINUE +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clon + WRITE(tapeout,9001) ch1,'clon' + WRITE(tapeout,*) clon +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clat + WRITE(tapeout,9001) ch1,'clat' + WRITE(tapeout,*) clat + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismx + WRITE(tapeout,9001) ch1,'grossismx' + WRITE(tapeout,*) grossismx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismy + WRITE(tapeout,9001) ch1,'grossismy' + WRITE(tapeout,*) grossismy + + IF( grossismx.LT.1. ) THEN + WRITE(tapeout,*) '*** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + IF( grossismy.LT.1. ) THEN + WRITE(tapeout,*) ' *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) fxyhypb + WRITE(tapeout,9001) ch1,'fxyhypb' + WRITE(tapeout,*) fxyhypb + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomx + WRITE(tapeout,9001) ch1,'dzoomx' + WRITE(tapeout,*) dzoomx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomy + WRITE(tapeout,9001) ch1,'dzoomy' + WRITE(tapeout,*) dzoomy + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) taux + WRITE(tapeout,9001) ch1,'taux' + WRITE(tapeout,*) taux +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tauy + WRITE(tapeout,9001) ch1,'tauy' + WRITE(tapeout,*) tauy + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ysinus + WRITE(tapeout,9001) ch1,'ysinus' + WRITE(tapeout,*) ysinus + + WRITE(tapeout,*) ' alphax alphay defrun ',alphax,alphay +c +9000 FORMAT(3(/,a72)) +9001 FORMAT(/,a72,/,a12) +cc + CLOSE(tapedef) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/description.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/description.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/description.h (revision 1280) @@ -0,0 +1,5 @@ +! +! $Header$ +! + character (len=120) :: descript + common /titre/descript Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/diagedyn.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/diagedyn.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/diagedyn.F (revision 1280) @@ -0,0 +1,321 @@ +! +! $Id$ +! + +C====================================================================== + SUBROUTINE diagedyn(tit,iprt,idiag,idiag2,dtime + e , ucov , vcov , ps, p ,pk , teta , q, ql) +C====================================================================== +C +C Purpose: +C Calcul la difference d'enthalpie et de masse d'eau entre 2 appels, +C et calcul le flux de chaleur et le flux d'eau necessaire a ces +C changements. Ces valeurs sont moyennees sur la surface de tout +C le globe et sont exprime en W/2 et kg/s/m2 +C Outil pour diagnostiquer la conservation de l'energie +C et de la masse dans la dynamique. +C +C +c====================================================================== +C Arguments: +C tit-----imput-A15- Comment added in PRINT (CHARACTER*15) +C iprt----input-I- PRINT level ( <=1 : no PRINT) +C idiag---input-I- indice dans lequel sera range les nouveaux +C bilans d' entalpie et de masse +C idiag2--input-I-les nouveaux bilans d'entalpie et de masse +C sont compare au bilan de d'enthalpie de masse de +C l'indice numero idiag2 +C Cas parriculier : si idiag2=0, pas de comparaison, on +c sort directement les bilans d'enthalpie et de masse +C dtime----input-R- time step (s) +C uconv, vconv-input-R- vents covariants (m/s) +C ps-------input-R- Surface pressure (Pa) +C p--------input-R- pressure at the interfaces +C pk-------input-R- pk= (p/Pref)**kappa +c teta-----input-R- potential temperature (K) +c q--------input-R- vapeur d'eau (kg/kg) +c ql-------input-R- liquid watter (kg/kg) +c aire-----input-R- mesh surafce (m2) +c +C the following total value are computed by UNIT of earth surface +C +C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy +c change (J/m2) during one time step (dtime) for the whole +C atmosphere (air, watter vapour, liquid and solid) +C d_qt------output-R- total water mass flux (kg/m2/s) defined as the +C total watter (kg/m2) change during one time step (dtime), +C d_qw------output-R- same, for the watter vapour only (kg/m2/s) +C d_ql------output-R- same, for the liquid watter only (kg/m2/s) +C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column +C +C +C J.L. Dufresne, July 2002 +c====================================================================== + + IMPLICIT NONE +C +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "iniprint.h" + +#ifdef CPP_EARTH +#include "../phylmd/YOMCST.h" +#include "../phylmd/YOETHF.h" +#endif +C + INTEGER imjmp1 + PARAMETER( imjmp1=iim*jjp1) +c Input variables + CHARACTER*15 tit + INTEGER iprt,idiag, idiag2 + REAL dtime + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL ps(ip1jmp1) ! pression au sol + REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL pk (ip1jmp1,llm ) ! = (p/Pref)**kappa + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL q(ip1jmp1,llm) ! champs eau vapeur + REAL ql(ip1jmp1,llm) ! champs eau liquide + + +c Output variables + REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec +C +C Local variables +c + REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + . , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot +c h_vcol_tot-- total enthalpy of vertical air column +C (air with watter vapour, liquid and solid) (J/m2) +c h_dair_tot-- total enthalpy of dry air (J/m2) +c h_qw_tot---- total enthalpy of watter vapour (J/m2) +c h_ql_tot---- total enthalpy of liquid watter (J/m2) +c h_qs_tot---- total enthalpy of solid watter (J/m2) +c qw_tot------ total mass of watter vapour (kg/m2) +c ql_tot------ total mass of liquid watter (kg/m2) +c qs_tot------ total mass of solid watter (kg/m2) +c ec_tot------ total cinetic energy (kg/m2) +C + REAL masse(ip1jmp1,llm) ! masse d'air + REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL ecin(ip1jmp1,llm) + + REAL zaire(imjmp1) + REAL zps(imjmp1) + REAL zairm(imjmp1,llm) + REAL zecin(imjmp1,llm) + REAL zpaprs(imjmp1,llm) + REAL zpk(imjmp1,llm) + REAL zt(imjmp1,llm) + REAL zh(imjmp1,llm) + REAL zqw(imjmp1,llm) + REAL zql(imjmp1,llm) + REAL zqs(imjmp1,llm) + + REAL zqw_col(imjmp1) + REAL zql_col(imjmp1) + REAL zqs_col(imjmp1) + REAL zec_col(imjmp1) + REAL zh_dair_col(imjmp1) + REAL zh_qw_col(imjmp1), zh_ql_col(imjmp1), zh_qs_col(imjmp1) +C + REAL d_h_dair, d_h_qw, d_h_ql, d_h_qs +C + REAL airetot, zcpvap, zcwat, zcice +C + INTEGER i, k, jj, ij , l ,ip1jjm1 +C + INTEGER ndiag ! max number of diagnostic in parallel + PARAMETER (ndiag=10) + integer pas(ndiag) + save pas + data pas/ndiag*0/ +C + REAL h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag) + $ , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag) + $ , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag) + SAVE h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre + $ , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre + + +#ifdef CPP_EARTH +c====================================================================== +C Compute Kinetic enrgy + CALL covcont ( llm , ucov , vcov , ucont, vcont ) + CALL enercin ( vcov , ucov , vcont , ucont , ecin ) + CALL massdair( p, masse ) +c====================================================================== +C +C + print*,'MAIS POURQUOI DONC DIAGEDYN NE MARCHE PAS ?' + return +C On ne garde les donnees que dans les colonnes i=1,iim + DO jj = 1,jjp1 + ip1jjm1=iip1*(jj-1) + DO ij = 1,iim + i=iim*(jj-1)+ij + zaire(i)=aire(ij+ip1jjm1) + zps(i)=ps(ij+ip1jjm1) + ENDDO + ENDDO +C 3D arrays + DO l = 1, llm + DO jj = 1,jjp1 + ip1jjm1=iip1*(jj-1) + DO ij = 1,iim + i=iim*(jj-1)+ij + zairm(i,l) = masse(ij+ip1jjm1,l) + zecin(i,l) = ecin(ij+ip1jjm1,l) + zpaprs(i,l) = p(ij+ip1jjm1,l) + zpk(i,l) = pk(ij+ip1jjm1,l) + zh(i,l) = teta(ij+ip1jjm1,l) + zqw(i,l) = q(ij+ip1jjm1,l) + zql(i,l) = ql(ij+ip1jjm1,l) + zqs(i,l) = 0. + ENDDO + ENDDO + ENDDO +C +C Reset variables + DO i = 1, imjmp1 + zqw_col(i)=0. + zql_col(i)=0. + zqs_col(i)=0. + zec_col(i) = 0. + zh_dair_col(i) = 0. + zh_qw_col(i) = 0. + zh_ql_col(i) = 0. + zh_qs_col(i) = 0. + ENDDO +C + zcpvap=RCPV + zcwat=RCW + zcice=RCS +C +C Compute vertical sum for each atmospheric column +C ================================================ + DO k = 1, llm + DO i = 1, imjmp1 +C Watter mass + zqw_col(i) = zqw_col(i) + zqw(i,k)*zairm(i,k) + zql_col(i) = zql_col(i) + zql(i,k)*zairm(i,k) + zqs_col(i) = zqs_col(i) + zqs(i,k)*zairm(i,k) +C Cinetic Energy + zec_col(i) = zec_col(i) + $ +zecin(i,k)*zairm(i,k) +C Air enthalpy + zt(i,k)= zh(i,k) * zpk(i,k) / RCPD + zh_dair_col(i) = zh_dair_col(i) + $ + RCPD*(1.-zqw(i,k)-zql(i,k)-zqs(i,k))*zairm(i,k)*zt(i,k) + zh_qw_col(i) = zh_qw_col(i) + $ + zcpvap*zqw(i,k)*zairm(i,k)*zt(i,k) + zh_ql_col(i) = zh_ql_col(i) + $ + zcwat*zql(i,k)*zairm(i,k)*zt(i,k) + $ - RLVTT*zql(i,k)*zairm(i,k) + zh_qs_col(i) = zh_qs_col(i) + $ + zcice*zqs(i,k)*zairm(i,k)*zt(i,k) + $ - RLSTT*zqs(i,k)*zairm(i,k) + + END DO + ENDDO +C +C Mean over the planete surface +C ============================= + qw_tot = 0. + ql_tot = 0. + qs_tot = 0. + ec_tot = 0. + h_vcol_tot = 0. + h_dair_tot = 0. + h_qw_tot = 0. + h_ql_tot = 0. + h_qs_tot = 0. + airetot=0. +C + do i=1,imjmp1 + qw_tot = qw_tot + zqw_col(i) + ql_tot = ql_tot + zql_col(i) + qs_tot = qs_tot + zqs_col(i) + ec_tot = ec_tot + zec_col(i) + h_dair_tot = h_dair_tot + zh_dair_col(i) + h_qw_tot = h_qw_tot + zh_qw_col(i) + h_ql_tot = h_ql_tot + zh_ql_col(i) + h_qs_tot = h_qs_tot + zh_qs_col(i) + airetot=airetot+zaire(i) + END DO +C + qw_tot = qw_tot/airetot + ql_tot = ql_tot/airetot + qs_tot = qs_tot/airetot + ec_tot = ec_tot/airetot + h_dair_tot = h_dair_tot/airetot + h_qw_tot = h_qw_tot/airetot + h_ql_tot = h_ql_tot/airetot + h_qs_tot = h_qs_tot/airetot +C + h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot +C +C Compute the change of the atmospheric state compare to the one +C stored in "idiag2", and convert it in flux. THis computation +C is performed IF idiag2 /= 0 and IF it is not the first CALL +c for "idiag" +C =================================== +C + IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN + d_h_vcol = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime + d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime + d_h_qw = (h_qw_tot - h_qw_pre(idiag2) )/dtime + d_h_ql = (h_ql_tot - h_ql_pre(idiag2) )/dtime + d_h_qs = (h_qs_tot - h_qs_pre(idiag2) )/dtime + d_qw = (qw_tot - qw_pre(idiag2) )/dtime + d_ql = (ql_tot - ql_pre(idiag2) )/dtime + d_qs = (qs_tot - qs_pre(idiag2) )/dtime + d_ec = (ec_tot - ec_pre(idiag2) )/dtime + d_qt = d_qw + d_ql + d_qs + ELSE + d_h_vcol = 0. + d_h_dair = 0. + d_h_qw = 0. + d_h_ql = 0. + d_h_qs = 0. + d_qw = 0. + d_ql = 0. + d_qs = 0. + d_ec = 0. + d_qt = 0. + ENDIF +C + IF (iprt.ge.2) THEN + WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs + 9000 format('Dyn3d. Watter Mass Budget (kg/m2/s)',A15 + $ ,1i6,10(1pE14.6)) + WRITE(6,9001) tit,pas(idiag), d_h_vcol + 9001 format('Dyn3d. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2)) + WRITE(6,9002) tit,pas(idiag), d_ec + 9002 format('Dyn3d. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2)) +C WRITE(6,9003) tit,pas(idiag), ec_tot + 9003 format('Dyn3d. Cinetic Energy (W/m2) ',A15,1i6,10(E15.6)) + WRITE(6,9004) tit,pas(idiag), d_h_vcol+d_ec + 9004 format('Dyn3d. Total Energy Budget (W/m2) ',A15,1i6,10(F8.2)) + END IF +C +C Store the new atmospheric state in "idiag" +C + pas(idiag)=pas(idiag)+1 + h_vcol_pre(idiag) = h_vcol_tot + h_dair_pre(idiag) = h_dair_tot + h_qw_pre(idiag) = h_qw_tot + h_ql_pre(idiag) = h_ql_tot + h_qs_pre(idiag) = h_qs_tot + qw_pre(idiag) = qw_tot + ql_pre(idiag) = ql_tot + qs_pre(idiag) = qs_tot + ec_pre (idiag) = ec_tot +C +#else + write(lunout,*)'diagedyn: Needs Earth physics to function' +#endif +! #endif of #ifdef CPP_EARTH + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dissip_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dissip_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dissip_p.F (revision 1280) @@ -0,0 +1,207 @@ + SUBROUTINE dissip_p( vcov,ucov,teta,p, dv,du,dh ) +c + USE parallel + USE write_field_p + IMPLICIT NONE + + +c .. Avec nouveaux operateurs star : gradiv2 , divgrad2, nxgraro2 ... +c ( 10/01/98 ) + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c Dissipation horizontale +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comdissnew.h" +#include "comdissipn.h" + +c Arguments: +c ---------- + + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL p( ip1jmp1,llmp1 ) + REAL dv(ip1jm,llm),du(ip1jmp1,llm),dh(ip1jmp1,llm) + +c Local: +c ------ + + REAL gdx(ip1jmp1,llm),gdy(ip1jm,llm) + REAL grx(ip1jmp1,llm),gry(ip1jm,llm) + REAL te1dt(llm),te2dt(llm),te3dt(llm) + REAL deltapres(ip1jmp1,llm) + + INTEGER l,ij + + REAL SSUM + integer :: ijb,ije +c----------------------------------------------------------------------- +c initialisations: +c ---------------- + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + te1dt(l) = tetaudiv(l) * dtdiss + te2dt(l) = tetaurot(l) * dtdiss + te3dt(l) = tetah(l) * dtdiss + ENDDO +c$OMP END DO NOWAIT +c CALL initial0( ijp1llm, du ) +c CALL initial0( ijmllm , dv ) +c CALL initial0( ijp1llm, dh ) + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + du(ijb:ije,l)=0 + dh(ijb:ije,l)=0 + ENDDO +c$OMP END DO NOWAIT + + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + dv(ijb:ije,l)=0 + ENDDO +c$OMP END DO NOWAIT + +c----------------------------------------------------------------------- +c Calcul de la dissipation: +c ------------------------- + +c Calcul de la partie grad ( div ) : +c ------------------------------------- + + + + IF(lstardis) THEN +c IF (.FALSE.) THEN + CALL gradiv2_p( llm,ucov,vcov,nitergdiv,gdx,gdy ) + ELSE + CALL gradiv_p ( llm,ucov,vcov,nitergdiv,gdx,gdy ) + ENDIF + + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + if (pole_nord) then + DO ij = 1, iip1 + gdx( ij ,l) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iip1 + gdx(ij+ip1jm,l) = 0. + ENDDO + endif + + if (pole_nord) ijb=ij_begin+iip1 + DO ij = ijb,ije + du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l) + ENDDO + + if (pole_nord) ijb=ij_begin + DO ij = ijb,ije + dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l) + ENDDO + + ENDDO +c$OMP END DO NOWAIT +c calcul de la partie n X grad ( rot ): +c --------------------------------------- + + IF(lstardis) THEN +c IF (.FALSE.) THEN + CALL nxgraro2_p( llm,ucov, vcov, nitergrot,grx,gry ) + ELSE + CALL nxgrarot_p( llm,ucov, vcov, nitergrot,grx,gry ) + ENDIF + + + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + if (pole_nord) then + DO ij = 1, iip1 + grx(ij,l) = 0. + ENDDO + endif + + if (pole_nord) ijb=ij_begin+iip1 + DO ij = ijb,ije + du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l) + ENDDO + + if (pole_nord) ijb=ij_begin + DO ij = ijb, ije + dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l) + ENDDO + + ENDDO +c$OMP END DO NOWAIT + +c calcul de la partie div ( grad ): +c ----------------------------------- + + + IF(lstardis) THEN +c IF (.FALSE.) THEN + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije + deltapres(ij,l) = AMAX1( 0., p(ij,l) - p(ij,l+1) ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + CALL divgrad2_p( llm,teta, deltapres ,niterh, gdx ) + ELSE + CALL divgrad_p ( llm,teta, niterh, gdx ) + ENDIF + +c call write_field3d_p('gdx2',reshape(gdx,(/iip1,jmp1,llm/))) +c stop + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + DO ij = ijb,ije + dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/disvert.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/disvert.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/disvert.F (revision 1280) @@ -0,0 +1,194 @@ +! +! $Id$ +! + SUBROUTINE disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig) + +c Auteur : P. Le Van . +c + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +#include "logic.h" +c +c======================================================================= +c +c +c s = sigma ** kappa : coordonnee verticale +c dsig(l) : epaisseur de la couche l ds la coord. s +c sig(l) : sigma a l'interface des couches l et l-1 +c ds(l) : distance entre les couches l et l-1 en coord.s +c +c======================================================================= +c + REAL pa,preff + REAL ap(llmp1),bp(llmp1),dpres(llm),nivsigs(llm),nivsig(llmp1) + REAL presnivs(llm) +c +c declarations: +c ------------- +c + REAL sig(llm+1),dsig(llm) + real zzz(1:llm+1) + real dzz(1:llm) + real zk,zkm1,dzk1,dzk2,k0,k1 +c + INTEGER l + REAL snorm,dsigmin + REAL alpha,beta,gama,delta,deltaz,h + INTEGER np,ierr + REAL pi,x + + REAL SSUM +c +c----------------------------------------------------------------------- +c + pi=2.*ASIN(1.) + + OPEN(99,file='sigma.def',status='old',form='formatted', + s iostat=ierr) + +c----------------------------------------------------------------------- +c cas 1 on lit les options dans sigma.def: +c ---------------------------------------- + + IF (ierr.eq.0) THEN + + READ(99,*) h ! hauteur d'echelle 8. + READ(99,*) deltaz ! epaiseur de la premiere couche 0.04 + READ(99,*) beta ! facteur d'acroissement en haut 1.3 + READ(99,*) k0 ! nombre de couches dans la transition surf + READ(99,*) k1 ! nombre de couches dans la transition haute + CLOSE(99) + alpha=deltaz/(llm*h) + write(lunout,*)'h,alpha,k0,k1,beta' + +c read(*,*) h,deltaz,beta,k0,k1 ! 8 0.04 4 20 1.2 + + alpha=deltaz/tanh(1./k0)*2. + zkm1=0. + sig(1)=1. + do l=1,llm + sig(l+1)=(cosh(l/k0))**(-alpha*k0/h) + + *exp(-alpha/h*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta)) + zk=-h*log(sig(l+1)) + + dzk1=alpha*tanh(l/k0) + dzk2=alpha*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta) + write(lunout,*)l,sig(l+1),zk,zk-zkm1,dzk1,dzk2 + zkm1=zk + enddo + + sig(llm+1)=0. + +c + DO 2 l = 1, llm + dsig(l) = sig(l)-sig(l+1) + 2 CONTINUE +c + + ELSE +c----------------------------------------------------------------------- +c cas 2 ancienne discretisation (LMD5...): +c ---------------------------------------- + + WRITE(LUNOUT,*)'WARNING!!! Ancienne discretisation verticale' + + if (ok_strato) then + if (llm==39) then + dsigmin=0.3 + else if (llm==50) then + dsigmin=1. + else + WRITE(LUNOUT,*) 'ATTENTION discretisation z a ajuster' + dsigmin=1. + endif + WRITE(LUNOUT,*) 'Discretisation verticale DSIGMIN=',dsigmin + endif + + h=7. + snorm = 0. + DO l = 1, llm + x = 2.*asin(1.) * (FLOAT(l)-0.5) / float(llm+1) + + IF (ok_strato) THEN + dsig(l) =(dsigmin + 7.0 * SIN(x)**2) + & *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2 + ELSE + dsig(l) = 1.0 + 7.0 * SIN(x)**2 + ENDIF + + snorm = snorm + dsig(l) + ENDDO + snorm = 1./snorm + DO l = 1, llm + dsig(l) = dsig(l)*snorm + ENDDO + sig(llm+1) = 0. + DO l = llm, 1, -1 + sig(l) = sig(l+1) + dsig(l) + ENDDO + + ENDIF + + + DO l=1,llm + nivsigs(l) = FLOAT(l) + ENDDO + + DO l=1,llmp1 + nivsig(l)= FLOAT(l) + ENDDO + +c +c .... Calculs de ap(l) et de bp(l) .... +c ......................................... +c +c +c ..... pa et preff sont lus sur les fichiers start par lectba ..... +c + + bp(llmp1) = 0. + + DO l = 1, llm +cc +ccc ap(l) = 0. +ccc bp(l) = sig(l) + + bp(l) = EXP( 1. -1./( sig(l)*sig(l)) ) + ap(l) = pa * ( sig(l) - bp(l) ) +c + ENDDO + + bp(1)=1. + ap(1)=0. + + ap(llmp1) = pa * ( sig(llmp1) - bp(llmp1) ) + + write(lunout,*)' BP ' + write(lunout,*) bp + write(lunout,*)' AP ' + write(lunout,*) ap + + write(lunout,*) + .'Niveaux de pressions approximatifs aux centres des' + write(lunout,*)'couches calcules pour une pression de surface =', + . preff + write(lunout,*) + . 'et altitudes equivalentes pour une hauteur d echelle de' + write(lunout,*)'8km' + DO l = 1, llm + dpres(l) = bp(l) - bp(l+1) + presnivs(l) = 0.5 *( ap(l)+bp(l)*preff + ap(l+1)+bp(l+1)*preff ) + write(lunout,*)'PRESNIVS(',l,')=',presnivs(l),' Z ~ ', + . log(preff/presnivs(l))*8. + . ,' DZ ~ ',8.*log((ap(l)+bp(l)*preff)/ + . max(ap(l+1)+bp(l+1)*preff,1.e-10)) + ENDDO + + write(lunout,*)' PRESNIVS ' + write(lunout,*)presnivs + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/diverg.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/diverg.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/diverg.F (revision 1280) @@ -0,0 +1,85 @@ +! +! $Header$ +! + SUBROUTINE diverg(klevel,x,y,div) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER l,ij +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps +c ................................................................... +c + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO ij = iip2, ip1jm - 1 + div( ij + 1, l ) = + * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + + * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + DO ij = 1,iim + aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) + aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) / apoln + sumyps = SSUM ( iim,aiy2,1 ) / apols +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + div( ij + ip1jm, l ) = sumyps + ENDDO + 10 CONTINUE +c + +ccc CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 ) + +c + DO l = 1, klevel + DO ij = iip2,ip1jm + div(ij,l) = div(ij,l) * unsaire(ij) + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/diverg_gam.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/diverg_gam.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/diverg_gam.F (revision 1280) @@ -0,0 +1,80 @@ +! +! $Header$ +! + SUBROUTINE diverg_gam(klevel,cuvscvgam,cvuscugam,unsairegam , + * unsapolnga,unsapolsga, x, y, div ) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1) + REAL unsapolnga,unsapolsga +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps + INTEGER l,ij +c ................................................................... +c + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO ij = iip2, ip1jm - 1 + div( ij + 1, l ) = ( + * cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) + + * cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* + * unsairegam( ij+1 ) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + DO ij = 1,iim + aiy1(ij) = cuvscvgam( ij ) * y( ij , l ) + aiy2(ij) = cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga + sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + div( ij + ip1jm, l ) = sumyps + ENDDO + 10 CONTINUE +c + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/diverg_gam_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/diverg_gam_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/diverg_gam_p.F (revision 1280) @@ -0,0 +1,97 @@ + SUBROUTINE diverg_gam_p(klevel,cuvscvgam,cvuscugam,unsairegam , + * unsapolnga,unsapolsga, x, y, div ) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + USE parallel + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1) + REAL unsapolnga,unsapolsga +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps + INTEGER l,ij +c ................................................................... +c + EXTERNAL SSUM + REAL SSUM + INTEGER :: ijb,ije,jjb,jje +c +c + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + div( ij + 1, l ) = ( + * cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) + + * cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* + * unsairegam( ij+1 ) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = ijb,ije,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + if (pole_nord) then + DO ij = 1,iim + aiy1(ij) = cuvscvgam( ij ) * y( ij , l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + ENDDO + endif + + if (pole_sud) then + DO ij = 1,iim + aiy2(ij) = cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga +c + DO ij = 1,iip1 + div( ij + ip1jm, l ) = sumyps + ENDDO + endif + 10 CONTINUE +c$OMP END DO NOWAIT +c + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/diverg_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/diverg_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/diverg_p.F (revision 1280) @@ -0,0 +1,106 @@ + SUBROUTINE diverg_p(klevel,x,y,div) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + USE parallel + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER l,ij +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps + INTEGER ijb,ije +c ................................................................... +c + EXTERNAL SSUM + REAL SSUM +c +c + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + div( ij + 1, l ) = + * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + + * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = ijb,ije,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + if (pole_nord) then + DO ij = 1,iim + aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) / apoln +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + ENDDO + endif + + if (pole_sud) then + DO ij = 1,iim + aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumyps = SSUM ( iim,aiy2,1 ) / apols +c + DO ij = 1,iip1 + div( ij + ip1jm, l ) = sumyps + ENDDO + endif + + + 10 CONTINUE +c$OMP END DO NOWAIT +c + +ccc CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 ) + +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb,ije + div(ij,l) = div(ij,l) * unsaire(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divergf.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divergf.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divergf.F (revision 1280) @@ -0,0 +1,85 @@ +! +! $Header$ +! + SUBROUTINE divergf(klevel,x,y,div) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER l,ij +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps +c ................................................................... +c + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO ij = iip2, ip1jm - 1 + div( ij + 1, l ) = + * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + + * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + DO ij = 1,iim + aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) + aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) / apoln + sumyps = SSUM ( iim,aiy2,1 ) / apols +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + div( ij + ip1jm, l ) = sumyps + ENDDO + 10 CONTINUE +c + + CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 ) + +c + DO l = 1, klevel + DO ij = iip2,ip1jm + div(ij,l) = div(ij,l) * unsaire(ij) + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divergf_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divergf_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divergf_p.F (revision 1280) @@ -0,0 +1,115 @@ + SUBROUTINE divergf_p(klevel,x,y,div) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + USE PARALLEL + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER l,ij +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps +c ................................................................... +c + EXTERNAL SSUM + REAL SSUM + INTEGER :: ijb,ije,jjb,jje +c +c + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + div( ij + 1, l ) = + * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + + * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) + ENDDO + +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = ijb,ije,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + if (pole_nord) then + + DO ij = 1,iim + aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) / apoln + +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + ENDDO + + endif + + if (pole_sud) then + + DO ij = 1,iim + aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumyps = SSUM ( iim,aiy2,1 ) / apols +c + DO ij = 1,iip1 + div( ij + ip1jm, l ) = sumyps + ENDDO + + endif + + 10 CONTINUE +c$OMP END DO NOWAIT + +c + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + CALL filtreg_p( div,jjb,jje, jjp1, klevel, 2, 2, .TRUE., 1 ) + +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb,ije + div(ij,l) = div(ij,l) * unsaire(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divergst.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divergst.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divergst.F (revision 1280) @@ -0,0 +1,62 @@ +! +! $Header$ +! + SUBROUTINE divergst(klevel,x,y,div) + IMPLICIT NONE +c +c P. Le Van +c +c ****************************************************************** +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. x et y... +c x et y etant des composantes contravariantes ... +c **************************************************************** +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c ------------------------------------------------------------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER ij,l,i + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps + + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO 1 ij = iip2, ip1jm - 1 + div( ij + 1, l ) = x(ij+1,l) - x(ij,l)+ y(ij-iim,l)-y(ij+1,l) + 1 CONTINUE +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO 3 ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + 3 CONTINUE +c +c .... calcul aux poles ..... +c +c + DO 5 i = 1,iim + aiy1(i)= y(i,l) + aiy2(i)= y(i+ip1jmi1,l) + 5 CONTINUE + sumypn = SSUM ( iim,aiy1,1 ) + sumyps = SSUM ( iim,aiy2,1 ) + DO 7 i = 1,iip1 + div( i , l ) = - sumypn/iim + div( i + ip1jm, l ) = sumyps/iim + 7 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divgrad.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divgrad.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divgrad.F (revision 1280) @@ -0,0 +1,56 @@ +! +! $Header$ +! + SUBROUTINE divgrad (klevel,h, lh, divgra ) + IMPLICIT NONE +c +c======================================================================= +c +c Auteur : P. Le Van +c ---------- +c +c lh +c calcul de (div( grad )) de h ..... +c h et lh sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c +c======================================================================= +c +c declarations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comdissipn.h" +#include "logic.h" +c + INTEGER klevel + REAL h( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) + + INTEGER l,ij,iter,lh +c +c +c + CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 ) +c + DO 10 iter = 1,lh + + CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1 ) + + CALL grad (klevel,divgra, ghx , ghy ) + CALL diverg (klevel, ghx , ghy , divgra ) + + CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1) + + DO 5 l = 1,klevel + DO 4 ij = 1, ip1jmp1 + divgra( ij,l ) = - cdivh * divgra( ij,l ) + 4 CONTINUE + 5 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divgrad2.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divgrad2.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divgrad2.F (revision 1280) @@ -0,0 +1,79 @@ +! +! $Header$ +! + SUBROUTINE divgrad2 ( klevel, h, deltapres, lh, divgra ) +c +c P. Le Van +c +c *************************************************************** +c +c ..... calcul de (div( grad )) de ( pext * h ) ..... +c **************************************************************** +c h ,klevel,lh et pext sont des arguments d'entree pour le s-prg +c divgra est un argument de sortie pour le s-prg +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comdissipn.h" + +c ....... variables en arguments ....... +c + INTEGER klevel + REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel ) + REAL divgra( ip1jmp1,klevel) +c +c ....... variables locales .......... +c + REAL signe, nudivgrs, sqrtps( ip1jmp1,llm ) + INTEGER l,ij,iter,lh +c ................................................................... + +c + signe = (-1.)**lh + nudivgrs = signe * cdivh + + CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 ) + +c + CALL laplacien( klevel, divgra, divgra ) + + DO l = 1, klevel + DO ij = 1, ip1jmp1 + sqrtps( ij,l ) = SQRT( deltapres(ij,l) ) + ENDDO + ENDDO +c + DO l = 1, klevel + DO ij = 1, ip1jmp1 + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO + +c ........ Iteration de l'operateur laplacien_gam ........ +c + DO iter = 1, lh - 2 + CALL laplacien_gam ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2, + * unsapolnga2, unsapolsga2, divgra, divgra ) + ENDDO +c +c ............................................................... + + DO l = 1, klevel + DO ij = 1, ip1jmp1 + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO +c + CALL laplacien ( klevel, divgra, divgra ) +c + DO l = 1,klevel + DO ij = 1,ip1jmp1 + divgra(ij,l) = nudivgrs * divgra(ij,l) / deltapres(ij,l) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divgrad2_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divgrad2_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divgrad2_p.F (revision 1280) @@ -0,0 +1,120 @@ + SUBROUTINE divgrad2_p ( klevel, h, deltapres, lh, divgra_out ) +c +c P. Le Van +c +c *************************************************************** +c +c ..... calcul de (div( grad )) de ( pext * h ) ..... +c **************************************************************** +c h ,klevel,lh et pext sont des arguments d'entree pour le s-prg +c divgra est un argument de sortie pour le s-prg +c + USE parallel + USE times + USE mod_hallo + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comdissipn.h" + +c ....... variables en arguments ....... +c + INTEGER klevel + REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel ) + REAL divgra_out( ip1jmp1,klevel) + REAL,SAVE :: divgra( ip1jmp1,llm) + +c +c ....... variables locales .......... +c + REAL signe, nudivgrs, sqrtps( ip1jmp1,llm ) + INTEGER l,ij,iter,lh +c ................................................................... + Type(Request) :: request_dissip + INTEGER ijb,ije +c + signe = (-1.)**lh + nudivgrs = signe * cdivh + +c CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 ) + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + divgra(ijb:ije,l)=h(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT +c +c$OMP BARRIER + call Register_Hallo(divgra,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL laplacien_p( klevel, divgra, divgra ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + sqrtps( ij,l ) = SQRT( deltapres(ij,l) ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c ........ Iteration de l'operateur laplacien_gam ........ +c + DO iter = 1, lh - 2 +c$OMP BARRIER + call Register_Hallo(divgra,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) + +c$OMP BARRIER + + + CALL laplacien_gam_p ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2, + * unsapolnga2, unsapolsga2, divgra, divgra ) + ENDDO +c +c ............................................................... + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c +c$OMP BARRIER + call Register_Hallo(divgra,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL laplacien_p ( klevel, divgra, divgra ) +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,klevel + DO ij = ijb,ije + divgra_out(ij,l) = nudivgrs * divgra(ij,l) / deltapres(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divgrad_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divgrad_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/divgrad_p.F (revision 1280) @@ -0,0 +1,91 @@ + SUBROUTINE divgrad_p (klevel,h, lh, divgra_out ) + USE parallel + USE times + IMPLICIT NONE +c +c======================================================================= +c +c Auteur : P. Le Van +c ---------- +c +c lh +c calcul de (div( grad )) de h ..... +c h et lh sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c +c======================================================================= +c +c declarations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comdissipn.h" +#include "logic.h" +c + INTEGER klevel + REAL h( ip1jmp1,klevel ), divgra_out( ip1jmp1,klevel ) + REAL,SAVE :: divgra( ip1jmp1,llm ) + +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) + + INTEGER l,ij,iter,lh +c + INTEGER ijb,ije,jjb,jje +c +c +c CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 ) + + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + divgra(ijb:ije,l)=h(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT +c + +c + DO 10 iter = 1,lh + + jjb=jj_begin + jje=jj_end + CALL filtreg_p ( divgra,jjb,jje,jjp1,klevel,2,1,.true.,1 ) + +c call exchange_Hallo(divgra,ip1jmp1,llm,0,1) +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(divgra,ip1jmp1,llm,1,1) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + CALL grad_p (klevel,divgra, ghx , ghy ) + +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(ghy,ip1jm,llm,1,0) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + + CALL diverg_p (klevel, ghx , ghy , divgra ) + + jjb=jj_begin + jje=jj_end + CALL filtreg_p( divgra,jjb,jje,jjp1,klevel,2,1,.true.,1) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,klevel + DO 4 ij = ijb, ije + divgra_out( ij,l ) = - cdivh * divgra( ij,l ) + 4 CONTINUE + 5 CONTINUE +c$OMP END DO NOWAIT +c + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dteta1_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dteta1_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dteta1_p.F (revision 1280) @@ -0,0 +1,88 @@ + SUBROUTINE dteta1_p ( teta, pbaru, pbarv, dteta) + USE parallel + USE write_field_p + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c Modif F.Forget 03/94 (on retire q et dq pour construire dteta1) +c +c ******************************************************************** +c ... calcul du terme de convergence horizontale du flux d'enthalpie +c potentielle ...... +c ******************************************************************** +c .. teta,pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c dteta sont des arguments de sortie pour le s-pg .... +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" + + REAL teta( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL dteta( ip1jmp1,llm ) + INTEGER l,ij + + REAL hbyv( ip1jm,llm ), hbxu( ip1jmp1,llm ) + +c + INTEGER ijb,ije,jjb,jje + + + jjb=jj_begin + jje=jj_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,llm + + ijb=ij_begin + ije=ij_end + + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO 1 ij = ijb, ije - 1 + hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l)+teta(ij+1,l) ) + 1 CONTINUE + +c .... correction pour hbxu(iip1,j,l) ..... +c .... hbxu(iip1,j,l)= hbxu(1,j,l) .... + +CDIR$ IVDEP + DO 2 ij = ijb+iip1-1, ije, iip1 + hbxu( ij, l ) = hbxu( ij - iim, l ) + 2 CONTINUE + + ijb=ij_begin-iip1 + if (pole_nord) ijb=ij_begin + + DO 3 ij = ijb,ije + hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+teta(ij+iip1,l) ) + 3 CONTINUE + + if (.not. pole_sud) then + hbxu(ije+1:ije+iip1,l) = 0 + hbyv(ije+1:ije+iip1,l) = 0 + endif + + 5 CONTINUE +c$OMP END DO NOWAIT + + + CALL convflu_p ( hbxu, hbyv, llm, dteta ) + + +c stockage dans dh de la convergence horizont. filtree' du flux +c .... ........... +c d'enthalpie potentielle . + + + CALL filtreg_p( dteta,jjb,jje,jjp1, llm, 2, 2, .true., 1) + + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dudv1_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dudv1_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dudv1_p.F (revision 1280) @@ -0,0 +1,64 @@ + SUBROUTINE dudv1_p ( vorpot, pbaru, pbarv, du, dv ) + USE parallel + IMPLICIT NONE +c +c----------------------------------------------------------------------- +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c calcul du terme de rotation +c ce terme est ajoute a d(ucov)/dt et a d(vcov)/dt .. +c vorpot, pbaru et pbarv sont des arguments d'entree pour le s-pg .. +c du et dv sont des arguments de sortie pour le s-pg .. +c +c----------------------------------------------------------------------- + +#include "dimensions.h" +#include "paramet.h" + + REAL vorpot( ip1jm,llm ) ,pbaru( ip1jmp1,llm ) , + * pbarv( ip1jm,llm ) ,du( ip1jmp1,llm ) ,dv( ip1jm,llm ) + INTEGER l,ij,ijb,ije +c +c + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,llm +c + ijb=ij_begin + ije=ij_end + + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO 2 ij = ijb, ije-1 + du( ij,l ) = 0.125 *( vorpot(ij-iip1, l) + vorpot( ij, l) ) * + * ( pbarv(ij-iip1, l) + pbarv(ij-iim, l) + + * pbarv( ij , l) + pbarv(ij+ 1 , l) ) + 2 CONTINUE + + +c + if (pole_nord) ijb=ij_begin + + DO 3 ij = ijb, ije-1 + dv( ij+1,l ) = - 0.125 *( vorpot(ij, l) + vorpot(ij+1, l) ) * + * ( pbaru(ij, l) + pbaru(ij+1 , l) + + * pbaru(ij+iip1, l) + pbaru(ij+iip2, l) ) + 3 CONTINUE +c +c .... correction pour dv( 1,j,l ) ..... +c .... dv(1,j,l)= dv(iip1,j,l) .... +c +CDIR$ IVDEP + DO 4 ij = ijb, ije, iip1 + dv( ij,l ) = dv( ij + iim, l ) + 4 CONTINUE +c + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dudv2_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dudv2_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dudv2_p.F (revision 1280) @@ -0,0 +1,69 @@ + SUBROUTINE dudv2_p ( teta, pkf, bern, du, dv ) + USE parallel + IMPLICIT NONE +c +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ***************************************************************** +c ..... calcul du terme de pression (gradient de p/densite ) et +c du terme de ( -gradient de la fonction de Bernouilli ) ... +c ***************************************************************** +c Ces termes sont ajoutes a d(ucov)/dt et a d(vcov)/dt .. +c +c +c teta , pkf, bern sont des arguments d'entree pour le s-pg .... +c du et dv sont des arguments de sortie pour le s-pg .... +c +c======================================================================= +c +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + + REAL teta( ip1jmp1,llm ),pkf( ip1jmp1,llm ) ,bern( ip1jmp1,llm ), + * du( ip1jmp1,llm ), dv( ip1jm,llm ) + INTEGER l,ij,ijb,ije +c +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,llm +c + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + DO 2 ij = ijb, ije - 1 + du(ij,l) = du(ij,l) + 0.5* ( teta( ij,l ) + teta( ij+1,l ) ) * + * ( pkf( ij,l ) - pkf(ij+1,l) ) + bern(ij,l) - bern(ij+1,l) + 2 CONTINUE +c +c +c ..... correction pour du(iip1,j,l), j=2,jjm ...... +c ... du(iip1,j,l) = du(1,j,l) ... +c +CDIR$ IVDEP + DO 3 ij = ijb+iip1-1, ije, iip1 + du( ij,l ) = du( ij - iim,l ) + 3 CONTINUE +c +c + if (pole_nord) ijb=ijb-iip1 + + DO 4 ij = ijb,ije + dv( ij,l) = dv(ij,l) + 0.5 * ( teta(ij,l) + teta( ij+iip1,l ) ) * + * ( pkf(ij+iip1,l) - pkf( ij,l ) ) + * + bern( ij+iip1,l ) - bern( ij ,l ) + 4 CONTINUE +c + 5 CONTINUE +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dump2d.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dump2d.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dump2d.F (revision 1280) @@ -0,0 +1,46 @@ +! +! $Id$ +! + SUBROUTINE dump2d(im,jm,z,nom_z) + IMPLICIT NONE + INTEGER im,jm + REAL z(im,jm) + CHARACTER (len=*) :: nom_z + + INTEGER i,j,imin,illm,jmin,jllm + REAL zmin,zllm + + WRITE(*,*) "dump2d: ",trim(nom_z) + + zmin=z(1,1) + zllm=z(1,1) + imin=1 + illm=1 + jmin=1 + jllm=1 + + DO j=1,jm + DO i=1,im + IF(z(i,j).GT.zllm) THEN + illm=i + jllm=j + zllm=z(i,j) + ENDIF + IF(z(i,j).LT.zmin) THEN + imin=i + jmin=j + zmin=z(i,j) + ENDIF + ENDDO + ENDDO + + PRINT*,'MIN: ',zmin + PRINT*,'MAX: ',zllm + + IF(zllm.GT.zmin) THEN + DO j=1,jm + WRITE(*,'(600i1)') (NINT(10.*(z(i,j)-zmin)/(zllm-zmin)),i=1,im) + ENDDO + ENDIF + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dynetat0.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dynetat0.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dynetat0.F (revision 1280) @@ -0,0 +1,379 @@ +! +! $Header$ +! + SUBROUTINE dynetat0(fichnom,vcov,ucov, + . teta,q,masse,ps,phis,time) + USE infotrac + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van / L.Fairhead +c ------- +c +c objet: +c ------ +c +c Lecture de l'etat initial +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "temps.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "ener.h" +#include "netcdf.inc" +#include "description.h" +#include "serre.h" +#include "logic.h" + +c Arguments: +c ---------- + + CHARACTER*(*) fichnom + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nqtot),masse(ip1jmp1,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + + REAL time + +c Variables +c + INTEGER length,iq + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + INTEGER ierr, nid, nvarid + +c----------------------------------------------------------------------- +c Ouverture NetCDF du fichier etat initial + + ierr = NF_OPEN (fichnom, NF_NOWRITE,nid) + IF (ierr.NE.NF_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier start.nc' + write(6,*)' ierr = ', ierr + CALL ABORT + ENDIF + +c + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echoue pour " + CALL abort + ENDIF + + im = tab_cntrl(1) + jm = tab_cntrl(2) + lllm = tab_cntrl(3) + day_ref = tab_cntrl(4) + annee_ref = tab_cntrl(5) + rad = tab_cntrl(6) + omeg = tab_cntrl(7) + g = tab_cntrl(8) + cpp = tab_cntrl(9) + kappa = tab_cntrl(10) + daysec = tab_cntrl(11) + dtvr = tab_cntrl(12) + etot0 = tab_cntrl(13) + ptot0 = tab_cntrl(14) + ztot0 = tab_cntrl(15) + stot0 = tab_cntrl(16) + ang0 = tab_cntrl(17) + pa = tab_cntrl(18) + preff = tab_cntrl(19) +c + clon = tab_cntrl(20) + clat = tab_cntrl(21) + grossismx = tab_cntrl(22) + grossismy = tab_cntrl(23) +c + IF ( tab_cntrl(24).EQ.1. ) THEN + fxyhypb = . TRUE . +c dzoomx = tab_cntrl(25) +c dzoomy = tab_cntrl(26) +c taux = tab_cntrl(28) +c tauy = tab_cntrl(29) + ELSE + fxyhypb = . FALSE . + ysinus = . FALSE . + IF( tab_cntrl(27).EQ.1. ) ysinus = . TRUE. + ENDIF + + day_ini = tab_cntrl(30) + itau_dyn = tab_cntrl(31) +c ................................................................. +c +c + PRINT*,'rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa + + IF( im.ne.iim ) THEN + PRINT 1,im,iim + STOP + ELSE IF( jm.ne.jjm ) THEN + PRINT 2,jm,jjm + STOP + ELSE IF( lllm.ne.llm ) THEN + PRINT 3,lllm,llm + STOP + ENDIF + + ierr = NF_INQ_VARID (nid, "rlonu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlatu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlonv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlatv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour rlatv" + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "cu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, cu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "cv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, cv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "aire", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, aire) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, aire) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "phisinit", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phis) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, phis) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, time) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, time) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ucov) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ucov) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, vcov) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, vcov) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, teta) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, teta) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + + DO iq=1,nqtot + ierr = NF_INQ_VARID (nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ <"//tname(iq)//"> est absent" + PRINT*, " Il est donc initialise a zero" + q(:,:,iq)=0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q(1,1,iq)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, q(1,1,iq)) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour "//tname(iq) + CALL abort + ENDIF + ENDIF + ENDDO + + ierr = NF_INQ_VARID (nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, masse) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, masse) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ps) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ps) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_CLOSE(nid) + + day_ini=day_ini+INT(time) + time=time-INT(time) + + 1 FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dem + *arrage est differente de la valeur parametree iim =',i4//) + 2 FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dem + *arrage est differente de la valeur parametree jjm =',i4//) + 3 FORMAT(//10x,'la valeur de lmax =',i4,2x,'lue sur le fichier dema + *rrage est differente de la valeur parametree llm =',i4//) + 4 FORMAT(//10x,'la valeur de dtrv =',i4,2x,'lue sur le fichier dema + *rrage est differente de la valeur dtinteg =',i4//) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dynredem.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dynredem.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dynredem.F (revision 1280) @@ -0,0 +1,741 @@ +! +! $Id$ +! +c + SUBROUTINE dynredem0(fichnom,iday_end,phis) +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + USE infotrac + IMPLICIT NONE +c======================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF (initialisation) +c======================================================================= +c Declarations: +c ------------- +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "netcdf.inc" +#include "description.h" +#include "serre.h" + +c Arguments: +c ---------- + INTEGER iday_end + REAL phis(ip1jmp1) + CHARACTER*(*) fichnom + +c Local: +c ------ + INTEGER iq,l + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + INTEGER ierr + character*20 modname + character*80 abort_message + +c Variables locales pour NetCDF: +c + INTEGER dims2(2), dims3(3), dims4(4) + INTEGER idim_index + INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv + INTEGER idim_s, idim_sig + INTEGER idim_tim + INTEGER nid,nvarid + + REAL zan0,zjulian,hours + INTEGER yyears0,jjour0, mmois0 + character*30 unites + + +c----------------------------------------------------------------------- + modname='dynredem0' + +#ifdef CPP_IOIPSL + call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian) + call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours) +#else +! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used) + yyears0=0 + mmois0=1 + jjour0=1 +#endif + + DO l=1,length + tab_cntrl(l) = 0. + ENDDO + tab_cntrl(1) = FLOAT(iim) + tab_cntrl(2) = FLOAT(jjm) + tab_cntrl(3) = FLOAT(llm) + tab_cntrl(4) = FLOAT(day_ref) + tab_cntrl(5) = FLOAT(annee_ref) + tab_cntrl(6) = rad + tab_cntrl(7) = omeg + tab_cntrl(8) = g + tab_cntrl(9) = cpp + tab_cntrl(10) = kappa + tab_cntrl(11) = daysec + tab_cntrl(12) = dtvr + tab_cntrl(13) = etot0 + tab_cntrl(14) = ptot0 + tab_cntrl(15) = ztot0 + tab_cntrl(16) = stot0 + tab_cntrl(17) = ang0 + tab_cntrl(18) = pa + tab_cntrl(19) = preff +c +c ..... parametres pour le zoom ...... + + tab_cntrl(20) = clon + tab_cntrl(21) = clat + tab_cntrl(22) = grossismx + tab_cntrl(23) = grossismy +c + IF ( fxyhypb ) THEN + tab_cntrl(24) = 1. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = taux + tab_cntrl(29) = tauy + ELSE + tab_cntrl(24) = 0. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = 0. + tab_cntrl(29) = 0. + IF( ysinus ) tab_cntrl(27) = 1. + ENDIF + + tab_cntrl(30) = FLOAT(iday_end) + tab_cntrl(31) = FLOAT(itau_dyn + itaufin) +c +c ......................................................... +c +c Creation du fichier: +c + ierr = NF_CREATE(fichnom, NF_CLOBBER, nid) + IF (ierr.NE.NF_NOERR) THEN + WRITE(6,*)" Pb d ouverture du fichier "//fichnom + WRITE(6,*)' ierr = ', ierr + CALL ABORT + ENDIF +c +c Preciser quelques attributs globaux: +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27, + . "Fichier demmarage dynamique") +c +c Definir les dimensions du fichiers: +c + ierr = NF_DEF_DIM (nid, "index", length, idim_index) + ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu) + ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu) + ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv) + ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv) + ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s) + ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig) + ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim) +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition +c +c Definir et enregistrer certains champs invariants: +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid) +#else + ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Parametres de controle") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28, + . "Numero naturel des couches s") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32, + . "Numero naturel des couches sigma") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient A pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ap) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient B pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,bp) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs) +#endif +c +c Coefficients de passage cov. <-> contra. <--> naturel +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonu + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cu) +#endif +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatv +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cv) +#endif +c +c Aire de chaque maille: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Aires de chaque maille") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,aire) +#endif +c +c Geopentiel au sol: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Geopotentiel au sol") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,phis) +#endif +c +c Definir les variables pour pouvoir les enregistrer plus tard: +c + ierr = NF_REDEF (nid) ! entrer dans le mode de definition +c +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid) +#else + ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Temps de simulation") + write(unites,200)yyears0,mmois0,jjour0 +200 format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00') + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30, + . unites) + +c + dims4(1) = idim_rlonu + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse U") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatv + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse V") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11, + . "Temperature") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim + IF(nqtot.GE.1) THEN + DO iq=1,nqtot +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq)) + ENDDO + ENDIF +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12, + . "C est quoi ?") +c + dims3(1) = idim_rlonv + dims3(2) = idim_rlatu + dims3(3) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15, + . "Pression au sol") +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition + ierr = NF_CLOSE(nid) ! fermer le fichier + + PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end + PRINT*,'rad,omeg,g,cpp,kappa', + , rad,omeg,g,cpp,kappa + + RETURN + END + SUBROUTINE dynredem1(fichnom,time, + . vcov,ucov,teta,q,masse,ps) + USE infotrac + IMPLICIT NONE +c================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF +c================================================================= +#include "dimensions.h" +#include "paramet.h" +#include "description.h" +#include "netcdf.inc" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "control.h" + + INTEGER l + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nqtot) + CHARACTER*(*) fichnom + + REAL time + INTEGER nid, nvarid, nid_trac, nvarid_trac + REAL trac_tmp(ip1jmp1,llm) + INTEGER ierr, ierr_file + INTEGER iq + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + character*20 modname + character*80 abort_message +c + INTEGER nb + SAVE nb + DATA nb / 0 / + + modname = 'dynredem1' + ierr = NF_OPEN(fichnom, NF_WRITE, nid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Pb. d ouverture "//fichnom + CALL abort + ENDIF + +c Ecriture/extension de la coordonnee temps + + nb = nb + 1 + ierr = NF_INQ_VARID(nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + print *, NF_STRERROR(ierr) + abort_message='Variable temps n est pas definie' + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time) +#else + ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time) +#endif + PRINT*, "Enregistrement pour ", nb, time + +c +c Re-ecriture du tableau de controle, itaufin n'est plus defini quand +c on passe dans dynredem0 + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Le champ est absent" + ierr = 1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + tab_cntrl(31) = FLOAT(itau_dyn + itaufin) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif + +c Ecriture des champs +c + ierr = NF_INQ_VARID(nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ucov n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov) +#endif + + ierr = NF_INQ_VARID(nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable vcov n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov) +#endif + + ierr = NF_INQ_VARID(nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable teta n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,teta) +#endif + + IF (config_inca /= 'none') THEN +! Ajout Anne pour lecture valeurs traceurs dans un fichier start_trac.nc + ierr_file = NF_OPEN ("start_trac.nc", NF_NOWRITE,nid_trac) + IF (ierr_file .NE.NF_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier start_trac.nc' + write(6,*)' ierr = ', ierr_file + ENDIF + END IF + + IF(nqtot.GE.1) THEN + do iq=1,nqtot + + IF (config_inca == 'none') THEN + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable tname(iq) n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ELSE ! config_inca = 'chem' ou 'aero' +! lecture de la valeur du traceur dans start_trac.nc + IF (ierr_file .ne. 2) THEN + ierr = NF_INQ_VARID (nid_trac, tname(iq), nvarid_trac) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, tname(iq),"est absent de start_trac.nc" + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ", tname(iq)," n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + + ELSE + PRINT*, tname(iq), "est present dans start_trac.nc" +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid_trac, nvarid_trac, trac_tmp) +#else + ierr = NF_GET_VAR_REAL(nid_trac, nvarid_trac, trac_tmp) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Lecture echouee pour", tname(iq) + CALL abort + ENDIF + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ", tname(iq)," n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,trac_tmp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,trac_tmp) +#endif + + ENDIF ! IF (ierr .NE. NF_NOERR) +! fin lecture du traceur + ELSE ! si il n'y a pas de fichier start_trac.nc +! print *, 'il n y a pas de fichier start_trac' + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable tname(iq) n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ENDIF ! (ierr_file .ne. 2) + END IF ! config_inca + + ENDDO + ENDIF +c + ierr = NF_INQ_VARID(nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable masse n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,masse) +#endif +c + ierr = NF_INQ_VARID(nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ps n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ps) +#endif + + ierr = NF_CLOSE(nid) +c + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dynredem_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dynredem_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/dynredem_p.F (revision 1280) @@ -0,0 +1,769 @@ +! +! $Id$ +! +c + SUBROUTINE dynredem0_p(fichnom,iday_end,phis) +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + USE parallel + USE infotrac + IMPLICIT NONE +c======================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF (initialisation) +c======================================================================= +c Declarations: +c ------------- +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "netcdf.inc" +#include "description.h" +#include "serre.h" + +c Arguments: +c ---------- + INTEGER iday_end + REAL phis(ip1jmp1) + CHARACTER*(*) fichnom + +c Local: +c ------ + INTEGER iq,l + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + INTEGER ierr + character*20 modname + character*80 abort_message + +c Variables locales pour NetCDF: +c + INTEGER dims2(2), dims3(3), dims4(4) + INTEGER idim_index + INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv + INTEGER idim_s, idim_sig + INTEGER idim_tim + INTEGER nid,nvarid + + REAL zan0,zjulian,hours + INTEGER yyears0,jjour0, mmois0 + character*30 unites + +c----------------------------------------------------------------------- + if (mpi_rank==0) then + + modname='dynredem0_p' + +#ifdef CPP_IOIPSL + call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian) + call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours) +#else +! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used) + yyears0=0 + mmois0=1 + jjour0=1 +#endif + + DO l=1,length + tab_cntrl(l) = 0. + ENDDO + tab_cntrl(1) = FLOAT(iim) + tab_cntrl(2) = FLOAT(jjm) + tab_cntrl(3) = FLOAT(llm) + tab_cntrl(4) = FLOAT(day_ref) + tab_cntrl(5) = FLOAT(annee_ref) + tab_cntrl(6) = rad + tab_cntrl(7) = omeg + tab_cntrl(8) = g + tab_cntrl(9) = cpp + tab_cntrl(10) = kappa + tab_cntrl(11) = daysec + tab_cntrl(12) = dtvr + tab_cntrl(13) = etot0 + tab_cntrl(14) = ptot0 + tab_cntrl(15) = ztot0 + tab_cntrl(16) = stot0 + tab_cntrl(17) = ang0 + tab_cntrl(18) = pa + tab_cntrl(19) = preff +c +c ..... parametres pour le zoom ...... + + tab_cntrl(20) = clon + tab_cntrl(21) = clat + tab_cntrl(22) = grossismx + tab_cntrl(23) = grossismy +c + IF ( fxyhypb ) THEN + tab_cntrl(24) = 1. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = taux + tab_cntrl(29) = tauy + ELSE + tab_cntrl(24) = 0. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = 0. + tab_cntrl(29) = 0. + IF( ysinus ) tab_cntrl(27) = 1. + ENDIF + + tab_cntrl(30) = FLOAT(iday_end) + tab_cntrl(31) = FLOAT(itau_dyn + itaufin) +c +c ......................................................... +c +c Creation du fichier: +c + ierr = NF_CREATE(fichnom, NF_CLOBBER, nid) + IF (ierr.NE.NF_NOERR) THEN + WRITE(6,*)" Pb d ouverture du fichier "//fichnom + WRITE(6,*)' ierr = ', ierr + CALL ABORT + ENDIF +c +c Preciser quelques attributs globaux: +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27, + . "Fichier demmarage dynamique") +c +c Definir les dimensions du fichiers: +c + ierr = NF_DEF_DIM (nid, "index", length, idim_index) + ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu) + ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu) + ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv) + ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv) + ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s) + ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig) + ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim) +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition +c +c Definir et enregistrer certains champs invariants: +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid) +#else + ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Parametres de controle") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28, + . "Numero naturel des couches s") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32, + . "Numero naturel des couches sigma") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient A pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ap) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient B pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,bp) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs) +#endif +c +c Coefficients de passage cov. <-> contra. <--> naturel +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonu + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cu) +#endif +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatv +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cv) +#endif +c +c Aire de chaque maille: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Aires de chaque maille") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,aire) +#endif +c +c Geopentiel au sol: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Geopotentiel au sol") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,phis) +#endif +c +c Definir les variables pour pouvoir les enregistrer plus tard: +c + ierr = NF_REDEF (nid) ! entrer dans le mode de definition +c +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid) +#else + ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Temps de simulation") + write(unites,200)yyears0,mmois0,jjour0 +200 format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00') + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30, + . unites) + +c + dims4(1) = idim_rlonu + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse U") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatv + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse V") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11, + . "Temperature") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim + + DO iq=1,nqtot +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq)) + ENDDO +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12, + . "C est quoi ?") +c + dims3(1) = idim_rlonv + dims3(2) = idim_rlatu + dims3(3) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15, + . "Pression au sol") +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition + ierr = NF_CLOSE(nid) ! fermer le fichier + + + PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end + PRINT*,'rad,omeg,g,cpp,kappa', + , rad,omeg,g,cpp,kappa + + endif ! mpi_rank==0 + RETURN + END + SUBROUTINE dynredem1_p(fichnom,time, + . vcov,ucov,teta,q,masse,ps) + USE parallel + USE infotrac + IMPLICIT NONE +c================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF +c================================================================= +#include "dimensions.h" +#include "paramet.h" +#include "description.h" +#include "netcdf.inc" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "control.h" + + INTEGER l + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nqtot) + CHARACTER*(*) fichnom + + REAL time + INTEGER nid, nvarid, nid_trac, nvarid_trac + REAL trac_tmp(ip1jmp1,llm) + INTEGER ierr, ierr_file + INTEGER iq + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + character*20 modname + character*80 abort_message +c + INTEGER nb + SAVE nb + DATA nb / 0 / + + logical exist_file + + call Gather_Field(ucov,ip1jmp1,llm,0) + call Gather_Field(vcov,ip1jm,llm,0) + call Gather_Field(teta,ip1jmp1,llm,0) + call Gather_Field(masse,ip1jmp1,llm,0) + call Gather_Field(ps,ip1jmp1,1,0) + + do iq=1,nqtot + call Gather_Field(q(1,1,iq),ip1jmp1,llm,0) + enddo + + + if (mpi_rank==0) then + + modname = 'dynredem1' + ierr = NF_OPEN(fichnom, NF_WRITE, nid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Pb. d ouverture "//fichnom + CALL abort + ENDIF + +c Ecriture/extension de la coordonnee temps + + nb = nb + 1 + ierr = NF_INQ_VARID(nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + print *, NF_STRERROR(ierr) + abort_message='Variable temps n est pas definie' + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time) +#else + ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time) +#endif + PRINT*, "Enregistrement pour ", nb, time + +c +c Re-ecriture du tableau de controle, itaufin n'est plus defini quand +c on passe dans dynredem0 + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Le champ est absent" + ierr = 1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + tab_cntrl(31) = FLOAT(itau_dyn + itaufin) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif + +c Ecriture des champs +c + ierr = NF_INQ_VARID(nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ucov n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov) +#endif + + ierr = NF_INQ_VARID(nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable vcov n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov) +#endif + + ierr = NF_INQ_VARID(nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable teta n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,teta) +#endif + + IF (config_inca /= 'none') THEN +! Ajout Anne pour lecture valeurs traceurs dans un fichier start_trac.nc + inquire(FILE="start_trac.nc", EXIST=exist_file) + print *, "EXIST", exist_file + if (exist_file) then + ierr_file = NF_OPEN ("start_trac.nc", NF_NOWRITE,nid_trac) + IF (ierr_file .NE.NF_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier start_trac.nc' + write(6,*)' ierr = ', ierr_file + ENDIF + else + ierr_file = 2 + endif + END IF + + do iq=1,nqtot + + IF (config_inca == 'none') THEN + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable tname(iq) n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ELSE ! config_inca = 'chem' ou 'aero' +! lecture de la valeur du traceur dans start_trac.nc + IF (ierr_file .ne. 2) THEN + ierr = NF_INQ_VARID (nid_trac, tname(iq), nvarid_trac) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, tname(iq),"est absent de start_trac.nc" + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ", tname(iq)," n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + + ELSE + PRINT*, tname(iq), "est present dans start_trac.nc" +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid_trac, nvarid_trac, trac_tmp) +#else + ierr = NF_GET_VAR_REAL(nid_trac, nvarid_trac, trac_tmp) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Lecture echouee pour", tname(iq) + CALL abort + ENDIF + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ", tname(iq)," n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,trac_tmp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,trac_tmp) +#endif + + ENDIF ! IF (ierr .NE. NF_NOERR) +! fin lecture du traceur + ELSE ! si il n'y a pas de fichier start_trac.nc +! print *, 'il n y a pas de fichier start_trac' + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable tname(iq) n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ENDIF ! (ierr_file .ne. 2) + END IF ! config_inca + + ENDDO + + + +c + ierr = NF_INQ_VARID(nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable masse n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,masse) +#endif +c + ierr = NF_INQ_VARID(nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ps n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ps) +#endif + + ierr = NF_CLOSE(nid) +c + endif ! mpi_rank==0 + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ener.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ener.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ener.h (revision 1280) @@ -0,0 +1,14 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c INCLUDE 'ener.h' + + COMMON/ener/ang0,etot0,ptot0,ztot0,stot0, + * ang,etot,ptot,ztot,stot,rmsdpdt , + * rmsv,gtot(llmm1) + + REAL ang0,etot0,ptot0,ztot0,stot0, + s ang,etot,ptot,ztot,stot,rmsdpdt,rmsv,gtot + +c----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/enercin.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/enercin.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/enercin.F (revision 1280) @@ -0,0 +1,98 @@ +! +! $Header$ +! + SUBROUTINE enercin ( vcov, ucov, vcont, ucont, ecin ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c .. calcul de l'energie cinetique aux niveaux s ...... +c ********************************************************************* +c vcov, vcont, ucov et ucont sont des arguments d'entree pour le s-pg . +c ecin est un argument de sortie pour le s-pg +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL vcov( ip1jm,llm ),vcont( ip1jm,llm ), + * ucov( ip1jmp1,llm ),ucont( ip1jmp1,llm ),ecin( ip1jmp1,llm ) + + REAL ecinni( iip1 ),ecinsi( iip1 ) + + REAL ecinpn, ecinps + INTEGER l,ij,i + + REAL SSUM + + + +c . V +c i,j-1 + +c alpha4 . . alpha1 + + +c U . . P . U +c i-1,j i,j i,j + +c alpha3 . . alpha2 + + +c . V +c i,j + +c +c L'energie cinetique au point scalaire P(i,j) ,autre que les poles, est : +c Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 ) + +c 0.5 * U(i ,j)**2 *( alpha1 + alpha2 ) + +c 0.5 * V(i,j-1)**2 *( alpha1 + alpha4 ) + +c 0.5 * V(i, j)**2 *( alpha2 + alpha3 ) + + + DO 5 l = 1,llm + + DO 1 ij = iip2, ip1jm -1 + ecin( ij+1, l ) = 0.5 * + * ( ucov( ij ,l ) * ucont( ij ,l ) * alpha3p4( ij +1 ) + + * ucov( ij+1 ,l ) * ucont( ij+1 ,l ) * alpha1p2( ij +1 ) + + * vcov(ij-iim,l ) * vcont(ij-iim,l ) * alpha1p4( ij +1 ) + + * vcov( ij+ 1,l ) * vcont( ij+ 1,l ) * alpha2p3( ij +1 ) ) + 1 CONTINUE + +c ... correction pour ecin(1,j,l) .... +c ... ecin(1,j,l)= ecin(iip1,j,l) ... + +CDIR$ IVDEP + DO 2 ij = iip2, ip1jm, iip1 + ecin( ij,l ) = ecin( ij + iim, l ) + 2 CONTINUE + +c calcul aux poles ....... + + + DO 3 i = 1, iim + ecinni(i) = vcov( i , l) * vcont( i ,l) * aire( i ) + ecinsi(i) = vcov(i+ip1jmi1,l) * vcont(i+ip1jmi1,l) * aire(i+ip1jm) + 3 CONTINUE + + ecinpn = 0.5 * SSUM( iim,ecinni,1 ) / apoln + ecinps = 0.5 * SSUM( iim,ecinsi,1 ) / apols + + DO 4 ij = 1,iip1 + ecin( ij , l ) = ecinpn + ecin( ij+ ip1jm, l ) = ecinps + 4 CONTINUE + + 5 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/enercin_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/enercin_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/enercin_p.F (revision 1280) @@ -0,0 +1,121 @@ + SUBROUTINE enercin_p ( vcov, ucov, vcont, ucont, ecin ) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c .. calcul de l'energie cinetique aux niveaux s ...... +c ********************************************************************* +c vcov, vcont, ucov et ucont sont des arguments d'entree pour le s-pg . +c ecin est un argument de sortie pour le s-pg +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL vcov( ip1jm,llm ),vcont( ip1jm,llm ), + * ucov( ip1jmp1,llm ),ucont( ip1jmp1,llm ),ecin( ip1jmp1,llm ) + + REAL ecinni( iip1 ),ecinsi( iip1 ) + + REAL ecinpn, ecinps + INTEGER l,ij,i,ijb,ije + + EXTERNAL SSUM + REAL SSUM + + + +c . V +c i,j-1 + +c alpha4 . . alpha1 + + +c U . . P . U +c i-1,j i,j i,j + +c alpha3 . . alpha2 + + +c . V +c i,j + +c +c L'energie cinetique au point scalaire P(i,j) ,autre que les poles, est : +c Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 ) + +c 0.5 * U(i ,j)**2 *( alpha1 + alpha2 ) + +c 0.5 * V(i,j-1)**2 *( alpha1 + alpha4 ) + +c 0.5 * V(i, j)**2 *( alpha2 + alpha3 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,llm + + ijb=ij_begin + ije=ij_end+iip1 + + IF (pole_nord) ijb=ij_begin+iip1 + IF (pole_sud) ije=ij_end-iip1 + + DO 1 ij = ijb, ije -1 + ecin( ij+1, l ) = 0.5 * + * ( ucov( ij ,l ) * ucont( ij ,l ) * alpha3p4( ij +1 ) + + * ucov( ij+1 ,l ) * ucont( ij+1 ,l ) * alpha1p2( ij +1 ) + + * vcov(ij-iim,l ) * vcont(ij-iim,l ) * alpha1p4( ij +1 ) + + * vcov( ij+ 1,l ) * vcont( ij+ 1,l ) * alpha2p3( ij +1 ) ) + 1 CONTINUE + +c ... correction pour ecin(1,j,l) .... +c ... ecin(1,j,l)= ecin(iip1,j,l) ... + +CDIR$ IVDEP + DO 2 ij = ijb, ije, iip1 + ecin( ij,l ) = ecin( ij + iim, l ) + 2 CONTINUE + +c calcul aux poles ....... + + IF (pole_nord) THEN + + DO i = 1, iim + ecinni(i) = vcov( i , l) * + * vcont( i ,l) * aire( i ) + ENDDO + + ecinpn = 0.5 * SSUM( iim,ecinni,1 ) / apoln + + DO ij = 1,iip1 + ecin( ij , l ) = ecinpn + ENDDO + + ENDIF + + IF (pole_sud) THEN + + DO i = 1, iim + ecinsi(i) = vcov(i+ip1jmi1,l)* + * vcont(i+ip1jmi1,l) * aire(i+ip1jm) + ENDDO + + ecinps = 0.5 * SSUM( iim,ecinsi,1 ) / apols + + DO ij = 1,iip1 + ecin( ij+ ip1jm, l ) = ecinps + ENDDO + + ENDIF + + + 5 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/etat0_netcdf.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/etat0_netcdf.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/etat0_netcdf.F (revision 1280) @@ -0,0 +1,791 @@ +! +! $Header$ +! +c +c + SUBROUTINE etat0_netcdf (interbar, masque) +#ifdef CPP_EARTH + USE startvar + USE ioipsl + USE dimphy + USE infotrac + USE fonte_neige_mod + USE pbl_surface_mod + USE phys_state_var_mod + USE filtreg_mod + use regr_lat_time_climoz_m, only: regr_lat_time_climoz + use conf_phys_m, only: conf_phys +#endif +!#endif of #ifdef CPP_EARTH + use netcdf, only: nf90_open, NF90_NOWRITE, nf90_close + ! + IMPLICIT NONE + ! +#include "dimensions.h" +#include "paramet.h" + ! + ! +! INTEGER, PARAMETER :: KIDIA=1, KFDIA=iim*(jjm-1)+2, +! .KLON=KFDIA-KIDIA+1,KLEV=llm + ! +#ifdef CPP_EARTH +#include "comgeom2.h" +#include "comvert.h" +#include "comconst.h" +#include "indicesol.h" +#include "dimsoil.h" +#include "temps.h" +#endif +!#endif of #ifdef CPP_EARTH + ! arguments: + LOGICAL interbar + REAL :: masque(iip1,jjp1) + +#ifdef CPP_EARTH + ! local variables: + REAL :: latfi(klon), lonfi(klon) + REAL :: orog(iip1,jjp1), rugo(iip1,jjp1) + REAL :: psol(iip1, jjp1), phis(iip1, jjp1) + REAL :: p3d(iip1, jjp1, llm+1) + REAL :: uvent(iip1, jjp1, llm) + REAL :: vvent(iip1, jjm, llm) + REAL :: t3d(iip1, jjp1, llm), tpot(iip1, jjp1, llm) + REAL :: qsat(iip1, jjp1, llm) + REAL,ALLOCATABLE :: q3d(:, :, :,:) + REAL :: tsol(klon), qsol(klon), sn(klon) +!! REAL :: tsolsrf(klon,nbsrf) + real qsolsrf(klon,nbsrf),snsrf(klon,nbsrf) + REAL :: albe(klon,nbsrf), evap(klon,nbsrf) + REAL :: alblw(klon,nbsrf) + REAL :: tsoil(klon,nsoilmx,nbsrf) + REAL :: frugs(klon,nbsrf), agesno(klon,nbsrf) + REAL :: rugmer(klon) + REAL :: qd(iip1, jjp1, llm) + REAL :: run_off_lic_0(klon) + ! declarations pour lecture glace de mer + REAL :: rugv(klon) + INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret + INTEGER :: itaul(1), fid + REAL :: lev(1), date + REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic + REAL, ALLOCATABLE, DIMENSION(:) :: dlon_lic, dlat_lic + REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic + REAL :: flic_tmp(iip1, jjp1) + REAL :: champint(iim, jjp1) + ! + + CHARACTER(len=80) :: varname + ! + INTEGER :: i,j, ig, l, ji,ii1,ii2 + REAL :: xpi + ! + REAL :: alpha(iip1,jjp1,llm),beta(iip1,jjp1,llm) + REAL :: pk(iip1,jjp1,llm), pls(iip1,jjp1,llm), pks(ip1jmp1) + REAL :: workvar(iip1,jjp1,llm) + ! + REAL :: prefkap, unskap + ! + real :: time_step,t_ops,t_wrt + +#include "comdissnew.h" +#include "control.h" +#include "serre.h" +#include "clesphys.h" + + INTEGER :: longcles + PARAMETER ( longcles = 20 ) + REAL :: clesphy0 ( longcles ) + REAL :: p(iip1,jjp1,llm) + INTEGER :: itau, iday + REAL :: masse(iip1,jjp1,llm) + REAL :: xpn,xps,xppn(iim),xpps(iim) + real :: time + REAL :: phi(ip1jmp1,llm) + REAL :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL :: w(ip1jmp1,llm) + REAL ::phystep +CC REAL :: rugsrel(iip1*jjp1) + REAL :: fder(klon) +!! real zrel(iip1*jjp1),chmin,chmax + +!! CHARACTER(len=80) :: visu_file + INTEGER :: visuid + +! pour la lecture du fichier masque ocean + integer :: nid_o2a + logical :: couple = .false. + INTEGER :: iml_omask, jml_omask + REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_omask, lat_omask + REAL, ALLOCATABLE, DIMENSION(:) :: dlon_omask, dlat_omask + REAL, ALLOCATABLE, DIMENSION (:,:) :: ocemask, ocetmp + real, dimension(klon) :: ocemask_fi + integer :: isst(klon-2) + real zx_tmp_2d(iim,jjp1) + + REAL :: dummy + + logical :: ok_newmicro + integer :: iflag_radia + logical :: ok_journe, ok_mensuel, ok_instan, ok_hf + logical :: ok_LES + LOGICAL :: ok_ade, ok_aie, aerosol_couple, new_aod + INTEGER :: flag_aerosol + REAL :: bl95_b0, bl95_b1 + real :: fact_cldcon, facttemps,ratqsbas,ratqshaut + real :: tau_ratqs + integer :: iflag_cldcon + integer :: iflag_ratqs + integer :: iflag_coupl + integer :: iflag_clos + integer :: iflag_wake + integer :: iflag_thermals,nsplit_thermals + real :: tau_thermals + integer :: iflag_thermals_ed,iflag_thermals_optflux + REAL :: solarlong0 + real :: seuil_inversion + + integer read_climoz ! read ozone climatology +C Allowed values are 0, 1 and 2 +C 0: do not read an ozone climatology +C 1: read a single ozone climatology that will be used day and night +C 2: read two ozone climatologies, the average day and night +C climatology and the daylight climatology + + ! + ! Constantes + ! + pi = 4. * ATAN(1.) + rad = 6371229. + omeg = 4.* ASIN(1.)/(24.*3600.) + g = 9.8 + daysec = 86400. + kappa = 0.2857143 + cpp = 1004.70885 + ! + preff = 101325. + pa = 50000. + unskap = 1./kappa + ! + jmp1 = jjm + 1 + ! + ! Construct a grid + ! + +! CALL defrun_new(99,.TRUE.,clesphy0) + CALL conf_gcm( 99, .TRUE. , clesphy0 ) + call conf_phys( ok_journe, ok_mensuel, ok_instan, ok_hf, ok_LES, & + & solarlong0,seuil_inversion, & + & fact_cldcon, facttemps,ok_newmicro,iflag_radia, & + & iflag_cldcon, & + & iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, & + & ok_ade, ok_aie, aerosol_couple, & + & flag_aerosol, new_aod, & + & bl95_b0, bl95_b1, & + & iflag_thermals,nsplit_thermals,tau_thermals, & + & iflag_thermals_ed,iflag_thermals_optflux, & + & iflag_coupl,iflag_clos,iflag_wake, read_climoz ) + +! co2_ppm0 : initial value of atmospheric CO2 from .def file (co2_ppm value) + co2_ppm0 = co2_ppm + + dtvr = daysec/FLOAT(day_step) + print*,'dtvr',dtvr + + CALL iniconst() + CALL inigeom() + +! Initialisation pour traceurs + call infotrac_init + ALLOCATE(q3d(iip1, jjp1, llm, nqtot)) + + CALL inifilr() + CALL phys_state_var_init(read_climoz) + ! + latfi(1) = ASIN(1.0) + DO j = 2, jjm + DO i = 1, iim + latfi((j-2)*iim+1+i)= rlatu(j) + ENDDO + ENDDO + latfi(klon) = - ASIN(1.0) + ! + lonfi(1) = 0.0 + DO j = 2, jjm + DO i = 1, iim + lonfi((j-2)*iim+1+i) = rlonv(i) + ENDDO + ENDDO + lonfi(klon) = 0.0 + ! + xpi = 2.0 * ASIN(1.0) + DO ig = 1, klon + latfi(ig) = latfi(ig) * 180.0 / xpi + lonfi(ig) = lonfi(ig) * 180.0 / xpi + ENDDO + ! + rlat(1) = ASIN(1.0) + DO j = 2, jjm + DO i = 1, iim + rlat((j-2)*iim+1+i)= rlatu(j) + ENDDO + ENDDO + rlat(klon) = - ASIN(1.0) + ! + rlon(1) = 0.0 + DO j = 2, jjm + DO i = 1, iim + rlon((j-2)*iim+1+i) = rlonv(i) + ENDDO + ENDDO + rlon(klon) = 0.0 + ! + xpi = 2.0 * ASIN(1.0) + DO ig = 1, klon + rlat(ig) = rlat(ig) * 180.0 / xpi + rlon(ig) = rlon(ig) * 180.0 / xpi + ENDDO + ! + + + +C +C En cas de simulation couplee, lecture du masque ocean issu du modele ocean +C utilise pour calculer les poids et pour assurer l'adequation entre les +C fractions d'ocean vu par l'atmosphere et l'ocean. Sinon, on cree le masque +C a partir du fichier relief +C + + write(*,*)'Essai de lecture masque ocean' + iret = nf90_open("o2a.nc", NF90_NOWRITE, nid_o2a) + if (iret .ne. 0) then + write(*,*)'ATTENTION!! pas de fichier o2a.nc trouve' + write(*,*)'Run force' + varname = 'masque' + masque(:,:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, masque, 0.0, + , jjm ,rlonu,rlatv , interbar ) + WRITE(*,*) 'MASQUE construit : Masque' + WRITE(*,'(97I1)') nINT(masque(:,:)) + call gr_dyn_fi(1, iip1, jjp1, klon, masque, zmasq) + WHERE (zmasq(1 : klon) .LT. EPSFRA) + zmasq(1 : klon) = 0. + END WHERE + WHERE (1. - zmasq(1 : klon) .LT. EPSFRA) + zmasq(1 : klon) = 1. + END WHERE + else + couple = .true. + iret = nf90_close(nid_o2a) + call flininfo("o2a.nc", iml_omask, jml_omask, llm_tmp, ttm_tmp + $ , nid_o2a) + if (iml_omask /= iim .or. jml_omask /= jjp1) then + write(*,*)'Dimensions non compatibles pour masque ocean' + write(*,*)'iim = ',iim,' iml_omask = ',iml_omask + write(*,*)'jjp1 = ',jjp1,' jml_omask = ',jml_omask + stop + endif + ALLOCATE(lat_omask(iml_omask, jml_omask), stat=iret) + ALLOCATE(lon_omask(iml_omask, jml_omask), stat=iret) + ALLOCATE(dlon_omask(iml_omask), stat=iret) + ALLOCATE(dlat_omask(jml_omask), stat=iret) + ALLOCATE(ocemask(iml_omask, jml_omask), stat=iret) + ALLOCATE(ocetmp(iml_omask, jml_omask), stat=iret) + CALL flinopen("o2a.nc", .FALSE., iml_omask, jml_omask, llm_tmp + $ , lon_omask, lat_omask, lev, ttm_tmp, itaul, date, dt, fid) + CALL flinget(fid, 'OceMask', iml_omask, jml_omask, llm_tmp, + $ ttm_tmp, 1, 1, ocetmp) + CALL flinclo(fid) + dlon_omask(1 : iml_omask) = lon_omask(1 : iml_omask, 1) + dlat_omask(1 : jml_omask) = lat_omask(1 , 1 : jml_omask) + ocemask = ocetmp + if (dlat_omask(1) < dlat_omask(jml_omask)) then + do j = 1, jml_omask + ocemask(:,j) = ocetmp(:,jml_omask-j+1) + enddo + endif +C +C passage masque ocean a la grille physique +C + write(*,*)'ocemask ' + write(*,'(96i1)')int(ocemask) + ocemask_fi(1) = ocemask(1,1) + do j = 2, jjm + do i = 1, iim + ocemask_fi((j-2)*iim + i + 1) = ocemask(i,j) + enddo + enddo + ocemask_fi(klon) = ocemask(1,jjp1) + zmasq = 1. - ocemask_fi + endif + + call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque) + + varname = 'relief' + ! This line needs to be replaced by a call to restget to get the values in the restart file + orog(:,:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, orog, 0.0 , + , jjm ,rlonu,rlatv , interbar, masque ) + ! + WRITE(*,*) 'OUT OF GET VARIABLE : Relief' +! WRITE(*,'(49I1)') INT(orog(:,:)) + ! + varname = 'rugosite' + ! This line needs to be replaced by a call to restget to get the values in the restart file + rugo(:,:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, rugo, 0.0 , + , jjm, rlonu,rlatv , interbar ) + ! + WRITE(*,*) 'OUT OF GET VARIABLE : Rugosite' +! WRITE(*,'(49I1)') INT(rugo(:,:)*10) + ! +C +C on initialise les sous surfaces +C + pctsrf=0. +c + varname = 'psol' + psol(:,:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, psol, 0.0 , + , jjm ,rlonu,rlatv , interbar ) + ! + ! Compute here the pressure on the intermediate levels. One would expect that this is available in the GCM + ! anyway. + ! +! WRITE(*,*) 'PSOL :', psol(10,20) +! WRITE(*,*) ap(:), bp(:) + CALL pression(ip1jmp1, ap, bp, psol, p3d) +! WRITE(*,*) 'P3D :', p3d(10,20,:) + CALL exner_hyb(ip1jmp1, psol, p3d, alpha, beta, pks, pk, workvar) +! WRITE(*,*) 'PK:', pk(10,20,:) + ! + ! + ! + prefkap = preff ** kappa +! WRITE(*,*) 'unskap, cpp, preff :', unskap, cpp, preff + DO l = 1, llm + DO j=1,jjp1 + DO i =1, iip1 + pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap + ENDDO + ENDDO + ENDDO + ! +! WRITE(*,*) 'PLS :', pls(10,20,:) + ! + varname = 'surfgeo' + phis(:,:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, phis, 0.0 , + , jjm ,rlonu,rlatv, interbar ) + ! + varname = 'u' + uvent(:,:,:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonu, rlatu, llm, pls, + . workvar, uvent, 0.0, jjm ,rlonv, rlatv, interbar ) + ! + varname = 'v' + vvent(:,:,:) = 0.0 + CALL startget(varname, iip1, jjm, rlonv, rlatv, llm, pls, + . workvar, vvent, 0.0, jjp1, rlonu, rlatu, interbar ) + ! + varname = 't' + t3d(:,:,:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, llm, pls, + . workvar, t3d, 0.0 , jjm, rlonu, rlatv , interbar ) + ! + WRITE(*,*) 'T3D min,max:',minval(t3d(:,:,:)), + . maxval(t3d(:,:,:)) + varname = 'tpot' + tpot(:,:,:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, llm, pls, + . pk, tpot, 0.0 , jjm, rlonu, rlatv , interbar ) + ! + WRITE(*,*) 'T3D min,max:',minval(t3d(:,:,:)), + . maxval(t3d(:,:,:)) + WRITE(*,*) 'PLS min,max:',minval(pls(:,:,:)), + . maxval(pls(:,:,:)) + +c Calcul de l'humidite a saturation + print*,'avant q_sat' + call q_sat(llm*jjp1*iip1,t3d,pls,qsat) + print*,'apres q_sat' + + WRITE(*,*) 'QSAT min,max:',minval(qsat(:,:,:)), + . maxval(qsat(:,:,:)) + ! +CC WRITE(*,*) 'QSAT :', qsat(10,20,:) + ! + varname = 'q' + qd(:,:,:) = 0.0 + q3d(:,:,:,:) = 0.0 + WRITE(*,*) 'QSAT min,max:',minval(qsat(:,:,:)), + . maxval(qsat(:,:,:)) + CALL startget(varname, iip1, jjp1, rlonv, rlatu, llm, pls, + . qsat, qd, 0.0, jjm, rlonu, rlatv , interbar ) + q3d(:,:,:,1) = qd(:,:,:) + ! + +! Ozone climatology: + if (read_climoz >= 1) call regr_lat_time_climoz(read_climoz) + + varname = 'tsol' + ! This line needs to be replaced by a call to restget to get the values in the restart file + tsol(:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, tsol, 0.0, + . jjm, rlonu, rlatv , interbar ) + ! + WRITE(*,*) 'TSOL construit :' +! WRITE(*,'(48I3)') INT(TSOL(2:klon)-273) + ! + varname = 'qsol' + qsol(:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, qsol, 0.0, + . jjm, rlonu, rlatv , interbar ) + ! + varname = 'snow' + sn(:) = 0.0 + CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, sn, 0.0, + . jjm, rlonu, rlatv , interbar ) + ! + varname = 'rads' + radsol(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,radsol,0.0, + . jjm, rlonu, rlatv , interbar ) + ! + varname = 'rugmer' + rugmer(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,rugmer,0.0, + . jjm, rlonu, rlatv , interbar ) + ! +! varname = 'agesno' +! agesno(:) = 0.0 +! CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,agesno,0.0, +! . jjm, rlonu, rlatv , interbar ) + + varname = 'zmea' + zmea(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zmea,0.0, + . jjm, rlonu, rlatv , interbar ) + + varname = 'zstd' + zstd(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zstd,0.0, + . jjm, rlonu, rlatv , interbar ) + varname = 'zsig' + zsig(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zsig,0.0, + . jjm, rlonu, rlatv , interbar ) + varname = 'zgam' + zgam(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zgam,0.0, + . jjm, rlonu, rlatv , interbar ) + varname = 'zthe' + zthe(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zthe,0.0, + . jjm, rlonu, rlatv , interbar ) + varname = 'zpic' + zpic(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zpic,0.0, + . jjm, rlonu, rlatv , interbar ) + varname = 'zval' + zval(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zval,0.0, + . jjm, rlonu, rlatv , interbar ) +c +cc rugsrel(:) = 0.0 +cc IF(ok_orodr) THEN +cc DO i = 1, iip1* jjp1 +cc rugsrel(i) = MAX( 1.e-05, zstd(i)* zsig(i) /2. ) +cc ENDDO +cc ENDIF + + +C +C lecture du fichier glace de terre pour fixer la fraction de terre +C et de glace de terre +C + CALL flininfo("landiceref.nc", iml_lic, jml_lic,llm_tmp, ttm_tmp + $ , fid) + ALLOCATE(lat_lic(iml_lic, jml_lic), stat=iret) + ALLOCATE(lon_lic(iml_lic, jml_lic), stat=iret) + ALLOCATE(dlon_lic(iml_lic), stat=iret) + ALLOCATE(dlat_lic(jml_lic), stat=iret) + ALLOCATE(fraclic(iml_lic, jml_lic), stat=iret) + CALL flinopen("landiceref.nc", .FALSE., iml_lic, jml_lic, llm_tmp + $ , lon_lic, lat_lic, lev, ttm_tmp, itaul, date, dt, fid) + CALL flinget(fid, 'landice', iml_lic, jml_lic, llm_tmp, ttm_tmp + $ , 1, 1, fraclic) + CALL flinclo(fid) +C +C interpolation sur la grille T du modele +C + WRITE(*,*) 'dimensions de landice iml_lic, jml_lic : ', + $ iml_lic, jml_lic +c +C sil les coordonnees sont en degres, on les transforme +C + IF( MAXVAL( lon_lic(:,:) ) .GT. 2.0 * asin(1.0) ) THEN + lon_lic(:,:) = lon_lic(:,:) * 2.0* ASIN(1.0) / 180. + ENDIF + IF( maxval( lat_lic(:,:) ) .GT. 2.0 * asin(1.0)) THEN + lat_lic(:,:) = lat_lic(:,:) * 2.0 * asin(1.0) / 180. + ENDIF + + dlon_lic(1 : iml_lic) = lon_lic(1 : iml_lic, 1) + dlat_lic(1 : jml_lic) = lat_lic(1 , 1 : jml_lic) +C + CALL grille_m(iml_lic, jml_lic, dlon_lic, dlat_lic, fraclic + $ ,iim, jjp1, + $ rlonv, rlatu, flic_tmp(1 : iim, 1 : jjp1)) +cx$$$ flic_tmp(1 : iim, 1 : jjp1) = champint(1: iim, 1 : jjp1) + flic_tmp(iip1, 1 : jjp1) = flic_tmp(1 , 1 : jjp1) +C +C passage sur la grille physique +C + CALL gr_dyn_fi(1, iip1, jjp1, klon, flic_tmp, + $ pctsrf(1:klon, is_lic)) +C adequation avec le maque terre/mer +c zmasq(157) = 0. + WHERE (pctsrf(1 : klon, is_lic) .LT. EPSFRA ) + pctsrf(1 : klon, is_lic) = 0. + END WHERE + WHERE (zmasq( 1 : klon) .LT. EPSFRA) + pctsrf(1 : klon, is_lic) = 0. + END WHERE + pctsrf(1 : klon, is_ter) = zmasq(1 : klon) + DO ji = 1, klon + IF (zmasq(ji) .GT. EPSFRA) THEN + IF ( pctsrf(ji, is_lic) .GE. zmasq(ji)) THEN + pctsrf(ji, is_lic) = zmasq(ji) + pctsrf(ji, is_ter) = 0. + ELSE + pctsrf(ji,is_ter) = zmasq(ji) - pctsrf(ji, is_lic) + IF (pctsrf(ji,is_ter) .LT. EPSFRA) THEN + pctsrf(ji,is_ter) = 0. + pctsrf(ji, is_lic) = zmasq(ji) + ENDIF + ENDIF + ENDIF + END DO +C +C sous surface ocean et glace de mer (pour demarrer on met glace de mer a 0) +C + pctsrf(1 : klon, is_oce) = (1. - zmasq(1 : klon)) + + + WHERE (pctsrf(1 : klon, is_oce) .LT. EPSFRA) + pctsrf(1 : klon, is_oce) = 0. + END WHERE + + if (couple) pctsrf(1 : klon, is_oce) = ocemask_fi(1 : klon) + + isst = 0 + where (pctsrf(2:klon-1,is_oce) >0.) isst = 1 +C +C verif que somme des sous surface = 1 +C + ji=count( (abs( sum(pctsrf(1 : klon, 1 : nbsrf),dim=2))-1.0) + $ .GT. EPSFRA) + IF (ji .NE. 0) THEN + WRITE(*,*) 'pb repartition sous maille pour ',ji,' points' + ENDIF + +! where (pctsrf(1:klon, is_ter) >= .5) +! pctsrf(1:klon, is_ter) = 1. +! pctsrf(1:klon, is_oce) = 0. +! pctsrf(1:klon, is_sic) = 0. +! pctsrf(1:klon, is_lic) = 0. +! zmasq = 1. +! endwhere +! where (pctsrf(1:klon, is_lic) >= .5) +! pctsrf(1:klon, is_ter) = 0. +! pctsrf(1:klon, is_oce) = 0. +! pctsrf(1:klon, is_sic) = 0. +! pctsrf(1:klon, is_lic) = 1. +! zmasq = 1. +! endwhere +! where (pctsrf(1:klon, is_oce) >= .5) +! pctsrf(1:klon, is_ter) = 0. +! pctsrf(1:klon, is_oce) = 1. +! pctsrf(1:klon, is_sic) = 0. +! pctsrf(1:klon, is_lic) = 0. +! zmasq = 0. +! endwhere +! where (pctsrf(1:klon, is_sic) >= .5) +! pctsrf(1:klon, is_ter) = 0. +! pctsrf(1:klon, is_oce) = 0. +! pctsrf(1:klon, is_sic) = 1. +! pctsrf(1:klon, is_lic) = 0. +! zmasq = 0. +! endwhere +! call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque) +C +C verif que somme des sous surface = 1 +C +! ji=count( (abs( sum(pctsrf(1 : klon, 1 : nbsrf), dim = 2)) - 1.0 ) +! $ .GT. EPSFRA) +! IF (ji .NE. 0) THEN +! WRITE(*,*) 'pb repartition sous maille pour ',ji,' points' +! ENDIF + + CALL gr_fi_ecrit(1,klon,iim,jjp1,zmasq,zx_tmp_2d) + write(*,*)'zmasq = ' + write(*,'(96i1)')nint(zx_tmp_2d) + call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque) + WRITE(*,*) 'MASQUE construit : Masque' + WRITE(*,'(97I1)') nINT(masque(:,:)) + + + +C Calcul intermediaire +c + CALL massdair( p3d, masse ) +c + + print *,' ALPHAX ',alphax + + DO l = 1, llm + DO i = 1, iim + xppn(i) = aire( i, 1 ) * masse( i , 1 , l ) + xpps(i) = aire( i,jjp1 ) * masse( i , jjp1 , l ) + ENDDO + xpn = SUM(xppn)/apoln + xps = SUM(xpps)/apols + DO i = 1, iip1 + masse( i , 1 , l ) = xpn + masse( i , jjp1 , l ) = xps + ENDDO + ENDDO + q3d(iip1,:,:,:) = q3d(1,:,:,:) + phis(iip1,:) = phis(1,:) + +C Ecriture + CALL inidissip( lstardis, nitergdiv, nitergrot, niterh , + * tetagdiv, tetagrot , tetatemp ) + print*,'sortie inidissip' + itau = 0 + itau_dyn = 0 + itau_phy = 0 + iday = dayref +itau/day_step + time = real(itau-(iday-dayref)*day_step)/day_step +c + IF(time.GT.1) THEN + time = time - 1 + iday = iday + 1 + ENDIF + day_ref = dayref + annee_ref = anneeref + + CALL geopot ( ip1jmp1, tpot , pk , pks, phis , phi ) + print*,'sortie geopot' + + CALL caldyn0 ( itau,uvent,vvent,tpot,psol,masse,pk,phis , + * phi,w, pbaru,pbarv,time+iday-dayref ) + print*,'sortie caldyn0' + CALL dynredem0("start.nc",dayref,phis) + print*,'sortie dynredem0' + CALL dynredem1("start.nc",0.0,vvent,uvent,tpot,q3d,masse , + . psol) + print*,'sortie dynredem1' +C +C Ecriture etat initial physique +C + write(*,*)'phystep ',dtvr,iphysiq,nbapp_rad + phystep = dtvr * FLOAT(iphysiq) + radpas = NINT (86400./phystep/ FLOAT(nbapp_rad) ) + write(*,*)'phystep =', phystep, radpas +cIM : lecture de co2_ppm & solaire ds physiq.def +c co2_ppm = 348.0 +c solaire = 1365.0 + +c +c Initialisation +c tsol, qsol, sn,albe, evap,tsoil,rain_fall, snow_fall,solsw, sollw,frugs +c + ftsol(:,is_ter) = tsol + ftsol(:,is_lic) = tsol + ftsol(:,is_oce) = tsol + ftsol(:,is_sic) = tsol + snsrf(:,is_ter) = sn + snsrf(:,is_lic) = sn + snsrf(:,is_oce) = sn + snsrf(:,is_sic) = sn + falb1(:,is_ter) = 0.08 + falb1(:,is_lic) = 0.6 + falb1(:,is_oce) = 0.5 + falb1(:,is_sic) = 0.6 + falb2 = falb1 + evap(:,:) = 0. + qsolsrf(:,is_ter) = 150 + qsolsrf(:,is_lic) = 150 + qsolsrf(:,is_oce) = 150. + qsolsrf(:,is_sic) = 150. + do i = 1, nbsrf + do j = 1, nsoilmx + tsoil(:,j,i) = tsol + enddo + enddo + rain_fall = 0.; snow_fall = 0. + solsw = 165. + sollw = -53. + t_ancien = 273.15 + q_ancien = 0. + agesno = 0. +c + frugs(1:klon,is_oce) = rugmer(1:klon) + frugs(1:klon,is_ter) = MAX(1.0e-05, zstd(1:klon)*zsig(1:klon)/2.0) + frugs(1:klon,is_lic) = MAX(1.0e-05, zstd(1:klon)*zsig(1:klon)/2.0) + frugs(1:klon,is_sic) = 0.001 + fder = 0.0 + clwcon = 0.0 + rnebcon = 0.0 + ratqs = 0.0 + run_off_lic_0 = 0.0 + rugoro = 0.0 + +c +c Avant l'appel a phyredem, on initialize les modules de surface +c avec les valeurs qui vont etre ecrit dans startphy.nc +c + dummy = 1.0 + pbl_tke(:,:,:) = 1.e-8 + zmax0(:) = 40. + f0(:) = 1.e-5 + ema_work1(:,:) = 0. + ema_work2(:,:) = 0. + wake_deltat(:,:) = 0. + wake_deltaq(:,:) = 0. + wake_s(:) = 0. + wake_cstar(:) = 0. + wake_fip(:) = 0. + + call fonte_neige_init(run_off_lic_0) + call pbl_surface_init(qsol, fder, snsrf, qsolsrf, + $ evap, frugs, agesno, tsoil) + + call phyredem("startphy.nc") + + + +C Sortie Visu pour les champs dynamiques +cc if (1.eq.0 ) then +cc print*,'sortie visu' +cc time_step = 1. +cc t_ops = 2. +cc t_wrt = 2. +cc itau = 2. +cc visu_file='Etat0_visu.nc' +cc CALL initdynav(visu_file,dayref,anneeref,time_step, +cc . t_ops, t_wrt, visuid) +cc CALL writedynav(visuid, itau,vvent , +cc . uvent,tpot,pk,phi,q3d,masse,psol,phis) +cc else + print*,'CCCCCCCCCCCCCCCCCC REACTIVER SORTIE VISU DANS ETAT0' +cc endif + print*,'entree histclo' + CALL histclo + +#endif +!#endif of #ifdef CPP_EARTH + RETURN + ! + END SUBROUTINE etat0_netcdf Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/exner_hyb.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/exner_hyb.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/exner_hyb.F (revision 1280) @@ -0,0 +1,114 @@ +! +! $Header$ +! + SUBROUTINE exner_hyb ( ngrid, ps, p,alpha,beta, pks, pk, pkf ) +c +c Auteurs : P.Le Van , Fr. Hourdin . +c .......... +c +c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... +c .... alpha,beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... +c +c ************************************************************************ +c Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des +c couches . Pk(l) sera calcule aux milieux des couches l ,entre les +c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . +c ************************************************************************ +c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont +c la pression et la fonction d'Exner au sol . +c +c -------- z +c A partir des relations ( 1 ) p*dz(pk) = kappa *pk*dz(p) et +c ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1) +c ( voir note de Fr.Hourdin ) , +c +c on determine successivement , du haut vers le bas des couches, les +c coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), +c puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches, +c pk(ij,l) donne par la relation (2), pour l = 2 a l = llm . +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" +#include "serre.h" + + INTEGER ngrid + REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm) + REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm) + +c .... variables locales ... + + INTEGER l, ij + REAL unpl2k,dellta + + REAL ppn(iim),pps(iim) + REAL xpn, xps + REAL SSUM +c + + unpl2k = 1.+ 2.* kappa +c + DO ij = 1, ngrid + pks(ij) = cpp * ( ps(ij)/preff ) ** kappa + ENDDO + + DO ij = 1, iim + ppn(ij) = aire( ij ) * pks( ij ) + pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) + ENDDO + xpn = SSUM(iim,ppn,1) /apoln + xps = SSUM(iim,pps,1) /apols + + DO ij = 1, iip1 + pks( ij ) = xpn + pks( ij+ip1jm ) = xps + ENDDO +c +c +c .... Calcul des coeff. alpha et beta pour la couche l = llm .. +c + DO ij = 1, ngrid + alpha(ij,llm) = 0. + beta (ij,llm) = 1./ unpl2k + ENDDO +c +c ... Calcul des coeff. alpha et beta pour l = llm-1 a l = 2 ... +c + DO l = llm -1 , 2 , -1 +c + DO ij = 1, ngrid + dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k ) + alpha(ij,l) = - p(ij,l+1) / dellta * alpha(ij,l+1) + beta (ij,l) = p(ij,l ) / dellta + ENDDO +c + ENDDO +c +c *********************************************************************** +c ..... Calcul de pk pour la couche 1 , pres du sol .... +c + DO ij = 1, ngrid + pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) ) / + * ( p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) ) + ENDDO +c +c ..... Calcul de pk(ij,l) , pour l = 2 a l = llm ........ +c + DO l = 2, llm + DO ij = 1, ngrid + pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1) + ENDDO + ENDDO +c +c + CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) + + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/exner_hyb_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/exner_hyb_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/exner_hyb_p.F (revision 1280) @@ -0,0 +1,153 @@ + SUBROUTINE exner_hyb_p ( ngrid, ps, p,alpha,beta, pks, pk, pkf ) +c +c Auteurs : P.Le Van , Fr. Hourdin . +c .......... +c +c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... +c .... alpha,beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... +c +c ************************************************************************ +c Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des +c couches . Pk(l) sera calcule aux milieux des couches l ,entre les +c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . +c ************************************************************************ +c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont +c la pression et la fonction d'Exner au sol . +c +c -------- z +c A partir des relations ( 1 ) p*dz(pk) = kappa *pk*dz(p) et +c ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1) +c ( voir note de Fr.Hourdin ) , +c +c on determine successivement , du haut vers le bas des couches, les +c coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), +c puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches, +c pk(ij,l) donne par la relation (2), pour l = 2 a l = llm . +c +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" +#include "serre.h" + + INTEGER ngrid + REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm) + REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm) + +c .... variables locales ... + + INTEGER l, ij + REAL unpl2k,dellta + + REAL ppn(iim),pps(iim) + REAL xpn, xps + REAL SSUM + EXTERNAL SSUM + INTEGER ije,ijb,jje,jjb +c +c$OMP BARRIER + unpl2k = 1.+ 2.* kappa +c + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pks(ij) = cpp * ( ps(ij)/preff ) ** kappa + ENDDO +c$OMP ENDDO +c Synchro OPENMP ici + +c$OMP MASTER + if (pole_nord) then + DO ij = 1, iim + ppn(ij) = aire( ij ) * pks( ij ) + ENDDO + xpn = SSUM(iim,ppn,1) /apoln + + DO ij = 1, iip1 + pks( ij ) = xpn + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iim + pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) + ENDDO + xps = SSUM(iim,pps,1) /apols + + DO ij = 1, iip1 + pks( ij+ip1jm ) = xps + ENDDO + endif +c$OMP END MASTER +c +c +c .... Calcul des coeff. alpha et beta pour la couche l = llm .. +c +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb,ije + alpha(ij,llm) = 0. + beta (ij,llm) = 1./ unpl2k + ENDDO +c$OMP ENDDO NOWAIT +c +c ... Calcul des coeff. alpha et beta pour l = llm-1 a l = 2 ... +c + DO l = llm -1 , 2 , -1 +c +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k ) + alpha(ij,l) = - p(ij,l+1) / dellta * alpha(ij,l+1) + beta (ij,l) = p(ij,l ) / dellta + ENDDO +c$OMP ENDDO NOWAIT +c + ENDDO + +c +c *********************************************************************** +c ..... Calcul de pk pour la couche 1 , pres du sol .... +c +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) ) / + * ( p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) ) + ENDDO +c$OMP ENDDO NOWAIT +c +c ..... Calcul de pk(ij,l) , pour l = 2 a l = llm ........ +c + DO l = 2, llm +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1) + ENDDO +c$OMP ENDDO NOWAIT + ENDDO +c +c +c CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + DO l = 1, llm +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pkf(ij,l)=pk(ij,l) + ENDDO +c$OMP ENDDO NOWAIT + ENDDO + +c$OMP BARRIER + + jjb=jj_begin + jje=jj_end + CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) + + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/extrapol.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/extrapol.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/extrapol.F (revision 1280) @@ -0,0 +1,200 @@ +! +! $Header$ +! +C +C + SUBROUTINE extrapol (pfild, kxlon, kylat, pmask, + . norsud, ldper, knbor, pwork) + IMPLICIT none +c +c OASIS routine (Adaptation: Laurent Li, le 14 mars 1997) +c Fill up missed values by using the neighbor points +c + INTEGER kxlon, kylat ! longitude and latitude dimensions (Input) + INTEGER knbor ! minimum neighbor number (Input) + LOGICAL norsud ! True if field is from North to South (Input) + LOGICAL ldper ! True if take into account the periodicity (Input) + REAL pmask ! mask value (Input) + REAL pfild(kxlon,kylat) ! field to be extrapolated (Input/Output) + REAL pwork(kxlon,kylat) ! working space +c + REAL zwmsk + INTEGER incre, idoit, i, j, k, inbor, ideb, ifin, ilon, jlat + INTEGER ix(9), jy(9) ! index arrays for the neighbors coordinates + REAL zmask(9) +C +C We search over the eight closest neighbors +C +C j+1 7 8 9 +C j 4 5 6 Current point 5 --> (i,j) +C j-1 1 2 3 +C i-1 i i+1 +c +c + IF (norsud) THEN + DO j = 1, kylat + DO i = 1, kxlon + pwork(i,j) = pfild(i,kylat-j+1) + ENDDO + ENDDO + DO j = 1, kylat + DO i = 1, kxlon + pfild(i,j) = pwork(i,j) + ENDDO + ENDDO + ENDIF +c + incre = 0 +c + DO j = 1, kylat + DO i = 1, kxlon + pwork(i,j) = pfild(i,j) + ENDDO + ENDDO +c +C* To avoid problems in floating point tests + zwmsk = pmask - 1.0 +c +200 CONTINUE + incre = incre + 1 + DO 99999 j = 1, kylat + DO 99999 i = 1, kxlon + IF (pfild(i,j).GT. zwmsk) THEN + pwork(i,j) = pfild(i,j) + inbor = 0 + ideb = 1 + ifin = 9 +C +C* Fill up ix array + ix(1) = MAX (1,i-1) + ix(2) = i + ix(3) = MIN (kxlon,i+1) + ix(4) = MAX (1,i-1) + ix(5) = i + ix(6) = MIN (kxlon,i+1) + ix(7) = MAX (1,i-1) + ix(8) = i + ix(9) = MIN (kxlon,i+1) +C +C* Fill up iy array + jy(1) = MAX (1,j-1) + jy(2) = MAX (1,j-1) + jy(3) = MAX (1,j-1) + jy(4) = j + jy(5) = j + jy(6) = j + jy(7) = MIN (kylat,j+1) + jy(8) = MIN (kylat,j+1) + jy(9) = MIN (kylat,j+1) +C +C* Correct latitude bounds if southernmost or northernmost points + IF (j .EQ. 1) ideb = 4 + IF (j .EQ. kylat) ifin = 6 +C +C* Account for periodicity in longitude +C + IF (ldper) THEN + IF (i .EQ. kxlon) THEN + ix(3) = 1 + ix(6) = 1 + ix(9) = 1 + ELSE IF (i .EQ. 1) THEN + ix(1) = kxlon + ix(4) = kxlon + ix(7) = kxlon + ENDIF + ELSE + IF (i .EQ. 1) THEN + ix(1) = i + ix(2) = i + 1 + ix(3) = i + ix(4) = i + 1 + ix(5) = i + ix(6) = i + 1 + ENDIF + IF (i .EQ. kxlon) THEN + ix(1) = i -1 + ix(2) = i + ix(3) = i - 1 + ix(4) = i + ix(5) = i - 1 + ix(6) = i + ENDIF +C + IF (i .EQ. 1 .OR. i .EQ. kxlon) THEN + jy(1) = MAX (1,j-1) + jy(2) = MAX (1,j-1) + jy(3) = j + jy(4) = j + jy(5) = MIN (kylat,j+1) + jy(6) = MIN (kylat,j+1) +C + ideb = 1 + ifin = 6 + IF (j .EQ. 1) ideb = 3 + IF (j .EQ. kylat) ifin = 4 + ENDIF + ENDIF ! end for ldper test +C +C* Find unmasked neighbors +C + DO 230 k = ideb, ifin + zmask(k) = 0. + ilon = ix(k) + jlat = jy(k) + IF (pfild(ilon,jlat) .LT. zwmsk) THEN + zmask(k) = 1. + inbor = inbor + 1 + ENDIF + 230 CONTINUE +C +C* Not enough points around point P are unmasked; interpolation on P +C will be done in a future call to extrap. +C + IF (inbor .GE. knbor) THEN + pwork(i,j) = 0. + DO k = ideb, ifin + ilon = ix(k) + jlat = jy(k) + pwork(i,j) = pwork(i,j) + $ + pfild(ilon,jlat) * zmask(k)/FLOAT(inbor) + ENDDO + ENDIF +C + ENDIF +99999 CONTINUE +C +C* 3. Writing back unmasked field in pfild +C ------------------------------------ +C +C* pfild then contains: +C - Values which were not masked +C - Interpolated values from the inbor neighbors +C - Values which are not yet interpolated +C + idoit = 0 + DO j = 1, kylat + DO i = 1, kxlon + IF (pwork(i,j) .GT. zwmsk) idoit = idoit + 1 + pfild(i,j) = pwork(i,j) + ENDDO + ENDDO +c + IF (idoit .ne. 0) GOTO 200 +ccc PRINT*, "Number of extrapolation steps incre =", incre +c + IF (norsud) THEN + DO j = 1, kylat + DO i = 1, kxlon + pwork(i,j) = pfild(i,kylat-j+1) + ENDDO + ENDDO + DO j = 1, kylat + DO i = 1, kxlon + pfild(i,j) = pwork(i,j) + ENDDO + ENDDO + ENDIF +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/filtreg_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/filtreg_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/filtreg_p.F (revision 1280) @@ -0,0 +1,400 @@ + + + SUBROUTINE filtreg_p ( champ, ibeg, iend, nlat, nbniv, + & ifiltre, iaire, griscal ,iter) + USE Parallel, only : OMP_CHUNK + USE mod_filtre_fft + USE timer_filtre + + USE filtreg_mod + + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van 07/10/97 +c ------ +c +c Objet: filtre matriciel longitudinal ,avec les matrices precalculees +c pour l'operateur Filtre . +c ------ +c +c Arguments: +c ---------- +c +c +c ibeg..iend lattitude a filtrer +c nlat nombre de latitudes du champ +c nbniv nombre de niveaux verticaux a filtrer +c champ(iip1,nblat,nbniv) en entree : champ a filtrer +c en sortie : champ filtre +c ifiltre +1 Transformee directe +c -1 Transformee inverse +c +2 Filtre directe +c -2 Filtre inverse +c +c iaire 1 si champ intensif +c 2 si champ extensif (pondere par les aires) +c +c iter 1 filtre simple +c +c======================================================================= +c +c +c Variable Intensive +c ifiltre = 1 filtre directe +c ifiltre =-1 filtre inverse +c +c Variable Extensive +c ifiltre = 2 filtre directe +c ifiltre =-2 filtre inverse +c +c +#include "dimensions.h" +#include "paramet.h" +#include "coefils.h" +c + INTEGER ibeg,iend,nlat,nbniv,ifiltre,iter + INTEGER i,j,l,k + INTEGER iim2,immjm + INTEGER jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil + + REAL champ( iip1,nlat,nbniv) + + LOGICAL griscal + INTEGER hemisph, iaire + + REAL :: champ_fft(iip1,nlat,nbniv) + REAL :: champ_in(iip1,nlat,nbniv) + + LOGICAL,SAVE :: first=.TRUE. +c$OMP THREADPRIVATE(first) + + REAL, DIMENSION(iip1,nlat,nbniv) :: champ_loc + INTEGER :: ll_nb, nbniv_loc + REAL, SAVE :: sdd12(iim,4) +c$OMP THREADPRIVATE(sdd12) + + INTEGER, PARAMETER :: type_sddu=1 + INTEGER, PARAMETER :: type_sddv=2 + INTEGER, PARAMETER :: type_unsddu=3 + INTEGER, PARAMETER :: type_unsddv=4 + + INTEGER :: sdd1_type, sdd2_type + + IF (first) THEN + sdd12(1:iim,type_sddu) = sddu(1:iim) + sdd12(1:iim,type_sddv) = sddv(1:iim) + sdd12(1:iim,type_unsddu) = unsddu(1:iim) + sdd12(1:iim,type_unsddv) = unsddv(1:iim) + + CALL Init_timer + first=.FALSE. + ENDIF + +c$OMP MASTER + CALL start_timer +c$OMP END MASTER + +c-------------------------------------------------------c + + IF(ifiltre.EQ.1.or.ifiltre.EQ.-1) + & STOP'Pas de transformee simple dans cette version' + + IF( iter.EQ. 2 ) THEN + PRINT *,' Pas d iteration du filtre dans cette version !' + & , ' Utiliser old_filtreg et repasser !' + STOP + ENDIF + + IF( ifiltre.EQ. -2 .AND..NOT.griscal ) THEN + PRINT *,' Cette routine ne calcule le filtre inverse que ' + & , ' sur la grille des scalaires !' + STOP + ENDIF + + IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 ) THEN + PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2' + & , ' corriger et repasser !' + STOP + ENDIF +c + + iim2 = iim * iim + immjm = iim * jjm +c +c + IF( griscal ) THEN + IF( nlat. NE. jjp1 ) THEN + PRINT 1111 + STOP + ELSE +c + IF( iaire.EQ.1 ) THEN + sdd1_type = type_sddv + sdd2_type = type_unsddv + ELSE + sdd1_type = type_unsddv + sdd2_type = type_sddv + ENDIF +c + jdfil1 = 2 + jffil1 = jfiltnu + jdfil2 = jfiltsu + jffil2 = jjm + ENDIF + ELSE + IF( nlat.NE.jjm ) THEN + PRINT 2222 + STOP + ELSE +c + IF( iaire.EQ.1 ) THEN + sdd1_type = type_sddu + sdd2_type = type_unsddu + ELSE + sdd1_type = type_unsddu + sdd2_type = type_sddu + ENDIF +c + jdfil1 = 1 + jffil1 = jfiltnv + jdfil2 = jfiltsv + jffil2 = jjm + ENDIF + ENDIF +c + DO hemisph = 1, 2 +c + IF ( hemisph.EQ.1 ) THEN +cym + jdfil = max(jdfil1,ibeg) + jffil = min(jffil1,iend) + ELSE +cym + jdfil = max(jdfil2,ibeg) + jffil = min(jffil2,iend) + ENDIF + + +cccccccccccccccccccccccccccccccccccccccccccc +c Utilisation du filtre classique +cccccccccccccccccccccccccccccccccccccccccccc + + IF (.NOT. use_filtre_fft) THEN + +c !---------------------------------! +c ! Agregation des niveau verticaux ! +c ! uniquement necessaire pour une ! +c ! execution OpenMP ! +c !---------------------------------! + ll_nb = 0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, nbniv + ll_nb = ll_nb+1 + DO j = jdfil,jffil + DO i = 1, iim + champ_loc(i,j,ll_nb) = + & champ(i,j,l) * sdd12(i,sdd1_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + + nbniv_loc = ll_nb + + IF( hemisph.EQ.1 ) THEN + + IF( ifiltre.EQ.-2 ) THEN + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matrinvn(1,1,j), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ELSE IF ( griscal ) THEN + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matriceun(1,1,j), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ELSE + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matricevn(1,1,j), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ENDIF + + ELSE + + IF( ifiltre.EQ.-2 ) THEN + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matrinvs(1,1,j-jfiltsu+1), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ELSE IF ( griscal ) THEN + + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matriceus(1,1,j-jfiltsu+1), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ELSE + + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matricevs(1,1,j-jfiltsv+1), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ENDIF + + ENDIF +! c + IF( ifiltre.EQ.2 ) THEN + +c !-------------------------------------! +c ! Dés-agregation des niveau verticaux ! +c ! uniquement necessaire pour une ! +c ! execution OpenMP ! +c !-------------------------------------! + ll_nb = 0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, nbniv + ll_nb = ll_nb + 1 + DO j = jdfil,jffil + DO i = 1, iim + champ( i,j,l ) = (champ_loc(i,j,ll_nb) + & + champ_fft(i,j-jdfil+1,ll_nb)) + & * sdd12(i,sdd2_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ELSE + + ll_nb = 0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, nbniv_loc + ll_nb = ll_nb + 1 + DO j = jdfil,jffil + DO i = 1, iim + champ( i,j,l ) = (champ_loc(i,j,ll_nb) + & - champ_fft(i,j-jdfil+1,ll_nb)) + & * sdd12(i,sdd2_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ENDIF + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, nbniv + DO j = jdfil,jffil + champ( iip1,j,l ) = champ( 1,j,l ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +ccccccccccccccccccccccccccccccccccccccccccccc +c Utilisation du filtre FFT +ccccccccccccccccccccccccccccccccccccccccccccc + + ELSE + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + DO j=jdfil,jffil + DO i = 1, iim + champ( i,j,l)= champ(i,j,l)*sdd12(i,sdd1_type) + champ_fft( i,j,l) = champ(i,j,l) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + + IF (jdfil<=jffil) THEN + IF( ifiltre. EQ. -2 ) THEN + CALL Filtre_inv_fft(champ_fft,nlat,jdfil,jffil,nbniv) + ELSE IF ( griscal ) THEN + CALL Filtre_u_fft(champ_fft,nlat,jdfil,jffil,nbniv) + ELSE + CALL Filtre_v_fft(champ_fft,nlat,jdfil,jffil,nbniv) + ENDIF + ENDIF + + + IF( ifiltre.EQ. 2 ) THEN +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + DO j=jdfil,jffil + DO i = 1, iim + champ( i,j,l)=(champ(i,j,l)+champ_fft(i,j,l)) + & *sdd12(i,sdd2_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + ELSE + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + DO j=jdfil,jffil + DO i = 1, iim + champ(i,j,l)=(champ(i,j,l)-champ_fft(i,j,l)) + & *sdd12(i,sdd2_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDIF +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + DO j=jdfil,jffil +! champ_FFT( iip1,j,l ) = champ_FFT( 1,j,l ) + champ( iip1,j,l ) = champ( 1,j,l ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDIF +c Fin de la zone de filtrage + + + ENDDO + +! DO j=1,nlat +! +! PRINT *,"check FFT ----> Delta(",j,")=", +! & sum(champ(:,j,:)-champ_fft(:,j,:))/sum(champ(:,j,:)), +! & sum(champ(:,j,:)-champ_in(:,j,:))/sum(champ(:,j,:)) +! ENDDO + +! PRINT *,"check FFT ----> Delta(",j,")=", +! & sum(champ-champ_fft)/sum(champ) +! + +c + 1111 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a + & filtrer, sur la grille des scalaires'/) + 2222 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi + & ltrer, sur la grille de V ou de Z'/) +c$OMP MASTER + CALL stop_timer +c$OMP END MASTER + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/flumass.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/flumass.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/flumass.F (revision 1280) @@ -0,0 +1,109 @@ +! +! $Header$ +! + SUBROUTINE flumass (massebx,masseby, vcont, ucont, pbaru, pbarv ) + + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van, F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c .... calcul du flux de masse aux niveaux s ...... +c ********************************************************************* +c massebx,masseby,vcont et ucont sont des argum. d'entree pour le s-pg . +c pbaru et pbarv sont des argum.de sortie pour le s-pg . +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL massebx( ip1jmp1,llm ),masseby( ip1jm,llm ) , + * vcont( ip1jm,llm ),ucont( ip1jmp1,llm ),pbaru( ip1jmp1,llm ), + * pbarv( ip1jm,llm ) + + REAL apbarun( iip1 ),apbarus( iip1 ) + + REAL sairen,saireun,saires,saireus,ctn,cts,ctn0,cts0 + INTEGER l,ij,i + + REAL SSUM + + + DO 5 l = 1,llm + + DO 1 ij = iip2,ip1jm + pbaru( ij,l ) = massebx( ij,l ) * ucont( ij,l ) + 1 CONTINUE + + DO 3 ij = 1,ip1jm + pbarv( ij,l ) = masseby( ij,l ) * vcont( ij,l ) + 3 CONTINUE + + 5 CONTINUE + +c ................................................................ +c calcul de la composante du flux de masse en x aux poles ....... +c ................................................................ +c par la resolution d'1 systeme de 2 equations . + +c la premiere equat.decrivant le calcul de la divergence en 1 point i +c du pole,ce calcul etant itere de i=1 a i=im . +c c.a.d , +c ( ( 0.5*pbaru(i)-0.5*pbaru(i-1) - pbarv(i))/aire(i) = +c - somme de ( pbarv(n) )/aire pole + +c l'autre equat.specifiant que la moyenne du flux de masse au pole est =0. +c c.a.d somme de pbaru(n)*aire locale(n) = 0. + +c on en revient ainsi a determiner la constante additive commune aux pbaru +c qui representait pbaru(0,j,l) dans l'equat.du calcul de la diverg.au pt +c i=1 . +c i variant de 1 a im +c n variant de 1 a im + + sairen = SSUM( iim, aire( 1 ), 1 ) + saireun= SSUM( iim, aireu( 1 ), 1 ) + saires = SSUM( iim, aire( ip1jm+1 ), 1 ) + saireus= SSUM( iim, aireu( ip1jm+1 ), 1 ) + + DO 20 l = 1,llm + + ctn = SSUM( iim, pbarv( 1 ,l), 1 )/ sairen + cts = SSUM( iim, pbarv(ip1jmi1+ 1,l), 1 )/ saires + + pbaru( 1 ,l )= pbarv( 1 ,l ) - ctn * aire( 1 ) + pbaru( ip1jm+1,l )= - pbarv( ip1jmi1+1,l ) + cts * aire( ip1jm+1 ) + + DO 11 i = 2,iim + pbaru( i ,l ) = pbaru( i - 1 ,l ) + + * pbarv( i ,l ) - ctn * aire( i ) + + pbaru( i+ ip1jm,l ) = pbaru( i+ ip1jm-1,l ) - + * pbarv( i+ ip1jmi1,l ) + cts * aire(i+ ip1jm) + 11 CONTINUE + DO 12 i = 1,iim + apbarun(i) = aireu( i ) * pbaru( i , l) + apbarus(i) = aireu(i +ip1jm) * pbaru(i +ip1jm, l) + 12 CONTINUE + ctn0 = -SSUM( iim,apbarun,1 )/saireun + cts0 = -SSUM( iim,apbarus,1 )/saireus + DO 14 i = 1,iim + pbaru( i , l) = 2. * ( pbaru( i , l) + ctn0 ) + pbaru(i+ ip1jm, l) = 2. * ( pbaru(i +ip1jm, l) + cts0 ) + 14 CONTINUE + + pbaru( iip1 ,l ) = pbaru( 1 ,l ) + pbaru( ip1jmp1,l ) = pbaru( ip1jm +1,l ) + 20 CONTINUE + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/flumass_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/flumass_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/flumass_p.F (revision 1280) @@ -0,0 +1,152 @@ + SUBROUTINE flumass_p(massebx,masseby, vcont, ucont, pbaru, pbarv) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van, F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c .... calcul du flux de masse aux niveaux s ...... +c ********************************************************************* +c massebx,masseby,vcont et ucont sont des argum. d'entree pour le s-pg . +c pbaru et pbarv sont des argum.de sortie pour le s-pg . +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL massebx( ip1jmp1,llm ),masseby( ip1jm,llm ) , + * vcont( ip1jm,llm ),ucont( ip1jmp1,llm ),pbaru( ip1jmp1,llm ), + * pbarv( ip1jm,llm ) + + REAL apbarun( iip1 ),apbarus( iip1 ) + + REAL sairen,saireun,saires,saireus,ctn,cts,ctn0,cts0 + INTEGER l,ij,i + INTEGER ijb,ije + + EXTERNAL SSUM + REAL SSUM + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,llm + + ijb=ij_begin + ije=ij_end+iip1 + + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO 1 ij = ijb,ije + pbaru( ij,l ) = massebx( ij,l ) * ucont( ij,l ) + 1 CONTINUE + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO 3 ij = ijb,ije + pbarv( ij,l ) = masseby( ij,l ) * vcont( ij,l ) + 3 CONTINUE + + 5 CONTINUE +c$OMP END DO NOWAIT +c ................................................................ +c calcul de la composante du flux de masse en x aux poles ....... +c ................................................................ +c par la resolution d'1 systeme de 2 equations . + +c la premiere equat.decrivant le calcul de la divergence en 1 point i +c du pole,ce calcul etant itere de i=1 a i=im . +c c.a.d , +c ( ( 0.5*pbaru(i)-0.5*pbaru(i-1) - pbarv(i))/aire(i) = +c - somme de ( pbarv(n) )/aire pole + +c l'autre equat.specifiant que la moyenne du flux de masse au pole est =0. +c c.a.d somme de pbaru(n)*aire locale(n) = 0. + +c on en revient ainsi a determiner la constante additive commune aux pbaru +c qui representait pbaru(0,j,l) dans l'equat.du calcul de la diverg.au pt +c i=1 . +c i variant de 1 a im +c n variant de 1 a im + + IF (pole_nord) THEN + + sairen = SSUM( iim, aire( 1 ), 1 ) + saireun= SSUM( iim, aireu( 1 ), 1 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + + ctn = SSUM( iim, pbarv( 1 ,l), 1 )/ sairen + + pbaru(1,l)=pbarv(1,l) - ctn * aire(1) + + DO i = 2,iim + pbaru(i,l) = pbaru(i- 1,l ) + + * pbarv(i,l) - ctn * aire(i ) + ENDDO + + DO i = 1,iim + apbarun(i) = aireu( i ) * pbaru( i , l) + ENDDO + + ctn0 = -SSUM( iim,apbarun,1 )/saireun + + DO i = 1,iim + pbaru( i , l) = 2. * ( pbaru( i , l) + ctn0 ) + ENDDO + + pbaru( iip1 ,l ) = pbaru( 1 ,l ) + + ENDDO +c$OMP END DO NOWAIT + + ENDIF + + + IF (pole_sud) THEN + + saires = SSUM( iim, aire( ip1jm+1 ), 1 ) + saireus= SSUM( iim, aireu( ip1jm+1 ), 1 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + + cts = SSUM( iim, pbarv(ip1jmi1+ 1,l), 1 )/ saires + pbaru(ip1jm+1,l)= - pbarv(ip1jmi1+1,l) + cts * aire(ip1jm+1) + + DO i = 2,iim + pbaru(i+ ip1jm,l) = pbaru(i+ip1jm-1,l) - + * pbarv(i+ip1jmi1,l)+cts*aire(i+ip1jm) + ENDDO + + DO i = 1,iim + apbarus(i) = aireu(i +ip1jm) * pbaru(i +ip1jm, l) + ENDDO + + cts0 = -SSUM( iim,apbarus,1 )/saireus + + DO i = 1,iim + pbaru(i+ ip1jm, l) = 2. * ( pbaru(i +ip1jm, l) + cts0 ) + ENDDO + + pbaru( ip1jmp1,l ) = pbaru( ip1jm +1,l ) + + ENDDO +c$OMP END DO NOWAIT + ENDIF + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fluxstokenc_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fluxstokenc_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fluxstokenc_p.F (revision 1280) @@ -0,0 +1,250 @@ +! +! $Id$ +! + SUBROUTINE fluxstokenc_p(pbaru,pbarv,masse,teta,phi,phis, + . time_step,itau ) +#ifdef CPP_EARTH +! This routine is designed to work for Earth and with ioipsl + + USE IOIPSL + USE parallel + USE misc_mod + USE mod_hallo +c +c Auteur : F. Hourdin +c +c +ccc .. Modif. P. Le Van ( 20/12/97 ) ... +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "tracstoke.h" +#include "temps.h" +#include "iniprint.h" + + REAL time_step,t_wrt, t_ops + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm) + REAL phis(ip1jmp1) + + REAL,SAVE :: pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm) + REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm) + + REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm) + + REAL pbarvst(iip1,jjp1,llm),zistdyn + real dtcum + + INTEGER iadvtr,ndex(1) + integer nscal + real tst(1),ist(1),istp(1) + INTEGER ij,l,irec,i,j,itau + INTEGER,SAVE :: fluxid, fluxvid,fluxdid + + SAVE iadvtr, massem,irec + SAVE phic,tetac + logical first + save first + data first/.true./ + DATA iadvtr/0/ + integer :: ijb,ije,jjb,jje,jjn + type(Request) :: Req + +c AC initialisations +cym pbarug(:,:) = 0. +cym pbarvg(:,:,:) = 0. +cym wg(:,:) = 0. + +c$OMP MASTER + + if(first) then + + CALL initfluxsto_p( 'fluxstoke', + . time_step,istdyn* time_step,istdyn* time_step, + . fluxid,fluxvid,fluxdid) + + ijb=ij_begin + ije=ij_end + jjn=jj_nb + + ndex(1) = 0 + call histwrite(fluxid, 'phis', 1, phis(ijb:ije), + . iip1*jjn, ndex) + call histwrite(fluxid, 'aire', 1, aire(ijb:ije), + . iip1*jjn, ndex) + + ndex(1) = 0 + nscal = 1 + + if (mpi_rank==0) then + tst(1) = time_step + call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex) + ist(1)=istdyn + call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex) + istp(1)= istphy + call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex) + endif + first = .false. + + endif + + + IF(iadvtr.EQ.0) THEN +cym CALL initial0(ijp1llm,phic) +cym CALL initial0(ijp1llm,tetac) +cym CALL initial0(ijp1llm,pbaruc) +cym CALL initial0(ijmllm,pbarvc) + ijb=ij_begin + ije=ij_end + phic(ijb:ije,1:llm)=0 + tetac(ijb:ije,1:llm)=0 + pbaruc(ijb:ije,1:llm)=0 + + IF (pole_sud) ije=ij_end-iip1 + pbarvc(ijb:ije,1:llm)=0 + ENDIF + +c accumulation des flux de masse horizontaux + ijb=ij_begin + ije=ij_end + + DO l=1,llm + DO ij = ijb,ije + pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l) + tetac(ij,l) = tetac(ij,l) + teta(ij,l) + phic(ij,l) = phic(ij,l) + phi(ij,l) + ENDDO + ENDDO + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO l=1,llm + DO ij = ijb,ije + pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l) + ENDDO + ENDDO + +c selection de la masse instantannee des mailles avant le transport. + IF(iadvtr.EQ.0) THEN +cym CALL SCOPY(ip1jmp1*llm,masse,1,massem,1) + ijb=ij_begin + ije=ij_end + massem(ijb:ije,1:llm)=masse(ijb:ije,1:llm) + ENDIF + + iadvtr = iadvtr+1 + +c$OMP END MASTER +c$OMP BARRIER +c Test pour savoir si on advecte a ce pas de temps + IF ( iadvtr.EQ.istdyn ) THEN +c$OMP MASTER +c normalisation + ijb=ij_begin + ije=ij_end + + DO l=1,llm + DO ij = ijb,ije + pbaruc(ij,l) = pbaruc(ij,l)/float(istdyn) + tetac(ij,l) = tetac(ij,l)/float(istdyn) + phic(ij,l) = phic(ij,l)/float(istdyn) + ENDDO + ENDDO + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO l=1,llm + DO ij = ijb,ije + pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn) + ENDDO + ENDDO + +c traitement des flux de masse avant advection. +c 1. calcul de w +c 2. groupement des mailles pres du pole. +c$OMP END MASTER +c$OMP BARRIER + call Register_Hallo(pbaruc,ip1jmp1,llm,1,1,1,1,Req) + call Register_Hallo(pbarvc,ip1jm,llm,1,1,1,1,Req) + call SendRequest(Req) +c$OMP BARRIER + call WaitRequest(Req) +c$OMP BARRIER +c$OMP MASTER + CALL groupe_p( massem, pbaruc,pbarvc, pbarug,pbarvg,wg ) + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + do l=1,llm + do j=jjb,jje + do i=1,iip1 + pbarvst(i,j,l)=pbarvg(i,j,l) + enddo + enddo + enddo + + if (pole_sud) then + do i=1,iip1 + pbarvst(i,jjp1,l)=0. + enddo + endif + + iadvtr=0 + Print*,'ITAU auqel on stoke les fluxmasses',itau + + ijb=ij_begin + ije=ij_end + jjn=jj_nb + + call histwrite(fluxid, 'masse', itau, massem(ijb:ije,:), + . iip1*jjn*llm, ndex) + + call histwrite(fluxid, 'pbaru', itau, pbarug(ijb:ije,:), + . iip1*jjn*llm, ndex) + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + if (pole_sud) then + jje=jj_end-1 + jjn=jj_nb-1 + endif + + call histwrite(fluxvid, 'pbarv', itau, pbarvg(:,jjb:jje,:), + . iip1*jjn*llm, ndex) + + ijb=ij_begin + ije=ij_end + jjn=jj_nb + + call histwrite(fluxid, 'w' ,itau, wg(ijb:ije,:), + . iip1*jjn*llm, ndex) + + call histwrite(fluxid, 'teta' ,itau, tetac(ijb:ije,:), + . iip1*jjn*llm, ndex) + + call histwrite(fluxid, 'phi' ,itau, phic(ijb:ije,:), + . iip1*jjn*llm, ndex) + +C +c$OMP END MASTER + ENDIF ! if iadvtr.EQ.istdyn + +#else + write(lunout,*) + & 'fluxstokenc: Needs Earth physics (and ioipsl) to function' +#endif +! of #ifdef CPP_EARTH + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/friction_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/friction_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/friction_p.F (revision 1280) @@ -0,0 +1,143 @@ +! +! $Header$ +! +c======================================================================= + SUBROUTINE friction_p(ucov,vcov,pdt) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c +c Objet: +c ------ +c +c *********** +c Friction +c *********** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "control.h" +#include "comconst.h" + + REAL pdt + REAL modv(iip1,jjp1),zco,zsi + REAL vpn,vps,upoln,upols,vpols,vpoln + REAL u2(iip1,jjp1),v2(iip1,jjm) + REAL ucov( iip1,jjp1,llm ),vcov( iip1,jjm,llm ) + INTEGER i,j + REAL cfric + parameter (cfric=1.e-5) + integer :: jjb,jje + + +c calcul des composantes au carre du vent naturel + jjb=jj_begin + jje=jj_end+1 + if (pole_sud) jje=jj_end + + do j=jjb,jje + do i=1,iip1 + u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j) + enddo + enddo + + jjb=jj_begin-1 + jje=jj_end+1 + if (pole_nord) jjb=jj_begin + if (pole_sud) jje=jj_end-1 + + do j=jjb,jje + do i=1,iip1 + v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j) + enddo + enddo + +c calcul du module de V en dehors des poles + jjb=jj_begin + jje=jj_end+1 + if (pole_nord) jjb=jj_begin+1 + if (pole_sud) jje=jj_end-1 + + do j=jjb,jje + do i=2,iip1 + modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j))) + enddo + modv(1,j)=modv(iip1,j) + enddo + +c les deux composantes du vent au pole sont obtenues comme +c premiers modes de fourier de v pres du pole + if (pole_nord) then + + upoln=0. + vpoln=0. + + do i=2,iip1 + zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1)) + zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1)) + vpn=vcov(i,1,1)/cv(i,1) + upoln=upoln+zco*vpn + vpoln=vpoln+zsi*vpn + enddo + vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi + do i=1,iip1 +c modv(i,1)=vpn + modv(i,1)=modv(i,2) + enddo + + endif + + if (pole_sud) then + + upols=0. + vpols=0. + do i=2,iip1 + zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1)) + zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1)) + vps=vcov(i,jjm,1)/cv(i,jjm) + upols=upols+zco*vps + vpols=vpols+zsi*vps + enddo + vps=sqrt(upols*upols+vpols*vpols)/pi + do i=1,iip1 +c modv(i,jjp1)=vps + modv(i,jjp1)=modv(i,jjm) + enddo + + endif + +c calcul du frottement au sol. + + jjb=jj_begin + jje=jj_end + if (pole_nord) jjb=jj_begin+1 + if (pole_sud) jje=jj_end-1 + + do j=jjb,jje + do i=1,iim + ucov(i,j,1)=ucov(i,j,1) + s -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1) + enddo + ucov(iip1,j,1)=ucov(1,j,1) + enddo + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + do j=jjb,jje + do i=1,iip1 + vcov(i,j,1)=vcov(i,j,1) + s -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1) + enddo + vcov(iip1,j,1)=vcov(1,j,1) + enddo + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fxhyp.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fxhyp.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fxhyp.F (revision 1280) @@ -0,0 +1,448 @@ +! +! $Header$ +! +c +c + SUBROUTINE fxhyp ( xzoomdeg,grossism,dzooma,tau , + , rlonm025,xprimm025,rlonv,xprimv,rlonu,xprimu,rlonp025,xprimp025, + , champmin,champmax ) + +c Auteur : P. Le Van + + IMPLICIT NONE + +c Calcule les longitudes et derivees dans la grille du GCM pour une +c fonction f(x) a tangente hyperbolique . +c +c grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois,etc.) +c dzoom etant la distance totale de la zone du zoom +c tau la raideur de la transition de l'interieur a l'exterieur du zoom +c +c On doit avoir grossism x dzoom < pi ( radians ) , en longitude. +c ******************************************************************** + + + INTEGER nmax, nmax2 + PARAMETER ( nmax = 30000, nmax2 = 2*nmax ) +c + LOGICAL scal180 + PARAMETER ( scal180 = .TRUE. ) + +c scal180 = .TRUE. si on veut avoir le premier point scalaire pour +c une grille reguliere ( grossism = 1.,tau=0.,clon=0. ) a -180. degres. +c sinon scal180 = .FALSE. + +#include "dimensions.h" +#include "paramet.h" + +c ...... arguments d'entree ....... +c + REAL xzoomdeg,dzooma,tau,grossism + +c ...... arguments de sortie ...... + + REAL rlonm025(iip1),xprimm025(iip1),rlonv(iip1),xprimv(iip1), + , rlonu(iip1),xprimu(iip1),rlonp025(iip1),xprimp025(iip1) + +c .... variables locales .... +c + REAL dzoom + REAL*8 xlon(iip1),xprimm(iip1),xuv + REAL*8 xtild(0:nmax2) + REAL*8 fhyp(0:nmax2),ffdx,beta,Xprimt(0:nmax2) + REAL*8 Xf(0:nmax2),xxpr(0:nmax2) + REAL*8 xvrai(iip1),xxprim(iip1) + REAL*8 pi,depi,epsilon,xzoom,fa,fb + REAL*8 Xf1, Xfi , a0,a1,a2,a3,xi2 + INTEGER i,it,ik,iter,ii,idif,ii1,ii2 + REAL*8 xi,xo1,xmoy,xlon2,fxm,Xprimin + REAL*8 champmin,champmax,decalx + INTEGER is2 + SAVE is2 + + REAL*8 heavyside + + pi = 2. * ASIN(1.) + depi = 2. * pi + epsilon = 1.e-3 + xzoom = xzoomdeg * pi/180. +c + decalx = .75 + IF( grossism.EQ.1..AND.scal180 ) THEN + decalx = 1. + ENDIF + + WRITE(6,*) 'FXHYP scal180,decalx', scal180,decalx +c + IF( dzooma.LT.1.) THEN + dzoom = dzooma * depi + ELSEIF( dzooma.LT. 25. ) THEN + WRITE(6,*) ' Le param. dzoomx pour fxhyp est trop petit ! L aug + ,menter et relancer ! ' + STOP 1 + ELSE + dzoom = dzooma * pi/180. + ENDIF + + WRITE(6,*) ' xzoom( rad.),grossism,tau,dzoom (radians)' + WRITE(6,24) xzoom,grossism,tau,dzoom + + DO i = 0, nmax2 + xtild(i) = - pi + FLOAT(i) * depi /nmax2 + ENDDO + + DO i = nmax, nmax2 + + fa = tau* ( dzoom/2. - xtild(i) ) + fb = xtild(i) * ( pi - xtild(i) ) + + IF( 200.* fb .LT. - fa ) THEN + fhyp ( i) = - 1. + ELSEIF( 200. * fb .LT. fa ) THEN + fhyp ( i) = 1. + ELSE + IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13) THEN + IF( 200.*fb + fa.LT.1.e-10 ) THEN + fhyp ( i ) = - 1. + ELSEIF( 200.*fb - fa.LT.1.e-10 ) THEN + fhyp ( i ) = 1. + ENDIF + ELSE + fhyp ( i ) = TANH ( fa/fb ) + ENDIF + ENDIF + IF ( xtild(i).EQ. 0. ) fhyp(i) = 1. + IF ( xtild(i).EQ. pi ) fhyp(i) = -1. + + ENDDO + +cc .... Calcul de beta .... + + ffdx = 0. + + DO i = nmax +1,nmax2 + + xmoy = 0.5 * ( xtild(i-1) + xtild( i ) ) + fa = tau* ( dzoom/2. - xmoy ) + fb = xmoy * ( pi - xmoy ) + + IF( 200.* fb .LT. - fa ) THEN + fxm = - 1. + ELSEIF( 200. * fb .LT. fa ) THEN + fxm = 1. + ELSE + IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13) THEN + IF( 200.*fb + fa.LT.1.e-10 ) THEN + fxm = - 1. + ELSEIF( 200.*fb - fa.LT.1.e-10 ) THEN + fxm = 1. + ENDIF + ELSE + fxm = TANH ( fa/fb ) + ENDIF + ENDIF + + IF ( xmoy.EQ. 0. ) fxm = 1. + IF ( xmoy.EQ. pi ) fxm = -1. + + ffdx = ffdx + fxm * ( xtild(i) - xtild(i-1) ) + + ENDDO + + beta = ( grossism * ffdx - pi ) / ( ffdx - pi ) + + IF( 2.*beta - grossism.LE. 0.) THEN + WRITE(6,*) ' ** Attention ! La valeur beta calculee dans la rou + ,tine fxhyp est mauvaise ! ' + WRITE(6,*)'Modifier les valeurs de grossismx ,tau ou dzoomx ', + , ' et relancer ! *** ' + CALL ABORT + ENDIF +c +c ..... calcul de Xprimt ..... +c + + DO i = nmax, nmax2 + Xprimt(i) = beta + ( grossism - beta ) * fhyp(i) + ENDDO +c + DO i = nmax+1, nmax2 + Xprimt( nmax2 - i ) = Xprimt( i ) + ENDDO +c + +c ..... Calcul de Xf ........ + + Xf(0) = - pi + + DO i = nmax +1, nmax2 + + xmoy = 0.5 * ( xtild(i-1) + xtild( i ) ) + fa = tau* ( dzoom/2. - xmoy ) + fb = xmoy * ( pi - xmoy ) + + IF( 200.* fb .LT. - fa ) THEN + fxm = - 1. + ELSEIF( 200. * fb .LT. fa ) THEN + fxm = 1. + ELSE + fxm = TANH ( fa/fb ) + ENDIF + + IF ( xmoy.EQ. 0. ) fxm = 1. + IF ( xmoy.EQ. pi ) fxm = -1. + xxpr(i) = beta + ( grossism - beta ) * fxm + + ENDDO + + DO i = nmax+1, nmax2 + xxpr(nmax2-i+1) = xxpr(i) + ENDDO + + DO i=1,nmax2 + Xf(i) = Xf(i-1) + xxpr(i) * ( xtild(i) - xtild(i-1) ) + ENDDO + + +c ***************************************************************** +c + +c ..... xuv = 0. si calcul aux pts scalaires ........ +c ..... xuv = 0.5 si calcul aux pts U ........ +c + WRITE(6,18) +c + DO 5000 ik = 1, 4 + + IF( ik.EQ.1 ) THEN + xuv = -0.25 + ELSE IF ( ik.EQ.2 ) THEN + xuv = 0. + ELSE IF ( ik.EQ.3 ) THEN + xuv = 0.50 + ELSE IF ( ik.EQ.4 ) THEN + xuv = 0.25 + ENDIF + + xo1 = 0. + + ii1=1 + ii2=iim + IF(ik.EQ.1.and.grossism.EQ.1.) THEN + ii1 = 2 + ii2 = iim+1 + ENDIF + DO 1500 i = ii1, ii2 + + xlon2 = - pi + (FLOAT(i) + xuv - decalx) * depi / FLOAT(iim) + + Xfi = xlon2 +c + DO 250 it = nmax2,0,-1 + IF( Xfi.GE.Xf(it)) GO TO 350 +250 CONTINUE + + it = 0 + +350 CONTINUE + +c ...... Calcul de Xf(xi) ...... +c + xi = xtild(it) + + IF(it.EQ.nmax2) THEN + it = nmax2 -1 + Xf(it+1) = pi + ENDIF +c ..................................................................... +c +c Appel de la routine qui calcule les coefficients a0,a1,a2,a3 d'un +c polynome de degre 3 qui passe par les points (Xf(it),xtild(it) ) +c et (Xf(it+1),xtild(it+1) ) + + CALL coefpoly ( Xf(it),Xf(it+1),Xprimt(it),Xprimt(it+1), + , xtild(it),xtild(it+1), a0, a1, a2, a3 ) + + Xf1 = Xf(it) + Xprimin = a1 + 2.* a2 * xi + 3.*a3 * xi *xi + + DO 500 iter = 1,300 + xi = xi - ( Xf1 - Xfi )/ Xprimin + + IF( ABS(xi-xo1).LE.epsilon) GO TO 550 + xo1 = xi + xi2 = xi * xi + Xf1 = a0 + a1 * xi + a2 * xi2 + a3 * xi2 * xi + Xprimin = a1 + 2.* a2 * xi + 3.* a3 * xi2 +500 CONTINUE + WRITE(6,*) ' Pas de solution ***** ',i,xlon2,iter + STOP 6 +550 CONTINUE + + xxprim(i) = depi/ ( FLOAT(iim) * Xprimin ) + xvrai(i) = xi + xzoom + +1500 CONTINUE + + + IF(ik.EQ.1.and.grossism.EQ.1.) THEN + xvrai(1) = xvrai(iip1)-depi + xxprim(1) = xxprim(iip1) + ENDIF + DO i = 1 , iim + xlon(i) = xvrai(i) + xprimm(i) = xxprim(i) + ENDDO + DO i = 1, iim -1 + IF( xvrai(i+1). LT. xvrai(i) ) THEN + WRITE(6,*) ' PBS. avec rlonu(',i+1,') plus petit que rlonu(',i, + , ')' + STOP 7 + ENDIF + ENDDO +c +c ... Reorganisation des longitudes pour les avoir entre - pi et pi .. +c ........................................................................ + + champmin = 1.e12 + champmax = -1.e12 + DO i = 1, iim + champmin = MIN( champmin,xvrai(i) ) + champmax = MAX( champmax,xvrai(i) ) + ENDDO + + IF(champmin .GE.-pi-0.10.and.champmax.LE.pi+0.10 ) THEN + GO TO 1600 + ELSE + WRITE(6,*) 'Reorganisation des longitudes pour avoir entre - pi', + , ' et pi ' +c + IF( xzoom.LE.0.) THEN + IF( ik.EQ. 1 ) THEN + DO i = 1, iim + IF( xvrai(i).GE. - pi ) GO TO 80 + ENDDO + WRITE(6,*) ' PBS. 1 ! Xvrai plus petit que - pi ! ' + STOP 8 + 80 CONTINUE + is2 = i + ENDIF + + IF( is2.NE. 1 ) THEN + DO ii = is2 , iim + xlon (ii-is2+1) = xvrai(ii) + xprimm(ii-is2+1) = xxprim(ii) + ENDDO + DO ii = 1 , is2 -1 + xlon (ii+iim-is2+1) = xvrai(ii) + depi + xprimm(ii+iim-is2+1) = xxprim(ii) + ENDDO + ENDIF + ELSE + IF( ik.EQ.1 ) THEN + DO i = iim,1,-1 + IF( xvrai(i).LE. pi ) GO TO 90 + ENDDO + WRITE(6,*) ' PBS. 2 ! Xvrai plus grand que pi ! ' + STOP 9 + 90 CONTINUE + is2 = i + ENDIF + idif = iim -is2 + DO ii = 1, is2 + xlon (ii+idif) = xvrai(ii) + xprimm(ii+idif) = xxprim(ii) + ENDDO + DO ii = 1, idif + xlon (ii) = xvrai (ii+is2) - depi + xprimm(ii) = xxprim(ii+is2) + ENDDO + ENDIF + ENDIF +c +c ......... Fin de la reorganisation ............................ + + 1600 CONTINUE + + + xlon ( iip1) = xlon(1) + depi + xprimm( iip1 ) = xprimm (1 ) + + DO i = 1, iim+1 + xvrai(i) = xlon(i)*180./pi + ENDDO + + IF( ik.EQ.1 ) THEN +c WRITE(6,*) ' XLON aux pts. V-0.25 apres ( en deg. ) ' +c WRITE(6,18) +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM k ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim +1 + rlonm025(i) = xlon( i ) + xprimm025(i) = xprimm(i) + ENDDO + ELSE IF( ik.EQ.2 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' XLON aux pts. V apres ( en deg. ) ' +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM k ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim + 1 + rlonv(i) = xlon( i ) + xprimv(i) = xprimm(i) + ENDDO + + ELSE IF( ik.EQ.3) THEN +c WRITE(6,18) +c WRITE(6,*) ' XLON aux pts. U apres ( en deg. ) ' +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM ik ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim + 1 + rlonu(i) = xlon( i ) + xprimu(i) = xprimm(i) + ENDDO + + ELSE IF( ik.EQ.4 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' XLON aux pts. V+0.25 apres ( en deg. ) ' +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM ik ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim + 1 + rlonp025(i) = xlon( i ) + xprimp025(i) = xprimm(i) + ENDDO + + ENDIF + +5000 CONTINUE +c + WRITE(6,18) +c +c ........... fin de la boucle do 5000 ............ + + DO i = 1, iim + xlon(i) = rlonv(i+1) - rlonv(i) + ENDDO + champmin = 1.e12 + champmax = -1.e12 + DO i = 1, iim + champmin = MIN( champmin, xlon(i) ) + champmax = MAX( champmax, xlon(i) ) + ENDDO + champmin = champmin * 180./pi + champmax = champmax * 180./pi + +18 FORMAT(/) +24 FORMAT(2x,'Parametres xzoom,gross,tau ,dzoom pour fxhyp ',4f8.3) +68 FORMAT(1x,7f9.2) +566 FORMAT(1x,7f9.4) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fxy.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fxy.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fxy.F (revision 1280) @@ -0,0 +1,69 @@ +! +! $Header$ +! + SUBROUTINE fxy (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + IMPLICIT NONE + +c Auteur : P. Le Van +c +c Calcul des longitudes et des latitudes pour une fonction f(x,y) +c a tangente sinusoidale et eventuellement avec zoom . +c +c +#include "dimensions.h" +#include "paramet.h" +#include "serre.h" +#include "comconst.h" + + INTEGER i,j + + REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1), + , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1) + +#include "fxy_new.h" + + +c ...... calcul des latitudes et de y' ..... +c + DO j = 1, jjm + 1 + rlatu(j) = fy ( FLOAT( j ) ) + yprimu(j) = fyprim( FLOAT( j ) ) + ENDDO + + + DO j = 1, jjm + + rlatv(j) = fy ( FLOAT( j ) + 0.5 ) + rlatu1(j) = fy ( FLOAT( j ) + 0.25 ) + rlatu2(j) = fy ( FLOAT( j ) + 0.75 ) + + yprimv(j) = fyprim( FLOAT( j ) + 0.5 ) + yprimu1(j) = fyprim( FLOAT( j ) + 0.25 ) + yprimu2(j) = fyprim( FLOAT( j ) + 0.75 ) + + ENDDO + +c +c ..... calcul des longitudes et de x' ..... +c + DO i = 1, iim + 1 + rlonv(i) = fx ( FLOAT( i ) ) + rlonu(i) = fx ( FLOAT( i ) + 0.5 ) + rlonm025(i) = fx ( FLOAT( i ) - 0.25 ) + rlonp025(i) = fx ( FLOAT( i ) + 0.25 ) + + xprimv (i) = fxprim ( FLOAT( i ) ) + xprimu (i) = fxprim ( FLOAT( i ) + 0.5 ) + xprimm025(i) = fxprim ( FLOAT( i ) - 0.25 ) + xprimp025(i) = fxprim ( FLOAT( i ) + 0.25 ) + ENDDO + +c + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fxyhyper.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fxyhyper.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fxyhyper.F (revision 1280) @@ -0,0 +1,139 @@ +! +! $Header$ +! +c +c + SUBROUTINE fxyhyper ( yzoom, grossy, dzoomy,tauy , + , xzoom, grossx, dzoomx,taux , + , rlatu,yprimu,rlatv,yprimv,rlatu1, yprimu1, rlatu2, yprimu2 , + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + IMPLICIT NONE +c +c Auteur : P. Le Van . +c +c d'apres formulations de R. Sadourny . +c +c +c Ce spg calcule les latitudes( routine fyhyp ) et longitudes( fxhyp ) +c par des fonctions a tangente hyperbolique . +c +c Il y a 3 parametres ,en plus des coordonnees du centre du zoom (xzoom +c et yzoom ) : +c +c a) le grossissement du zoom : grossy ( en y ) et grossx ( en x ) +c b) l' extension du zoom : dzoomy ( en y ) et dzoomx ( en x ) +c c) la raideur de la transition du zoom : taux et tauy +c +c N.B : Il vaut mieux avoir : grossx * dzoomx < pi ( radians ) +c ****** +c et grossy * dzoomy < pi/2 ( radians ) +c +#include "dimensions.h" +#include "paramet.h" + + +c ..... Arguments ... +c + REAL xzoom,yzoom,grossx,grossy,dzoomx,dzoomy,taux,tauy + REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1), + , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1) + REAL(KIND=8) dxmin, dxmax , dymin, dymax + +c .... var. locales ..... +c + INTEGER i,j +c + + CALL fyhyp ( yzoom, grossy, dzoomy,tauy , + , rlatu, yprimu,rlatv,yprimv,rlatu2,yprimu2,rlatu1,yprimu1 , + , dymin,dymax ) + + CALL fxhyp(xzoom,grossx,dzoomx,taux,rlonm025,xprimm025,rlonv, + , xprimv,rlonu,xprimu,rlonp025,xprimp025 , dxmin,dxmax ) + + + DO i = 1, iip1 + IF(rlonp025(i).LT.rlonv(i)) THEN + WRITE(6,*) ' Attention ! rlonp025 < rlonv',i + STOP + ENDIF + + IF(rlonv(i).LT.rlonm025(i)) THEN + WRITE(6,*) ' Attention ! rlonm025 > rlonv',i + STOP + ENDIF + + IF(rlonp025(i).GT.rlonu(i)) THEN + WRITE(6,*) ' Attention ! rlonp025 > rlonu',i + STOP + ENDIF + ENDDO + + WRITE(6,*) ' *** TEST DE COHERENCE OK POUR FX **** ' + +c + DO j = 1, jjm +c + IF(rlatu1(j).LE.rlatu2(j)) THEN + WRITE(6,*)'Attention ! rlatu1 < rlatu2 ',rlatu1(j), rlatu2(j),j + STOP 13 + ENDIF +c + IF(rlatu2(j).LE.rlatu(j+1)) THEN + WRITE(6,*)'Attention ! rlatu2 < rlatup1 ',rlatu2(j),rlatu(j+1),j + STOP 14 + ENDIF +c + IF(rlatu(j).LE.rlatu1(j)) THEN + WRITE(6,*)' Attention ! rlatu < rlatu1 ',rlatu(j),rlatu1(j),j + STOP 15 + ENDIF +c + IF(rlatv(j).LE.rlatu2(j)) THEN + WRITE(6,*)' Attention ! rlatv < rlatu2 ',rlatv(j),rlatu2(j),j + STOP 16 + ENDIF +c + IF(rlatv(j).ge.rlatu1(j)) THEN + WRITE(6,*)' Attention ! rlatv > rlatu1 ',rlatv(j),rlatu1(j),j + STOP 17 + ENDIF +c + IF(rlatv(j).ge.rlatu(j)) THEN + WRITE(6,*) ' Attention ! rlatv > rlatu ',rlatv(j),rlatu(j),j + STOP 18 + ENDIF +c + ENDDO +c + WRITE(6,*) ' *** TEST DE COHERENCE OK POUR FY **** ' +c + WRITE(6,18) + WRITE(6,*) ' Latitudes ' + WRITE(6,*) ' *********** ' + WRITE(6,18) + WRITE(6,3) dymin, dymax + WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par + ,ametres grossism , tau , dzoom pour Y et repasser ! ' +c + WRITE(6,18) + WRITE(6,*) ' Longitudes ' + WRITE(6,*) ' ************ ' + WRITE(6,18) + WRITE(6,3) dxmin, dxmax + WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par + ,ametres grossism , tau , dzoom pour Y et repasser ! ' + WRITE(6,18) +c +3 Format(1x, ' Au centre du zoom , la longueur de la maille est', + , ' d environ ',f8.2 ,' degres ', + , ' alors que la maille en dehors de la zone du zoom est d environ + , ', f8.2,' degres ' ) +18 FORMAT(/) + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fxysinus.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fxysinus.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fxysinus.F (revision 1280) @@ -0,0 +1,69 @@ +! +! $Header$ +! + SUBROUTINE fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + + IMPLICIT NONE +c +c Calcul des longitudes et des latitudes pour une fonction f(x,y) +c avec y = Asin( j ) . +c +c Auteur : P. Le Van +c +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" + + INTEGER i,j + + REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1), + , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1) + +#include "fxy_sin.h" + + +c ...... calcul des latitudes et de y' ..... +c + DO j = 1, jjm + 1 + rlatu(j) = fy ( FLOAT( j ) ) + yprimu(j) = fyprim( FLOAT( j ) ) + ENDDO + + + DO j = 1, jjm + + rlatv(j) = fy ( FLOAT( j ) + 0.5 ) + rlatu1(j) = fy ( FLOAT( j ) + 0.25 ) + rlatu2(j) = fy ( FLOAT( j ) + 0.75 ) + + yprimv(j) = fyprim( FLOAT( j ) + 0.5 ) + yprimu1(j) = fyprim( FLOAT( j ) + 0.25 ) + yprimu2(j) = fyprim( FLOAT( j ) + 0.75 ) + + ENDDO + +c +c ..... calcul des longitudes et de x' ..... +c + DO i = 1, iim + 1 + rlonv(i) = fx ( FLOAT( i ) ) + rlonu(i) = fx ( FLOAT( i ) + 0.5 ) + rlonm025(i) = fx ( FLOAT( i ) - 0.25 ) + rlonp025(i) = fx ( FLOAT( i ) + 0.25 ) + + xprimv (i) = fxprim ( FLOAT( i ) ) + xprimu (i) = fxprim ( FLOAT( i ) + 0.5 ) + xprimm025(i) = fxprim ( FLOAT( i ) - 0.25 ) + xprimp025(i) = fxprim ( FLOAT( i ) + 0.25 ) + ENDDO + +c + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fyhyp.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fyhyp.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/fyhyp.F (revision 1280) @@ -0,0 +1,378 @@ +! +! $Header$ +! +c +c + SUBROUTINE fyhyp ( yzoomdeg, grossism, dzooma,tau , + , rrlatu,yyprimu,rrlatv,yyprimv,rlatu2,yprimu2,rlatu1,yprimu1 , + , champmin,champmax ) + +cc ... Version du 01/04/2001 .... + + IMPLICIT NONE +c +c ... Auteur : P. Le Van ... +c +c ....... d'apres formulations de R. Sadourny ....... +c +c Calcule les latitudes et derivees dans la grille du GCM pour une +c fonction f(y) a tangente hyperbolique . +c +c grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois , etc) +c dzoom etant la distance totale de la zone du zoom ( en radians ) +c tau la raideur de la transition de l'interieur a l'exterieur du zoom +c +c +c N.B : Il vaut mieux avoir : grossism * dzoom < pi/2 (radians) ,en lati. +c ******************************************************************** +c +c +#include "dimensions.h" +#include "paramet.h" + + INTEGER nmax , nmax2 + PARAMETER ( nmax = 30000, nmax2 = 2*nmax ) +c +c +c ....... arguments d'entree ....... +c + REAL yzoomdeg, grossism,dzooma,tau +c ( rentres par run.def ) + +c ....... arguments de sortie ....... +c + REAL rrlatu(jjp1), yyprimu(jjp1),rrlatv(jjm), yyprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + +c +c ..... champs locaux ..... +c + + REAL dzoom + REAL(KIND=8) ylat(jjp1), yprim(jjp1) + REAL(KIND=8) yuv + REAL(KIND=8) yt(0:nmax2) + REAL(KIND=8) fhyp(0:nmax2),beta,Ytprim(0:nmax2),fxm(0:nmax2) + SAVE Ytprim, yt,Yf + REAL(KIND=8) Yf(0:nmax2),yypr(0:nmax2) + REAL(KIND=8) yvrai(jjp1), yprimm(jjp1),ylatt(jjp1) + REAL(KIND=8) pi,depi,pis2,epsilon,y0,pisjm + REAL(KIND=8) yo1,yi,ylon2,ymoy,Yprimin,champmin,champmax + REAL(KIND=8) yfi,Yf1,ffdy + REAL(KIND=8) ypn,deply,y00 + SAVE y00, deply + + INTEGER i,j,it,ik,iter,jlat + INTEGER jpn,jjpn + SAVE jpn + REAL(KIND=8) a0,a1,a2,a3,yi2,heavyy0,heavyy0m + REAL(KIND=8) fa(0:nmax2),fb(0:nmax2) + REAL y0min,y0max + + REAL(KIND=8) heavyside + + pi = 2. * ASIN(1.) + depi = 2. * pi + pis2 = pi/2. + pisjm = pi/ FLOAT(jjm) + epsilon = 1.e-3 + y0 = yzoomdeg * pi/180. + + IF( dzooma.LT.1.) THEN + dzoom = dzooma * pi + ELSEIF( dzooma.LT. 12. ) THEN + WRITE(6,*) ' Le param. dzoomy pour fyhyp est trop petit ! L aug + ,menter et relancer ! ' + STOP 1 + ELSE + dzoom = dzooma * pi/180. + ENDIF + + WRITE(6,18) + WRITE(6,*) ' yzoom( rad.),grossism,tau,dzoom (radians)' + WRITE(6,24) y0,grossism,tau,dzoom + + DO i = 0, nmax2 + yt(i) = - pis2 + FLOAT(i)* pi /nmax2 + ENDDO + + heavyy0m = heavyside( -y0 ) + heavyy0 = heavyside( y0 ) + y0min = 2.*y0*heavyy0m - pis2 + y0max = 2.*y0*heavyy0 + pis2 + + fa = 999.999 + fb = 999.999 + + DO i = 0, nmax2 + IF( yt(i).LT.y0 ) THEN + fa (i) = tau* (yt(i)-y0+dzoom/2. ) + fb(i) = (yt(i)-2.*y0*heavyy0m +pis2) * ( y0 - yt(i) ) + ELSEIF ( yt(i).GT.y0 ) THEN + fa(i) = tau *(y0-yt(i)+dzoom/2. ) + fb(i) = (2.*y0*heavyy0 -yt(i)+pis2) * ( yt(i) - y0 ) + ENDIF + + IF( 200.* fb(i) .LT. - fa(i) ) THEN + fhyp ( i) = - 1. + ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN + fhyp ( i) = 1. + ELSE + fhyp(i) = TANH ( fa(i)/fb(i) ) + ENDIF + + IF( yt(i).EQ.y0 ) fhyp(i) = 1. + IF(yt(i).EQ. y0min. OR.yt(i).EQ. y0max ) fhyp(i) = -1. + + ENDDO + +cc .... Calcul de beta .... +c + ffdy = 0. + + DO i = 1, nmax2 + ymoy = 0.5 * ( yt(i-1) + yt( i ) ) + IF( ymoy.LT.y0 ) THEN + fa(i)= tau * ( ymoy-y0+dzoom/2.) + fb(i) = (ymoy-2.*y0*heavyy0m +pis2) * ( y0 - ymoy ) + ELSEIF ( ymoy.GT.y0 ) THEN + fa(i)= tau * ( y0-ymoy+dzoom/2. ) + fb(i) = (2.*y0*heavyy0 -ymoy+pis2) * ( ymoy - y0 ) + ENDIF + + IF( 200.* fb(i) .LT. - fa(i) ) THEN + fxm ( i) = - 1. + ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN + fxm ( i) = 1. + ELSE + fxm(i) = TANH ( fa(i)/fb(i) ) + ENDIF + IF( ymoy.EQ.y0 ) fxm(i) = 1. + IF (ymoy.EQ. y0min. OR.yt(i).EQ. y0max ) fxm(i) = -1. + ffdy = ffdy + fxm(i) * ( yt(i) - yt(i-1) ) + + ENDDO + + beta = ( grossism * ffdy - pi ) / ( ffdy - pi ) + + IF( 2.*beta - grossism.LE. 0.) THEN + + WRITE(6,*) ' ** Attention ! La valeur beta calculee dans la rou + ,tine fyhyp est mauvaise ! ' + WRITE(6,*)'Modifier les valeurs de grossismy ,tauy ou dzoomy', + , ' et relancer ! *** ' + CALL ABORT + + ENDIF +c +c ..... calcul de Ytprim ..... +c + + DO i = 0, nmax2 + Ytprim(i) = beta + ( grossism - beta ) * fhyp(i) + ENDDO + +c ..... Calcul de Yf ........ + + Yf(0) = - pis2 + DO i = 1, nmax2 + yypr(i) = beta + ( grossism - beta ) * fxm(i) + ENDDO + + DO i=1,nmax2 + Yf(i) = Yf(i-1) + yypr(i) * ( yt(i) - yt(i-1) ) + ENDDO + +c **************************************************************** +c +c ..... yuv = 0. si calcul des latitudes aux pts. U ..... +c ..... yuv = 0.5 si calcul des latitudes aux pts. V ..... +c + WRITE(6,18) +c + DO 5000 ik = 1,4 + + IF( ik.EQ.1 ) THEN + yuv = 0. + jlat = jjm + 1 + ELSE IF ( ik.EQ.2 ) THEN + yuv = 0.5 + jlat = jjm + ELSE IF ( ik.EQ.3 ) THEN + yuv = 0.25 + jlat = jjm + ELSE IF ( ik.EQ.4 ) THEN + yuv = 0.75 + jlat = jjm + ENDIF +c + yo1 = 0. + DO 1500 j = 1,jlat + yo1 = 0. + ylon2 = - pis2 + pisjm * ( FLOAT(j) + yuv -1.) + yfi = ylon2 +c + DO 250 it = nmax2,0,-1 + IF( yfi.GE.Yf(it)) GO TO 350 +250 CONTINUE + it = 0 +350 CONTINUE + + yi = yt(it) + IF(it.EQ.nmax2) THEN + it = nmax2 -1 + Yf(it+1) = pis2 + ENDIF +c ................................................................. +c .... Interpolation entre yi(it) et yi(it+1) pour avoir Y(yi) +c ..... et Y'(yi) ..... +c ................................................................. + + CALL coefpoly ( Yf(it),Yf(it+1),Ytprim(it), Ytprim(it+1), + , yt(it),yt(it+1) , a0,a1,a2,a3 ) + + Yf1 = Yf(it) + Yprimin = a1 + 2.* a2 * yi + 3.*a3 * yi *yi + + DO 500 iter = 1,300 + yi = yi - ( Yf1 - yfi )/ Yprimin + + IF( ABS(yi-yo1).LE.epsilon) GO TO 550 + yo1 = yi + yi2 = yi * yi + Yf1 = a0 + a1 * yi + a2 * yi2 + a3 * yi2 * yi + Yprimin = a1 + 2.* a2 * yi + 3.* a3 * yi2 +500 CONTINUE + WRITE(6,*) ' Pas de solution ***** ',j,ylon2,iter + STOP 2 +550 CONTINUE +c + Yprimin = a1 + 2.* a2 * yi + 3.* a3 * yi* yi + yprim(j) = pi / ( jjm * Yprimin ) + yvrai(j) = yi + +1500 CONTINUE + + DO j = 1, jlat -1 + IF( yvrai(j+1). LT. yvrai(j) ) THEN + WRITE(6,*) ' PBS. avec rlat(',j+1,') plus petit que rlat(',j, + , ')' + STOP 3 + ENDIF + ENDDO + + WRITE(6,*) 'Reorganisation des latitudes pour avoir entre - pi/2' + , ,' et pi/2 ' +c + IF( ik.EQ.1 ) THEN + ypn = pis2 + DO j = jlat,1,-1 + IF( yvrai(j).LE. ypn ) GO TO 1502 + ENDDO +1502 CONTINUE + + jpn = j + y00 = yvrai(jpn) + deply = pis2 - y00 + ENDIF + + DO j = 1, jjm +1 - jpn + ylatt (j) = -pis2 - y00 + yvrai(jpn+j-1) + yprimm(j) = yprim(jpn+j-1) + ENDDO + + jjpn = jpn + IF( jlat.EQ. jjm ) jjpn = jpn -1 + + DO j = 1,jjpn + ylatt (j + jjm+1 -jpn) = yvrai(j) + deply + yprimm(j + jjm+1 -jpn) = yprim(j) + ENDDO + +c *********** Fin de la reorganisation ************* +c + 1600 CONTINUE + + DO j = 1, jlat + ylat(j) = ylatt( jlat +1 -j ) + yprim(j) = yprimm( jlat +1 -j ) + ENDDO + + DO j = 1, jlat + yvrai(j) = ylat(j)*180./pi + ENDDO + + IF( ik.EQ.1 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en U apres ( en deg. ) ' +c WRITE(6,68) (yvrai(j),j=1,jlat) +cc WRITE(6,*) ' YPRIM ' +cc WRITE(6,445) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rrlatu(j) = ylat( j ) + yyprimu(j) = yprim( j ) + ENDDO + + ELSE IF ( ik.EQ. 2 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en V apres ( en deg. ) ' +c WRITE(6,68) (yvrai(j),j=1,jlat) +cc WRITE(6,*)' YPRIM ' +cc WRITE(6,445) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rrlatv(j) = ylat( j ) + yyprimv(j) = yprim( j ) + ENDDO + + ELSE IF ( ik.EQ. 3 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en U + 0.75 apres ( en deg. ) ' +c WRITE(6,68) (yvrai(j),j=1,jlat) +cc WRITE(6,*) ' YPRIM ' +cc WRITE(6,445) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rlatu2(j) = ylat( j ) + yprimu2(j) = yprim( j ) + ENDDO + + ELSE IF ( ik.EQ. 4 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en U + 0.25 apres ( en deg. ) ' +c WRITE(6,68)(yvrai(j),j=1,jlat) +cc WRITE(6,*) ' YPRIM ' +cc WRITE(6,68) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rlatu1(j) = ylat( j ) + yprimu1(j) = yprim( j ) + ENDDO + + ENDIF + +5000 CONTINUE +c + WRITE(6,18) +c +c ..... fin de la boucle do 5000 ..... + + DO j = 1, jjm + ylat(j) = rrlatu(j) - rrlatu(j+1) + ENDDO + champmin = 1.e12 + champmax = -1.e12 + DO j = 1, jjm + champmin = MIN( champmin, ylat(j) ) + champmax = MAX( champmax, ylat(j) ) + ENDDO + champmin = champmin * 180./pi + champmax = champmax * 180./pi + +24 FORMAT(2x,'Parametres yzoom,gross,tau ,dzoom pour fyhyp ',4f8.3) +18 FORMAT(/) +68 FORMAT(1x,7f9.2) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gcm.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gcm.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gcm.F (revision 1280) @@ -0,0 +1,511 @@ +! +! $Id$ +! +c +c + PROGRAM gcm + +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + + USE mod_const_mpi, ONLY: init_const_mpi + USE parallel + USE infotrac + USE mod_interface_dyn_phys + USE mod_hallo + USE Bands + USE getparam + USE filtreg_mod + +! Ehouarn: for now these only apply to Earth: +#ifdef CPP_EARTH + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para, ONLY : klon_mpi_para_nb + USE mod_phys_lmdz_omp_data, ONLY: klon_omp + USE dimphy + USE comgeomphy +#endif + IMPLICIT NONE + +c ...... Version du 10/01/98 .......... + +c avec coordonnees verticales hybrides +c avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 ) + +c======================================================================= +c +c Auteur: P. Le Van /L. Fairhead/F.Hourdin +c ------- +c +c Objet: +c ------ +c +c GCM LMD nouvelle grille +c +c======================================================================= +c +c ... Dans inigeom , nouveaux calculs pour les elongations cu , cv +c et possibilite d'appeler une fonction f(y) a derivee tangente +c hyperbolique a la place de la fonction a derivee sinusoidale. +c ... Possibilite de choisir le schema pour l'advection de +c q , en modifiant iadv dans traceur.def (MAF,10/02) . +c +c Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99) +c Pour Van-Leer iadv=10 +c +c----------------------------------------------------------------------- +c Declarations: +c ------------- +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissnew.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "temps.h" +#include "control.h" +#include "ener.h" +#include "description.h" +#include "serre.h" +#include "com_io_dyn.h" +#include "iniprint.h" +#include "tracstoke.h" + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + SAVE clesphy0 + + + + REAL zdtvr +c INTEGER nbetatmoy, nbetatdem,nbetat + INTEGER nbetatmoy, nbetatdem + +c variables dynamiques + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: q ! champs advectes + REAL ps(ip1jmp1) ! pression au sol +c REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches +c REAL pks(ip1jmp1) ! exner au sol +c REAL pk(ip1jmp1,llm) ! exner au milieu des couches +c REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches + REAL masse(ip1jmp1,llm) ! masse d'air + REAL phis(ip1jmp1) ! geopotentiel au sol +c REAL phi(ip1jmp1,llm) ! geopotentiel +c REAL w(ip1jmp1,llm) ! vitesse verticale + +c variables dynamiques intermediaire pour le transport + +c variables pour le fichier histoire + REAL dtav ! intervalle de temps elementaire + + REAL time_0 + + LOGICAL lafin +c INTEGER ij,iq,l,i,j + INTEGER i,j + + + real time_step, t_wrt, t_ops + + + LOGICAL call_iniphys + data call_iniphys/.true./ + +c REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm) +c+jld variables test conservation energie +c REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm) +C Tendance de la temp. potentiel d (theta)/ d t due a la +C tansformation d'energie cinetique en energie thermique +C cree par la dissipation +c REAL dhecdt(ip1jmp1,llm) +c REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) +c REAL d_h_vcol, d_qt, d_qw, d_ql, d_ec +c CHARACTER (len=15) :: ztit +c-jld + + + character (len=80) :: dynhist_file, dynhistave_file + character (len=20) :: modname + character (len=80) :: abort_message +! locales pour gestion du temps + INTEGER :: an, mois, jour + REAL :: heure + + +c----------------------------------------------------------------------- +c variables pour l'initialisation de la physique : +c ------------------------------------------------ + INTEGER ngridmx + PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm ) + REAL zcufi(ngridmx),zcvfi(ngridmx) + REAL latfi(ngridmx),lonfi(ngridmx) + REAL airefi(ngridmx) + SAVE latfi, lonfi, airefi + + INTEGER :: ierr + + +c----------------------------------------------------------------------- +c Initialisations: +c ---------------- + + abort_message = 'last timestep reached' + modname = 'gcm' + descript = 'Run GCM LMDZ' + lafin = .FALSE. + dynhist_file = 'dyn_hist' + dynhistave_file = 'dyn_hist_ave' + + + +c---------------------------------------------------------------------- +c lecture des fichiers gcm.def ou run.def +c --------------------------------------- +c +! Ehouarn: dump possibility of using defrun +!#ifdef CPP_IOIPSL + CALL conf_gcm( 99, .TRUE. , clesphy0 ) +!#else +! CALL defrun( 99, .TRUE. , clesphy0 ) +!#endif +c +c +c------------------------------------ +c Initialisation partie parallele +c------------------------------------ + CALL init_const_mpi + + call init_parallel + call ini_getparam("out.def") + call Read_Distrib +! Ehouarn : temporarily (?) keep this only for Earth + if (planet_type.eq."earth") then +#ifdef CPP_EARTH + CALL Init_Phys_lmdz(iim,jjp1,llm,mpi_size,distrib_phys) +#endif + endif ! of if (planet_type.eq."earth") + CALL set_bands +#ifdef CPP_EARTH +! Ehouarn: For now only Earth physics is parallel + CALL Init_interface_dyn_phys +#endif + CALL barrier + + if (mpi_rank==0) call WriteBands + call SetDistrib(jj_Nb_Caldyn) + +c$OMP PARALLEL + call Init_Mod_hallo +c$OMP END PARALLEL + +! Ehouarn : temporarily (?) keep this only for Earth + if (planet_type.eq."earth") then +#ifdef CPP_EARTH +c$OMP PARALLEL + call InitComgeomphy +c$OMP END PARALLEL +#endif + endif ! of if (planet_type.eq."earth") + +c----------------------------------------------------------------------- +c Choix du calendrier +c ------------------- + +c calend = 'earth_365d' + +#ifdef CPP_IOIPSL + if (calend == 'earth_360d') then + call ioconf_calendar('360d') + write(lunout,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an' + else if (calend == 'earth_365d') then + call ioconf_calendar('noleap') + write(lunout,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an' + else if (calend == 'earth_366d') then + call ioconf_calendar('gregorian') + write(lunout,*)'CALENDRIER CHOISI: Terrestre bissextile' + else + abort_message = 'Mauvais choix de calendrier' + call abort_gcm(modname,abort_message,1) + endif +#endif + + IF (config_inca /= 'none') THEN +#ifdef INCA + call init_const_lmdz( + $ nbtr,anneeref,dayref, + $ iphysiq,day_step,nday) + + call init_inca_para( + $ iim,jjm+1,llm,klon_glo,mpi_size, + $ distrib_phys,COMM_LMDZ) +#endif + END IF + +c----------------------------------------------------------------------- +c Initialisation des traceurs +c --------------------------- +c Choix du nombre de traceurs et du schema pour l'advection +c dans fichier traceur.def, par default ou via INCA + call infotrac_init + +c Allocation de la tableau q : champs advectes + ALLOCATE(q(ip1jmp1,llm,nqtot)) + +c----------------------------------------------------------------------- +c Lecture de l'etat initial : +c --------------------------- + +c lecture du fichier start.nc + if (read_start) then + ! we still need to run iniacademic to initialize some + ! constants & fields, if we run the 'newtonian' case: + if (iflag_phys.eq.2) then + CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0) + endif +!#ifdef CPP_IOIPSL + if (planet_type.eq."earth") then +#ifdef CPP_EARTH +! Load an Earth-format start file + CALL dynetat0("start.nc",vcov,ucov, + . teta,q,masse,ps,phis, time_0) +#endif + endif ! of if (planet_type.eq."earth") +c write(73,*) 'ucov',ucov +c write(74,*) 'vcov',vcov +c write(75,*) 'teta',teta +c write(76,*) 'ps',ps +c write(77,*) 'q',q + + endif ! of if (read_start) + +c le cas echeant, creation d un etat initial + IF (prt_level > 9) WRITE(lunout,*) + . 'GCM: AVANT iniacademic AVANT AVANT AVANT AVANT' + if (.not.read_start) then + CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0) + endif + +c----------------------------------------------------------------------- +c Lecture des parametres de controle pour la simulation : +c ------------------------------------------------------- +c on recalcule eventuellement le pas de temps + + IF(MOD(day_step,iperiod).NE.0) THEN + abort_message = + . 'Il faut choisir un nb de pas par jour multiple de iperiod' + call abort_gcm(modname,abort_message,1) + ENDIF + + IF(MOD(day_step,iphysiq).NE.0) THEN + abort_message = + * 'Il faut choisir un nb de pas par jour multiple de iphysiq' + call abort_gcm(modname,abort_message,1) + ENDIF + + zdtvr = daysec/FLOAT(day_step) + IF(dtvr.NE.zdtvr) THEN + WRITE(lunout,*) + . 'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr + ENDIF + +C +C on remet le calendrier à zero si demande +c + if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then + write(lunout,*) + . 'GCM: Attention les dates initiales lues dans le fichier' + write(lunout,*) + . ' restart ne correspondent pas a celles lues dans ' + write(lunout,*)' gcm.def' + write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref + write(lunout,*)' day_ref=',day_ref," dayref=",dayref + if (raz_date .ne. 1) then + write(lunout,*) + . 'GCM: On garde les dates du fichier restart' + else + annee_ref = anneeref + day_ref = dayref + day_ini = dayref + itau_dyn = 0 + itau_phy = 0 + time_0 = 0. + write(lunout,*) + . 'GCM: On reinitialise a la date lue dans gcm.def' + endif + ELSE + raz_date = 0 + endif + +#ifdef CPP_IOIPSL + mois = 1 + heure = 0. + call ymds2ju(annee_ref, mois, day_ref, heure, jD_ref) + jH_ref = jD_ref - int(jD_ref) + jD_ref = int(jD_ref) + + call ioconf_startdate(INT(jD_ref), jH_ref) + + write(lunout,*)'DEBUG' + write(lunout,*)'annee_ref, mois, day_ref, heure, jD_ref' + write(lunout,*)annee_ref, mois, day_ref, heure, jD_ref + call ju2ymds(jD_ref+jH_ref,an, mois, jour, heure) + write(lunout,*)'jD_ref+jH_ref,an, mois, jour, heure' + write(lunout,*)jD_ref+jH_ref,an, mois, jour, heure +#else +! Ehouarn: we still need to define JD_ref and JH_ref +! and since we don't know how many days there are in a year +! we set JD_ref to 0 (this should be improved ...) + jD_ref=0 + jH_ref=0 +#endif + +c nombre d'etats dans les fichiers demarrage et histoire + nbetatdem = nday / iecri + nbetatmoy = nday / periodav + 1 + +c----------------------------------------------------------------------- +c Initialisation des constantes dynamiques : +c ------------------------------------------ + dtvr = zdtvr + CALL iniconst + +c----------------------------------------------------------------------- +c Initialisation de la geometrie : +c -------------------------------- + CALL inigeom + +c----------------------------------------------------------------------- +c Initialisation du filtre : +c -------------------------- + CALL inifilr +c +c----------------------------------------------------------------------- +c Initialisation de la dissipation : +c ---------------------------------- + + CALL inidissip( lstardis, nitergdiv, nitergrot, niterh , + * tetagdiv, tetagrot , tetatemp ) + +c----------------------------------------------------------------------- +c Initialisation de la physique : +c ------------------------------- + IF (call_iniphys.and.iflag_phys.eq.1) THEN + latfi(1)=rlatu(1) + lonfi(1)=0. + zcufi(1) = cu(1) + zcvfi(1) = cv(1) + DO j=2,jjm + DO i=1,iim + latfi((j-2)*iim+1+i)= rlatu(j) + lonfi((j-2)*iim+1+i)= rlonv(i) + zcufi((j-2)*iim+1+i) = cu((j-1)*iip1+i) + zcvfi((j-2)*iim+1+i) = cv((j-1)*iip1+i) + ENDDO + ENDDO + latfi(ngridmx)= rlatu(jjp1) + lonfi(ngridmx)= 0. + zcufi(ngridmx) = cu(ip1jm+1) + zcvfi(ngridmx) = cv(ip1jm-iim) + CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi) + + WRITE(lunout,*) + . 'GCM: WARNING!!! vitesse verticale nulle dans la physique' +! Earth: + if (planet_type.eq."earth") then +#ifdef CPP_EARTH + CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys , + , latfi,lonfi,airefi,zcufi,zcvfi,rad,g,r,cpp ) +#endif + endif ! of if (planet_type.eq."earth") + call_iniphys=.false. + ENDIF ! of IF (call_iniphys.and.(iflag_phys.eq.1)) + + +c----------------------------------------------------------------------- +c Initialisation des dimensions d'INCA : +c -------------------------------------- + IF (config_inca /= 'none') THEN +!$OMP PARALLEL +#ifdef INCA + CALL init_inca_dim(klon_omp,llm,iim,jjm, + $ rlonu,rlatu,rlonv,rlatv) +#endif +!$OMP END PARALLEL + END IF + +c----------------------------------------------------------------------- +c Initialisation des I/O : +c ------------------------ + + + day_end = day_ini + nday + WRITE(lunout,300)day_ini,day_end + 300 FORMAT('1'/,15x,'run du jour',i7,2x,'au jour',i7//) + +#ifdef CPP_IOIPSL + call ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure) + write (lunout,301)jour, mois, an + call ju2ymds(jD_ref + day_end - day_ref, an, mois, jour, heure) + write (lunout,302)jour, mois, an + 301 FORMAT('1'/,15x,'run du ', i2,'/',i2,'/',i4) + 302 FORMAT('1'/,15x,' au ', i2,'/',i2,'/',i4) +#endif + + if (planet_type.eq."earth") then + CALL dynredem0_p("restart.nc", day_end, phis) + endif + + ecripar = .TRUE. + +#ifdef CPP_IOIPSL + if ( 1.eq.1) then + time_step = zdtvr + t_ops = iecri * daysec + t_wrt = iecri * daysec +! CALL inithist_p(dynhist_file,day_ref,annee_ref,time_step, +! . t_ops, t_wrt, histid, histvid) + + IF (ok_dynzon) THEN + t_ops = iperiod * time_step + t_wrt = periodav * daysec +! CALL initdynav_p(dynhistave_file,day_ref,annee_ref,time_step, +! . t_ops, t_wrt, histaveid) + END IF + dtav = iperiod*dtvr/daysec + endif + + +#endif +! #endif of #ifdef CPP_IOIPSL + +c Choix des frequences de stokage pour le offline +c istdyn=day_step/4 ! stockage toutes les 6h=1jour/4 +c istdyn=day_step/12 ! stockage toutes les 2h=1jour/12 + istdyn=day_step/4 ! stockage toutes les 6h=1jour/12 + istphy=istdyn/iphysiq + + +c +c----------------------------------------------------------------------- +c Integration temporelle du modele : +c ---------------------------------- + +c write(78,*) 'ucov',ucov +c write(78,*) 'vcov',vcov +c write(78,*) 'teta',teta +c write(78,*) 'ps',ps +c write(78,*) 'q',q + +c$OMP PARALLEL DEFAULT(SHARED) COPYIN(/temps/,/logic/) + CALL leapfrog_p(ucov,vcov,teta,ps,masse,phis,q,clesphy0, + . time_0) +c$OMP END PARALLEL + + + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/geopot.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/geopot.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/geopot.F (revision 1280) @@ -0,0 +1,64 @@ +! +! $Header$ +! + SUBROUTINE geopot (ngrid, teta, pk, pks, phis, phi ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c .... calcul du geopotentiel aux milieux des couches ..... +c ******************************************************************* +c +c .... l'integration se fait de bas en haut .... +c +c .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg .. +c phi est un argum. de sortie pour le s-pg . +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + +c Arguments: +c ---------- + + INTEGER ngrid + REAL teta(ngrid,llm),pks(ngrid),phis(ngrid),pk(ngrid,llm) , + * phi(ngrid,llm) + + +c Local: +c ------ + + INTEGER l, ij + + +c----------------------------------------------------------------------- +c calcul de phi au niveau 1 pres du sol ..... + + DO 1 ij = 1, ngrid + phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) ) + 1 CONTINUE + +c calcul de phi aux niveaux superieurs ....... + + DO l = 2,llm + DO ij = 1,ngrid + phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l) + teta(ij,l-1) ) + * * ( pk(ij,l-1) - pk(ij,l) ) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/geopot_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/geopot_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/geopot_p.F (revision 1280) @@ -0,0 +1,66 @@ + SUBROUTINE geopot_p ( ngrid, teta, pk, pks, phis, phi ) + USE parallel + IMPLICIT NONE + + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c .... calcul du geopotentiel aux milieux des couches ..... +c ******************************************************************* +c +c .... l'integration se fait de bas en haut .... +c +c .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg .. +c phi est un argum. de sortie pour le s-pg . +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + +c Arguments: +c ---------- + INTEGER ngrid + REAL teta(ngrid,llm),pks(ngrid),phis(ngrid),pk(ngrid,llm) , + * phi(ngrid,llm) + + +c Local: +c ------ + + INTEGER l, ij,ijb,ije + + +c----------------------------------------------------------------------- +c calcul de phi au niveau 1 pres du sol ..... + ijb=ij_begin + ije=ij_end+iip1 + + IF (pole_sud) ije=ij_end + + DO ij = ijb, ije + phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) ) + ENDDO + +c calcul de phi aux niveaux superieurs ....... + + DO l = 2,llm + DO ij = ijb,ije + phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l) + teta(ij,l-1) ) + * * ( pk(ij,l-1) - pk(ij,l) ) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/getparam.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/getparam.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/getparam.F90 (revision 1280) @@ -0,0 +1,118 @@ +! +! $Id$ +! +MODULE getparam +#ifdef CPP_IOIPSL + USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + USE ioipsl_getincom +#endif + + INTERFACE getpar + MODULE PROCEDURE ini_getparam,fin_getparam,getparamr,getparami,getparaml + END INTERFACE + + INTEGER, PARAMETER :: out_eff=99 + +CONTAINS + SUBROUTINE ini_getparam(fichier) + USE parallel + ! + IMPLICIT NONE + ! + CHARACTER*(*) :: fichier + IF (mpi_rank==0) OPEN(out_eff,file=fichier,status='unknown',form='formatted') + + END SUBROUTINE ini_getparam + + SUBROUTINE fin_getparam + USE parallel + ! + IMPLICIT NONE + ! + IF (mpi_rank==0) CLOSE(out_eff) + + END SUBROUTINE fin_getparam + + SUBROUTINE getparamr(TARGET,def_val,ret_val,comment) + USE parallel + ! + IMPLICIT NONE + ! + ! Get a real scalar. We first check if we find it + ! in the database and if not we get it from the run.def + ! + ! getinr1d and getinr2d are written on the same pattern + ! + CHARACTER*(*) :: TARGET + REAL :: def_val + REAL :: ret_val + CHARACTER*(*) :: comment + + ret_val=def_val + call getin(TARGET,ret_val) + + IF (mpi_rank==0) THEN + write(out_eff,*) '######################################' + write(out_eff,*) '#### ',comment,' #####' + write(out_eff,*) TARGET,'=',ret_val + ENDIF + + END SUBROUTINE getparamr + + SUBROUTINE getparami(TARGET,def_val,ret_val,comment) + USE parallel + ! + IMPLICIT NONE + ! + ! Get a real scalar. We first check if we find it + ! in the database and if not we get it from the run.def + ! + ! getinr1d and getinr2d are written on the same pattern + ! + CHARACTER*(*) :: TARGET + INTEGER :: def_val + INTEGER :: ret_val + CHARACTER*(*) :: comment + + ret_val=def_val + call getin(TARGET,ret_val) + + IF (mpi_rank==0) THEN + write(out_eff,*) '######################################' + write(out_eff,*) '#### ',comment,' #####' + write(out_eff,*) comment + write(out_eff,*) TARGET,'=',ret_val + ENDIF + + END SUBROUTINE getparami + + SUBROUTINE getparaml(TARGET,def_val,ret_val,comment) + USE parallel + ! + IMPLICIT NONE + ! + ! Get a real scalar. We first check if we find it + ! in the database and if not we get it from the run.def + ! + ! getinr1d and getinr2d are written on the same pattern + ! + CHARACTER*(*) :: TARGET + LOGICAL :: def_val + LOGICAL :: ret_val + CHARACTER*(*) :: comment + + ret_val=def_val + call getin(TARGET,ret_val) + + IF (mpi_rank==0) THEN + write(out_eff,*) '######################################' + write(out_eff,*) '#### ',comment,' #####' + write(out_eff,*) TARGET,'=',ret_val + ENDIF + + END SUBROUTINE getparaml + + +END MODULE getparam Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_dyn_fi.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_dyn_fi.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_dyn_fi.F (revision 1280) @@ -0,0 +1,38 @@ +! +! $Header$ +! + SUBROUTINE gr_dyn_fi(nfield,im,jm,ngrid,pdyn,pfi) + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER j,ifield,ig + +c----------------------------------------------------------------------- +c calcul: +c ------- + + IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim' +c traitement des poles + CALL SCOPY(nfield,pdyn,im*jm,pfi,ngrid) + CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(ngrid,1),ngrid) + +c traitement des point normaux + DO ifield=1,nfield + DO j=2,jm-1 + ig=2+(j-2)*(im-1) + CALL SCOPY(im-1,pdyn(1,j,ifield),1,pfi(ig,ifield),1) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_dyn_fi_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_dyn_fi_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_dyn_fi_p.F (revision 1280) @@ -0,0 +1,49 @@ +! +! $Id$ +! + SUBROUTINE gr_dyn_fi_p(nfield,im,jm,ngrid,pdyn,pfi) +#ifdef CPP_EARTH +! Interface with parallel physics, +! for now this routine only works with Earth physics + USE mod_interface_dyn_phys + USE dimphy + USE PARALLEL + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER i,j,ig,l + +c----------------------------------------------------------------------- +c calcul: +c ------- + +c IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim' +c traitement des poles +c traitement des point normaux +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nfield + DO ig=1,klon + i=index_i(ig) + j=index_j(ig) + pfi(ig,l)=pdyn(i,j,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +#else + write(lunout,*) "gr_fi_dyn_p : This routine should not be called", + & "without parallelized physics" + stop +#endif +! of #ifdef CPP_EARTH + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_ecrit_fi.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_ecrit_fi.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_ecrit_fi.F (revision 1280) @@ -0,0 +1,32 @@ +! +! $Header$ +! + SUBROUTINE gr_ecrit_fi(nfield,nlon,iim,jjmp1,ecrit,fi) + + IMPLICIT none + +c Transformer une variable de la grille d'ecriture a la grille physique + + INTEGER nfield,nlon,iim,jjmp1, jjm + REAL fi(nlon,nfield), ecrit(iim,jjmp1,nfield) +c + INTEGER i, j, n, ig +c +c print*,'iim jjm ',iim,jjm + +c modif par abd 21 02 01 + + jjm = jjmp1 - 1 + do n = 1, nfield + fi(1,n) = ecrit(1,1,n) + fi(nlon,n) = ecrit(1,jjm+1,n) + DO j = 2, jjm + ig = 2+(j-2)*iim + DO i = 1, iim + fi(ig-1+i,n) = ecrit(i,j,n) + ENDDO + ENDDO + ENDDO + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_fi_dyn.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_fi_dyn.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_fi_dyn.F (revision 1280) @@ -0,0 +1,40 @@ +! +! $Header$ +! + SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn) + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER i,j,ifield,ig + +c----------------------------------------------------------------------- +c calcul: +c ------- + + DO ifield=1,nfield +c traitement des poles + DO i=1,im + pdyn(i,1,ifield)=pfi(1,ifield) + pdyn(i,jm,ifield)=pfi(ngrid,ifield) + ENDDO + +c traitement des point normaux + DO j=2,jm-1 + ig=2+(j-2)*(im-1) + CALL SCOPY(im-1,pfi(ig,ifield),1,pdyn(1,j,ifield),1) + pdyn(im,j,ifield)=pdyn(1,j,ifield) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_fi_dyn_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_fi_dyn_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_fi_dyn_p.F (revision 1280) @@ -0,0 +1,61 @@ +! +! $Id$ +! + SUBROUTINE gr_fi_dyn_p(nfield,ngrid,im,jm,pfi,pdyn) +#ifdef CPP_EARTH +! Interface with parallel physics, +! for now this routine only works with Earth physics + USE mod_interface_dyn_phys + USE dimphy + use parallel + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER i,j,ifield,ig + +c----------------------------------------------------------------------- +c calcul: +c ------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO ifield=1,nfield + + do ig=1,klon + i=index_i(ig) + j=index_j(ig) + pdyn(i,j,ifield)=pfi(ig,ifield) + if (i==1) pdyn(im,j,ifield)=pdyn(i,j,ifield) + enddo + +c traitement des poles + if (pole_nord) then + do i=1,im + pdyn(i,1,ifield)=pdyn(1,1,ifield) + enddo + endif + + if (pole_sud) then + do i=1,im + pdyn(i,jm,ifield)=pdyn(1,jm,ifield) + enddo + endif + + ENDDO +c$OMP END DO NOWAIT +#else + write(lunout,*) "gr_fi_dyn_p : This routine should not be called", + & "without parallelized physics" + stop +#endif +! of #ifdef CPP_EARTH + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_int_dyn.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_int_dyn.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_int_dyn.F (revision 1280) @@ -0,0 +1,49 @@ +! +! $Header$ +! + subroutine gr_int_dyn(champin,champdyn,iim,jp1) + implicit none +c======================================================================= +c passage d'un champ interpole a un champ sur grille scalaire +c======================================================================= +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER iim + integer ip1, jp1 + REAL champin(iim, jp1) + REAL champdyn(iim+1, jp1) + + INTEGER i, j + real polenord, polesud + +c----------------------------------------------------------------------- +c calcul: +c ------- + + ip1 = iim + 1 + polenord = 0. + polesud = 0. + do i = 1, iim + polenord = polenord + champin (i, 1) + polesud = polesud + champin (i, jp1) + enddo + polenord = polenord / iim + polesud = polesud / iim + do j = 1, jp1 + do i = 1, iim + if (j .eq. 1) then + champdyn(i, j) = polenord + else if (j .eq. jp1) then + champdyn(i, j) = polesud + else + champdyn(i, j) = champin (i, j) + endif + enddo + champdyn(ip1, j) = champdyn(1, j) + enddo + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_u_scal.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_u_scal.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_u_scal.F (revision 1280) @@ -0,0 +1,60 @@ +! +! $Header$ +! + SUBROUTINE gr_u_scal(nx,x_u,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx) + +c Local: +c ------ + + INTEGER l,ij + +c----------------------------------------------------------------------- + + DO l=1,nx + DO ij=ip1jmp1,2,-1 + x_scal(ij,l)= + s (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l)) + s /(aireu(ij)+aireu(ij-1)) + ENDDO + ENDDO + + CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_u_scal_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_u_scal_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_u_scal_p.F (revision 1280) @@ -0,0 +1,72 @@ +! +! $Header$ +! + SUBROUTINE gr_u_scal_p(nx,x_u,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + USE parallel + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx) + +c Local: +c ------ + + INTEGER l,ij + INTEGER :: ijb,ije + +c----------------------------------------------------------------------- + ijb=ij_begin + ije=ij_end + + DO l=1,nx + DO ij=ijb+1,ije + x_scal(ij,l)= + s (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l)) + s /(aireu(ij)+aireu(ij-1)) + ENDDO + ENDDO + +cym CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1) + ijb=ij_begin + ije=ij_end + + DO l=1,nx + DO ij=ijb,ije-iip1+1,iip1 + x_scal(ij,l)=x_scal(ij+iip1-1,l) + ENDDO + ENDDO + RETURN + + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_v_scal.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_v_scal.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_v_scal.F (revision 1280) @@ -0,0 +1,64 @@ +! +! $Header$ +! + SUBROUTINE gr_v_scal(nx,x_v,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_v(ip1jm,nx),x_scal(ip1jmp1,nx) + +c Local: +c ------ + + INTEGER l,ij + +c----------------------------------------------------------------------- + + DO l=1,nx + DO ij=iip2,ip1jm + x_scal(ij,l)= + s (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l)) + s /(airev(ij-iip1)+airev(ij)) + ENDDO + DO ij=1,iip1 + x_scal(ij,l)=0. + ENDDO + DO ij=ip1jm+1,ip1jmp1 + x_scal(ij,l)=0. + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_v_scal_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_v_scal_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gr_v_scal_p.F (revision 1280) @@ -0,0 +1,79 @@ +! +! $Header$ +! + SUBROUTINE gr_v_scal_p(nx,x_v,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + USE parallel + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_v(ip1jm,nx),x_scal(ip1jmp1,nx) + +c Local: +c ------ + + INTEGER l,ij + INTEGER :: ijb,ije +c----------------------------------------------------------------------- + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO l=1,nx + DO ij=ijb,ije + x_scal(ij,l)= + s (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l)) + s /(airev(ij-iip1)+airev(ij)) + ENDDO + ENDDO + + if (pole_nord) then + DO l=1,nx + DO ij=1,iip1 + x_scal(ij,l)=0. + ENDDO + ENDDO + endif + + if (pole_sud) then + DO l=1,nx + DO ij=ip1jm+1,ip1jmp1 + x_scal(ij,l)=0. + ENDDO + ENDDO + endif + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/grad.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/grad.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/grad.F (revision 1280) @@ -0,0 +1,44 @@ +! +! $Header$ +! + SUBROUTINE grad(klevel, pg,pgx,pgy ) +c +c P. Le Van +c +c ****************************************************************** +c .. calcul des composantes covariantes en x et y du gradient de g +c +c ****************************************************************** +c pg est un argument d'entree pour le s-prog +c pgx et pgy sont des arguments de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + INTEGER klevel + REAL pg( ip1jmp1,klevel ) + REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel ) + INTEGER l,ij +c +c + DO 6 l = 1,klevel +c + DO 2 ij = 1, ip1jmp1 - 1 + pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l ) + 2 CONTINUE +c +c .... correction pour pgx(ip1,j,l) .... +c ... pgx(iip1,j,l)= pgx(1,j,l) .... +CDIR$ IVDEP + DO 3 ij = iip1, ip1jmp1, iip1 + pgx( ij,l ) = pgx( ij -iim,l ) + 3 CONTINUE +c + DO 4 ij = 1,ip1jm + pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l ) + 4 CONTINUE +c + 6 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/grad_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/grad_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/grad_p.F (revision 1280) @@ -0,0 +1,53 @@ + SUBROUTINE grad_p(klevel, pg,pgx,pgy ) +c +c P. Le Van +c +c ****************************************************************** +c .. calcul des composantes covariantes en x et y du gradient de g +c +c ****************************************************************** +c pg est un argument d'entree pour le s-prog +c pgx et pgy sont des arguments de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + INTEGER klevel + REAL pg( ip1jmp1,klevel ) + REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel ) + INTEGER l,ij + INTEGER :: ijb,ije,jjb,jje +c +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 6 l = 1,klevel +c + ijb=ij_begin + ije=ij_end + DO 2 ij = ijb, ije - 1 + pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l ) + 2 CONTINUE +c +c .... correction pour pgx(ip1,j,l) .... +c ... pgx(iip1,j,l)= pgx(1,j,l) .... +CDIR$ IVDEP + DO 3 ij = ijb+iip1-1, ije, iip1 + pgx( ij,l ) = pgx( ij -iim,l ) + 3 CONTINUE +c + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO 4 ij = ijb,ije + pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l ) + 4 CONTINUE +c + 6 CONTINUE +c$OMP END DO NOWAIT + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gradiv.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gradiv.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gradiv.F (revision 1280) @@ -0,0 +1,57 @@ +! +! $Header$ +! + SUBROUTINE gradiv(klevel, xcov, ycov, ld, gdx, gdy ) +c +c Auteur : P. Le Van +c +c *************************************************************** +c +c ld +c calcul de (grad (div) ) du vect. v .... +c +c xcov et ycov etant les composant.covariantes de v +c **************************************************************** +c xcov , ycov et ld sont des arguments d'entree pour le s-prog +c gdx et gdy sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "logic.h" + + INTEGER klevel +c + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL gdx( ip1jmp1,klevel ), gdy( ip1jm,klevel ) + + REAL div(ip1jmp1,llm) + + INTEGER l,ij,iter,ld +c +c +c + CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 ) + CALL SCOPY( ip1jm*klevel, ycov,1,gdy,1 ) +c + DO 10 iter = 1,ld +c + CALL diverg( klevel, gdx , gdy, div ) + CALL filtreg( div, jjp1, klevel, 2,1, .true.,2 ) + CALL grad( klevel, div, gdx, gdy ) +c + DO 5 l = 1, klevel + DO 3 ij = 1, ip1jmp1 + gdx( ij,l ) = - gdx( ij,l ) * cdivu + 3 CONTINUE + DO 4 ij = 1, ip1jm + gdy( ij,l ) = - gdy( ij,l ) * cdivu + 4 CONTINUE + 5 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gradiv2.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gradiv2.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gradiv2.F (revision 1280) @@ -0,0 +1,79 @@ +! +! $Header$ +! + SUBROUTINE gradiv2(klevel, xcov, ycov, ld, gdx, gdy ) +c +c P. Le Van +c +c ********************************************************** +c ld +c calcul de (grad (div) ) du vect. v .... +c +c xcov et ycov etant les composant.covariantes de v +c ********************************************************** +c xcont , ycont et ld sont des arguments d'entree pour le s-prog +c gdx et gdy sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comdissipn.h" +c +c ........ variables en arguments ........ + + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL gdx( ip1jmp1,klevel ), gdy( ip1jm,klevel ) +c +c ........ variables locales ......... +c + REAL div(ip1jmp1,llm) + REAL signe, nugrads + INTEGER l,ij,iter,ld + +c ........................................................ +c +c + CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 ) + CALL SCOPY( ip1jm * klevel, ycov, 1, gdy, 1 ) +c +c + signe = (-1.)**ld + nugrads = signe * cdivu +c + + + CALL divergf( klevel, gdx, gdy , div ) + + IF( ld.GT.1 ) THEN + + CALL laplacien ( klevel, div, div ) + +c ...... Iteration de l'operateur laplacien_gam ....... + + DO iter = 1, ld -2 + CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1, + * unsapolnga1, unsapolsga1, div, div ) + ENDDO + + ENDIF + + + CALL filtreg( div , jjp1, klevel, 2, 1, .TRUE., 1 ) + CALL grad ( klevel, div, gdx, gdy ) + +c + DO l = 1, klevel + DO ij = 1, ip1jmp1 + gdx( ij,l ) = gdx( ij,l ) * nugrads + ENDDO + DO ij = 1, ip1jm + gdy( ij,l ) = gdy( ij,l ) * nugrads + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gradiv2_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gradiv2_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gradiv2_p.F (revision 1280) @@ -0,0 +1,147 @@ + SUBROUTINE gradiv2_p(klevel, xcov, ycov, ld, gdx_out, gdy_out ) +c +c P. Le Van +c +c ********************************************************** +c ld +c calcul de (grad (div) ) du vect. v .... +c +c xcov et ycov etant les composant.covariantes de v +c ********************************************************** +c xcont , ycont et ld sont des arguments d'entree pour le s-prog +c gdx et gdy sont des arguments de sortie pour le s-prog +c +c + USE parallel + USE times + USE Write_field_p + USE mod_hallo + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comdissipn.h" +c +c ........ variables en arguments ........ + + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL,SAVE :: gdx( ip1jmp1,llm ), gdy( ip1jm,llm ) + REAL gdx_out( ip1jmp1,klevel ), gdy_out( ip1jm,klevel ) +c +c ........ variables locales ......... +c + REAL,SAVE :: div(ip1jmp1,llm) + REAL :: tmp_div2(ip1jmp1,llm) + REAL signe, nugrads + INTEGER l,ij,iter,ld + INTEGER :: ijb,ije,jjb,jje + Type(Request) :: request_dissip + +c ........................................................ +c +c +c CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 ) +c CALL SCOPY( ip1jm * klevel, ycov, 1, gdy, 1 ) + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + gdx(ijb:ije,l)=xcov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + gdy(ijb:ije,l)=ycov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c$OMP BARRIER + call Register_Hallo(gdy,ip1jm,llm,1,0,0,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER +c +c + signe = (-1.)**ld + nugrads = signe * cdivu +c + + + CALL divergf_p( klevel, gdx, gdy , div ) +c call write_field3d_p('div1',reshape(div,(/iip1,jjp1,llm/))) + + IF( ld.GT.1 ) THEN +c$OMP BARRIER + call Register_Hallo(div,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + CALL laplacien_p ( klevel, div, div ) + +c ...... Iteration de l'operateur laplacien_gam ....... +c call write_field3d_p('div2',reshape(div,(/iip1,jjp1,llm/))) + + DO iter = 1, ld -2 +c$OMP BARRIER + call Register_Hallo(div,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) + +c$OMP BARRIER + + CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1, + * unsapolnga1, unsapolsga1, div, div ) + ENDDO +c call write_field3d_p('div3',reshape(div,(/iip1,jjp1,llm/))) + ENDIF + + jjb=jj_begin + jje=jj_end + + CALL filtreg_p( div ,jjb,jje, jjp1, klevel, 2, 1, .TRUE., 1 ) +c call exchange_Hallo(div,ip1jmp1,llm,0,1) +c$OMP BARRIER + call Register_Hallo(div,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) + +c$OMP BARRIER + + + CALL grad_p ( klevel, div, gdx, gdy ) + +c + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + + if (pole_sud) ije=ij_end + DO ij = ijb, ije + gdx_out( ij,l ) = gdx( ij,l ) * nugrads + ENDDO + + if (pole_sud) ije=ij_end-iip1 + DO ij = ijb, ije + gdy_out( ij,l ) = gdy( ij,l ) * nugrads + ENDDO + + ENDDO +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gradiv_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gradiv_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gradiv_p.F (revision 1280) @@ -0,0 +1,109 @@ + SUBROUTINE gradiv_p(klevel, xcov, ycov, ld, gdx_out, gdy_out ) +c +c Auteur : P. Le Van +c +c *************************************************************** +c +c ld +c calcul de (grad (div) ) du vect. v .... +c +c xcov et ycov etant les composant.covariantes de v +c **************************************************************** +c xcov , ycov et ld sont des arguments d'entree pour le s-prog +c gdx et gdy sont des arguments de sortie pour le s-prog +c +c + USE parallel + USE times + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "logic.h" + + INTEGER klevel +c + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL,SAVE :: gdx( ip1jmp1,llm ), gdy( ip1jm,llm ) + + REAL gdx_out( ip1jmp1,klevel ), gdy_out( ip1jm,klevel ) + + REAL,SAVE :: div(ip1jmp1,llm) + + INTEGER l,ij,iter,ld +c + INTEGER ijb,ije,jjb,jje +c +c +c CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 ) +c CALL SCOPY( ip1jm*klevel, ycov,1,gdy,1 ) + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,klevel + gdx(ijb:ije,l)=xcov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,klevel + gdy(ijb:ije,l)=ycov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c + DO 10 iter = 1,ld + +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(gdy,ip1jm,llm,1,0) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + + CALL diverg_p( klevel, gdx , gdy, div ) + + jjb=jj_begin + jje=jj_end + CALL filtreg_p( div,jjb,jje, jjp1, klevel, 2,1, .true.,2 ) + +c call exchange_Hallo(div,ip1jmp1,llm,0,1) + +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(div,ip1jmp1,llm,1,1) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + + CALL grad_p( klevel, div, gdx, gdy ) +c + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1, klevel + + if(pole_sud) ije=ij_end + DO 3 ij = ijb, ije + gdx_out( ij,l ) = - gdx( ij,l ) * cdivu + 3 CONTINUE + + if(pole_sud) ije=ij_end-iip1 + DO 4 ij = ijb, ije + gdy_out( ij,l ) = - gdy( ij,l ) * cdivu + 4 CONTINUE + + 5 CONTINUE +c$OMP END DO NOWAIT +c + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gradsdef.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gradsdef.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/gradsdef.h (revision 1280) @@ -0,0 +1,23 @@ +! +! $Header$ +! + integer nfmx,imx,jmx,lmx,nvarmx + parameter(nfmx=10,imx=200,jmx=150,lmx=200,nvarmx=1000) + + real xd(imx,nfmx),yd(jmx,nfmx),zd(lmx,nfmx),dtime(nfmx) + + integer imd(imx),jmd(jmx),lmd(lmx) + integer iid(imx),jid(jmx) + integer ifd(imx),jfd(jmx) + integer unit(nfmx),irec(nfmx),itime(nfmx),nld(nvarmx,nfmx) + + integer nvar(nfmx),ivar(nfmx) + logical firsttime(nfmx) + + character*10 var(nvarmx,nfmx),fichier(nfmx) + character*40 title(nfmx),tvar(nvarmx,nfmx) + + common/gradsdef/xd,yd,zd,dtime, + s imd,jmd,lmd,iid,jid,ifd,jfd, + s unit,irec,nvar,ivar,itime,nld,firsttime, + s var,fichier,title,tvar Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/grid_atob.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/grid_atob.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/grid_atob.F (revision 1280) @@ -0,0 +1,971 @@ +! +! $Header$ +! + SUBROUTINE grille_m(imdep, jmdep, xdata, ydata, entree, + . imar, jmar, x, y, sortie) +c======================================================================= +c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead) +c +c Methode naive pour transformer un champ d'une grille fine a une +c grille grossiere. Je considere que les nouveaux points occupent +c une zone adjacente qui comprend un ou plusieurs anciens points +c +c Aucune ponderation est consideree (voir grille_p) +c +c (c) +c ----d----- +c | . . . .| +c | | +c (b)a . * . .b(a) +c | | +c | . . . .| +c ----c----- +c (d) +C======================================================================= +c INPUT: +c imdep, jmdep: dimensions X et Y pour depart +c xdata, ydata: coordonnees X et Y pour depart +c entree: champ d'entree a transformer +c OUTPUT: +c imar, jmar: dimensions X et Y d'arrivee +c x, y: coordonnees X et Y d'arrivee +c sortie: champ de sortie deja transforme +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL entree(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL sortie(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(2200),b(2200),c(1100),d(1100) + REAL number(2200,1100) + REAL distans(2200*1100) + INTEGER i_proche, j_proche, ij_proche +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + IF (imar.GT.2200 .OR. jmar.GT.1100) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c +c Calculer les limites des zones des nouveaux points +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + number(i,j) = 0.0 + sortie(i,j) = 0.0 + ENDDO + ENDDO +c +c Determiner la zone sur laquelle chaque ancien point se trouve +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + number(ii,jj) = number(ii,jj) + 1.0 + sortie(ii,jj) = sortie(ii,jj) + entree(i,j) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c Si aucun ancien point tombe sur une zone, c'est un probleme +c + + DO i = 1, imar + DO j = 1, jmar + IF (number(i,j) .GT. 0.001) THEN + sortie(i,j) = sortie(i,j) / number(i,j) + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans) +#ifdef CRAY + ij_proche = ISMIN(imdep*jmdep,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imdep*jmdep + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imdep + 1 + i_proche = ij_proche - (j_proche-1)*imdep + PRINT*, "solution:", ij_proche, i_proche, j_proche + sortie(i,j) = entree(i_proche,j_proche) + ENDIF + ENDDO + ENDDO + + RETURN + END + + + SUBROUTINE grille_p(imdep, jmdep, xdata, ydata, entree, + . imar, jmar, x, y, sortie) +c======================================================================= +c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead) +c +c Methode naive pour transformer un champ d'une grille fine a une +c grille grossiere. Je considere que les nouveaux points occupent +c une zone adjacente qui comprend un ou plusieurs anciens points +c +c Consideration de la distance des points (voir grille_m) +c +c (c) +c ----d----- +c | . . . .| +c | | +c (b)a . * . .b(a) +c | | +c | . . . .| +c ----c----- +c (d) +C======================================================================= +c INPUT: +c imdep, jmdep: dimensions X et Y pour depart +c xdata, ydata: coordonnees X et Y pour depart +c entree: champ d'entree a transformer +c OUTPUT: +c imar, jmar: dimensions X et Y d'arrivee +c x, y: coordonnees X et Y d'arrivee +c sortie: champ de sortie deja transforme +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL entree(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL sortie(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(400),b(400),c(200),d(200) + REAL number(400,200) + INTEGER indx(400,200), indy(400,200) + REAL dist(400,200), distsom(400,200) +c + IF (imar.GT.400 .OR. jmar.GT.200) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + IF (imdep.GT.400 .OR. jmdep.GT.200) THEN + PRINT*, 'imdep ou jmdep trop grand', imdep, jmdep + CALL ABORT + ENDIF +c +c calculer les bords a et b de la nouvelle grille +c + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + +c +c calculer les bords c et d de la nouvelle grille +c + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + +c +c trouver les indices (indx,indy) de la nouvelle grille sur laquelle +c un point de l'ancienne grille est tombe. +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + indx(i,j) = ii + indy(i,j) = jj + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c faire une verification +c + + DO i = 1, imdep + DO j = 1, jmdep + IF (indx(i,j).GT.imar .OR. indy(i,j).GT.jmar) THEN + PRINT*, 'Probleme grave,i,j,indx,indy=', + . i,j,indx(i,j),indy(i,j) + CALL abort + ENDIF + ENDDO + ENDDO + +c +c calculer la distance des anciens points avec le nouveau point, +c on prend ensuite une sorte d'inverse pour ponderation. +c + + DO i = 1, imar + DO j = 1, jmar + number(i,j) = 0.0 + distsom(i,j) = 0.0 + ENDDO + ENDDO + DO i = 1, imdep + DO j = 1, jmdep + dist(i,j) = SQRT ( (xdata(i)-x(indx(i,j)))**2 + . +(ydata(j)-y(indy(i,j)))**2 ) + distsom(indx(i,j),indy(i,j)) = distsom(indx(i,j),indy(i,j)) + . + dist(i,j) + number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j)) +1. + ENDDO + ENDDO + DO i = 1, imdep + DO j = 1, jmdep + dist(i,j) = 1.0 - dist(i,j)/distsom(indx(i,j),indy(i,j)) + ENDDO + ENDDO + + DO i = 1, imar + DO j = 1, jmar + number(i,j) = 0.0 + sortie(i,j) = 0.0 + ENDDO + ENDDO + DO i = 1, imdep + DO j = 1, jmdep + sortie(indx(i,j),indy(i,j)) = sortie(indx(i,j),indy(i,j)) + . + entree(i,j) * dist(i,j) + number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j)) + . + dist(i,j) + ENDDO + ENDDO + DO i = 1, imar + DO j = 1, jmar + IF (number(i,j) .GT. 0.001) THEN + sortie(i,j) = sortie(i,j) / number(i,j) + ELSE + PRINT*, 'probleme,i,j=', i,j + CALL ABORT + ENDIF + ENDDO + ENDDO + + RETURN + END + + + + + SUBROUTINE mask_c_o(imdep, jmdep, xdata, ydata, relief, + . imar, jmar, x, y, mask) +c======================================================================= +c z.x.li (le 1 avril 1994): A partir du champ de relief, on fabrique +c un champ indicateur (masque) terre/ocean +c terre:1; ocean:0 +c +c Methode naive (voir grille_m) +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL relief(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL mask(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(2200),b(2200),c(1100),d(1100) + REAL num_tot(2200,1100), num_oce(2200,1100) +c + IF (imar.GT.2200 .OR. jmar.GT.1100) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + num_oce(i,j) = 0.0 + num_tot(i,j) = 0.0 + ENDDO + ENDDO + +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + num_tot(ii,jj) = num_tot(ii,jj) + 1.0 + IF (.NOT. ( relief(i,j) - 0.9. GE. 1.e-5 ) ) + . num_oce(ii,jj) = num_oce(ii,jj) + 1.0 + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c +c + DO i = 1, imar + DO j = 1, jmar + IF (num_tot(i,j) .GT. 0.001) THEN + IF ( num_oce(i,j)/num_tot(i,j) - 0.5 .GE. 1.e-5 ) THEN + mask(i,j) = 0. + ELSE + mask(i,j) = 1. + ENDIF + ELSE + PRINT*, 'probleme,i,j=', i,j + CALL ABORT + ENDIF + ENDDO + ENDDO + + RETURN + END +c +c + + + SUBROUTINE rugosite(imdep, jmdep, xdata, ydata, entree, + . imar, jmar, x, y, sortie, mask) +c======================================================================= +c z.x.li (le 1 avril 1994): Transformer la longueur de rugosite d'une +c grille fine a une grille grossiere. Sur l'ocean, on impose une valeur +c fixe (0.001m). +c +c Methode naive (voir grille_m) +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL entree(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL sortie(imar,jmar), mask(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(400),b(400),c(400),d(400) + REAL num_tot(400,400) + REAL distans(400*400) + INTEGER i_proche, j_proche, ij_proche +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + IF (imar.GT.400 .OR. jmar.GT.400) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + num_tot(i,j) = 0.0 + sortie(i,j) = 0.0 + ENDDO + ENDDO + +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + sortie(ii,jj) = sortie(ii,jj) + LOG(entree(i,j)) + num_tot(ii,jj) = num_tot(ii,jj) + 1.0 + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c + + DO i = 1, imar + DO j = 1, jmar + IF (NINT(mask(i,j)).EQ.1) THEN + IF (num_tot(i,j) .GT. 0.0) THEN + sortie(i,j) = sortie(i,j) / num_tot(i,j) + sortie(i,j) = EXP(sortie(i,j)) + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans) +#ifdef CRAY + ij_proche = ISMIN(imdep*jmdep,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imdep*jmdep + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imdep + 1 + i_proche = ij_proche - (j_proche-1)*imdep + PRINT*, "solution:", ij_proche, i_proche, j_proche + sortie(i,j) = entree(i_proche,j_proche) + ENDIF + ELSE + sortie(i,j) = 0.001 + ENDIF + ENDDO + ENDDO + + RETURN + END + + + + + + SUBROUTINE sea_ice(imdep, jmdep, xdata, ydata, glace01, + . imar, jmar, x, y, frac_ice) +c======================================================================= +c z.x.li (le 1 avril 1994): Transformer un champ d'indicateur de la +c glace (1, sinon 0) d'une grille fine a un champ de fraction de glace +c (entre 0 et 1) dans une grille plus grossiere. +c +c Methode naive (voir grille_m) +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL glace01(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL frac_ice(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(400),b(400),c(400),d(400) + REAL num_tot(400,400), num_ice(400,400) + REAL distans(400*400) + INTEGER i_proche, j_proche, ij_proche +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + IF (imar.GT.400 .OR. jmar.GT.400) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + num_ice(i,j) = 0.0 + num_tot(i,j) = 0.0 + ENDDO + ENDDO + +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + num_tot(ii,jj) = num_tot(ii,jj) + 1.0 + IF (NINT(glace01(i,j)).EQ.1 ) + . num_ice(ii,jj) = num_ice(ii,jj) + 1.0 + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c + + DO i = 1, imar + DO j = 1, jmar + IF (num_tot(i,j) .GT. 0.001) THEN + IF (num_ice(i,j).GT.0.001) THEN + frac_ice(i,j) = num_ice(i,j) / num_tot(i,j) + ELSE + frac_ice(i,j) = 0.0 + ENDIF + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans) +#ifdef CRAY + ij_proche = ISMIN(imdep*jmdep,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imdep*jmdep + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imdep + 1 + i_proche = ij_proche - (j_proche-1)*imdep + PRINT*, "solution:", ij_proche, i_proche, j_proche + IF (NINT(glace01(i_proche,j_proche)).EQ.1 ) THEN + frac_ice(i,j) = 1.0 + ELSE + frac_ice(i,j) = 0.0 + ENDIF + ENDIF + ENDDO + ENDDO + + RETURN + END + + + + SUBROUTINE rugsoro(imrel, jmrel, xrel, yrel, relief, + . immod, jmmod, xmod, ymod, rugs) +c======================================================================= +c Calculer la longueur de rugosite liee au relief en utilisant +c l'ecart-type dans une maille de 1x1 +C======================================================================= + IMPLICIT none +c +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + REAL amin, AMAX +c + INTEGER imrel, jmrel + REAL xrel(imrel),yrel(jmrel) + REAL relief(imrel,jmrel) +c + INTEGER immod, jmmod + REAL xmod(immod),ymod(jmmod) + REAL rugs(immod,jmmod) +c + INTEGER imtmp, jmtmp + PARAMETER (imtmp=360,jmtmp=180) + REAL xtmp(imtmp), ytmp(jmtmp) + REAL(KIND=8) cham1tmp(imtmp,jmtmp), cham2tmp(imtmp,jmtmp) + REAL zzzz +c + INTEGER i, j, ii, jj + REAL a(2200),b(2200),c(1100),d(1100) + REAL number(2200,1100) +c + REAL distans(400*400) + INTEGER i_proche, j_proche, ij_proche +c + IF (immod.GT.2200 .OR. jmmod.GT.1100) THEN + PRINT*, 'immod ou jmmod trop grand', immod, jmmod + CALL ABORT + ENDIF +c +c Calculs intermediares: +c + xtmp(1) = -180.0 + 360.0/FLOAT(imtmp) / 2.0 + DO i = 2, imtmp + xtmp(i) = xtmp(i-1) + 360.0/FLOAT(imtmp) + ENDDO + DO i = 1, imtmp + xtmp(i) = xtmp(i) /180.0 * 4.0*ATAN(1.0) + ENDDO + ytmp(1) = -90.0 + 180.0/FLOAT(jmtmp) / 2.0 + DO j = 2, jmtmp + ytmp(j) = ytmp(j-1) + 180.0/FLOAT(jmtmp) + ENDDO + DO j = 1, jmtmp + ytmp(j) = ytmp(j) /180.0 * 4.0*ATAN(1.0) + ENDDO +c + a(1) = xtmp(1) - (xtmp(2)-xtmp(1))/2.0 + b(1) = (xtmp(1)+xtmp(2))/2.0 + DO i = 2, imtmp-1 + a(i) = b(i-1) + b(i) = (xtmp(i)+xtmp(i+1))/2.0 + ENDDO + a(imtmp) = b(imtmp-1) + b(imtmp) = xtmp(imtmp) + (xtmp(imtmp)-xtmp(imtmp-1))/2.0 + + c(1) = ytmp(1) - (ytmp(2)-ytmp(1))/2.0 + d(1) = (ytmp(1)+ytmp(2))/2.0 + DO j = 2, jmtmp-1 + c(j) = d(j-1) + d(j) = (ytmp(j)+ytmp(j+1))/2.0 + ENDDO + c(jmtmp) = d(jmtmp-1) + d(jmtmp) = ytmp(jmtmp) + (ytmp(jmtmp)-ytmp(jmtmp-1))/2.0 + + DO i = 1, imtmp + DO j = 1, jmtmp + number(i,j) = 0.0 + cham1tmp(i,j) = 0.0 + cham2tmp(i,j) = 0.0 + ENDDO + ENDDO +c +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imtmp + DO jj = 1, jmtmp + DO i = 1, imrel + IF( ( xrel(i)-a(ii).GE.1.e-5.AND.xrel(i)-b(ii).LE.1.e-5 ).OR. + . ( xrel(i)-a(ii).LE.1.e-5.AND.xrel(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmrel + IF( (yrel(j)-c(jj).GE.1.e-5.AND.yrel(j)-d(jj).LE.1.e-5 ).OR. + . ( yrel(j)-c(jj).LE.1.e-5.AND.yrel(j)-d(jj).GE.1.e-5 ) ) + . THEN + number(ii,jj) = number(ii,jj) + 1.0 + cham1tmp(ii,jj) = cham1tmp(ii,jj) + relief(i,j) + cham2tmp(ii,jj) = cham2tmp(ii,jj) + . + relief(i,j)*relief(i,j) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c + DO i = 1, imtmp + DO j = 1, jmtmp + IF (number(i,j) .GT. 0.001) THEN + cham1tmp(i,j) = cham1tmp(i,j) / number(i,j) + cham2tmp(i,j) = cham2tmp(i,j) / number(i,j) + zzzz=cham2tmp(i,j)-cham1tmp(i,j)**2 + if (zzzz .lt. 0.0) then + if (zzzz .gt. -7.5) then + zzzz = 0.0 + print*,'Pb rugsoro, -7.5 < zzzz < 0, => zzz = 0.0' + else + stop 'Pb rugsoro, zzzz <-7.5' + endif + endif + cham2tmp(i,j) = SQRT(zzzz) + ELSE + PRINT*, 'probleme,i,j=', i,j + CALL ABORT + ENDIF + ENDDO + ENDDO +c + amin = cham2tmp(1,1) + AMAX = cham2tmp(1,1) + DO j = 1, jmtmp + DO i = 1, imtmp + IF (cham2tmp(i,j).GT.AMAX) AMAX = cham2tmp(i,j) + IF (cham2tmp(i,j).LT.amin) amin = cham2tmp(i,j) + ENDDO + ENDDO + PRINT*, 'Ecart-type 1x1:', amin, AMAX +c +c +c + a(1) = xmod(1) - (xmod(2)-xmod(1))/2.0 + b(1) = (xmod(1)+xmod(2))/2.0 + DO i = 2, immod-1 + a(i) = b(i-1) + b(i) = (xmod(i)+xmod(i+1))/2.0 + ENDDO + a(immod) = b(immod-1) + b(immod) = xmod(immod) + (xmod(immod)-xmod(immod-1))/2.0 + + c(1) = ymod(1) - (ymod(2)-ymod(1))/2.0 + d(1) = (ymod(1)+ymod(2))/2.0 + DO j = 2, jmmod-1 + c(j) = d(j-1) + d(j) = (ymod(j)+ymod(j+1))/2.0 + ENDDO + c(jmmod) = d(jmmod-1) + d(jmmod) = ymod(jmmod) + (ymod(jmmod)-ymod(jmmod-1))/2.0 +c + DO i = 1, immod + DO j = 1, jmmod + number(i,j) = 0.0 + rugs(i,j) = 0.0 + ENDDO + ENDDO +c +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, immod + DO jj = 1, jmmod + DO i = 1, imtmp + IF( ( xtmp(i)-a(ii).GE.1.e-5.AND.xtmp(i)-b(ii).LE.1.e-5 ).OR. + . ( xtmp(i)-a(ii).LE.1.e-5.AND.xtmp(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmtmp + IF( (ytmp(j)-c(jj).GE.1.e-5.AND.ytmp(j)-d(jj).LE.1.e-5 ).OR. + . ( ytmp(j)-c(jj).LE.1.e-5.AND.ytmp(j)-d(jj).GE.1.e-5 ) ) + . THEN + number(ii,jj) = number(ii,jj) + 1.0 + rugs(ii,jj) = rugs(ii,jj) + . + LOG(MAX(0.001_8,cham2tmp(i,j))) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c + DO i = 1, immod + DO j = 1, jmmod + IF (number(i,j) .GT. 0.001) THEN + rugs(i,j) = rugs(i,j) / number(i,j) + rugs(i,j) = EXP(rugs(i,j)) + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(xmod(i),ymod(j),xtmp,ytmp,imtmp,jmtmp,distans) +#ifdef CRAY + ij_proche = ISMIN(imtmp*jmtmp,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imtmp*jmtmp + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imtmp + 1 + i_proche = ij_proche - (j_proche-1)*imtmp + PRINT*, "solution:", ij_proche, i_proche, j_proche + rugs(i,j) = LOG(MAX(0.001_8,cham2tmp(i_proche,j_proche))) + ENDIF + ENDDO + ENDDO +c + amin = rugs(1,1) + AMAX = rugs(1,1) + DO j = 1, jmmod + DO i = 1, immod + IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j) + IF (rugs(i,j).LT.amin) amin = rugs(i,j) + ENDDO + ENDDO + PRINT*, 'Ecart-type du modele:', amin, AMAX +c + DO j = 1, jmmod + DO i = 1, immod + rugs(i,j) = rugs(i,j) / AMAX * 20.0 + ENDDO + ENDDO +c + amin = rugs(1,1) + AMAX = rugs(1,1) + DO j = 1, jmmod + DO i = 1, immod + IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j) + IF (rugs(i,j).LT.amin) amin = rugs(i,j) + ENDDO + ENDDO + PRINT*, 'Longueur de rugosite du modele:', amin, AMAX +c + RETURN + END +c + SUBROUTINE dist_sphe(rf_lon,rf_lat,rlon,rlat,im,jm,distance) +c +c Auteur: Laurent Li (le 30 decembre 1996) +c +c Ce programme calcule la distance minimale (selon le grand cercle) +c entre deux points sur la terre +c +c Input: + INTEGER im, jm ! dimensions + REAL rf_lon ! longitude du point de reference (degres) + REAL rf_lat ! latitude du point de reference (degres) + REAL rlon(im), rlat(jm) ! longitude et latitude des points +c +c Output: + REAL distance(im,jm) ! distances en metre +c + REAL rlon1, rlat1 + REAL rlon2, rlat2 + REAL dist + REAL pa, pb, p, pi +c + REAL radius + PARAMETER (radius=6371229.) +c + pi = 4.0 * ATAN(1.0) +c + DO 9999 j = 1, jm + DO 9999 i = 1, im +c + rlon1=rf_lon + rlat1=rf_lat + rlon2=rlon(i) + rlat2=rlat(j) + pa = pi/2.0 - rlat1*pi/180.0 ! dist. entre pole n et point a + pb = pi/2.0 - rlat2*pi/180.0 ! dist. entre pole n et point b + p = (rlon1-rlon2)*pi/180.0 ! angle entre a et b (leurs meridiens) +c + dist = ACOS( COS(pa)*COS(pb) + SIN(pa)*SIN(pb)*COS(p)) + dist = radius * dist + distance(i,j) = dist +c + 9999 CONTINUE +c + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/grid_noro.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/grid_noro.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/grid_noro.F (revision 1280) @@ -0,0 +1,524 @@ +! +! $Header$ +! +c +c + SUBROUTINE grid_noro(imdep, jmdep, xdata, ydata, zdata, + . imar, jmar, x, y, + . zphi,zmea,zstd,zsig,zgam,zthe, + . zpic,zval,mask) +c======================================================================= +c (F. Lott) (voir aussi z.x. Li, A. Harzallah et L. Fairhead) +c +c Compute the Parameters of the SSO scheme as described in +c LOTT & MILLER (1997) and LOTT(1999). +c Target points are on a rectangular grid: +c iim+1 latitudes including North and South Poles; +c jjm+1 longitudes, with periodicity jjm+1=1. +c aux poles. At the poles the fields value is repeated +c jjm+1 time. +c The parameters a,b,c,d represent the limite of the target +c gridpoint region. The means over this region are calculated +c from USN data, ponderated by a weight proportional to the +c surface occupated by the data inside the model gridpoint area. +c In most circumstances, this weight is the ratio between the +c surface of the USN gridpoint area and the surface of the +c model gridpoint area. +c +c (c) +c ----d----- +c | . . . .| +c | | +c (b)a . * . .b(a) +c | | +c | . . . .| +c ----c----- +c (d) +C======================================================================= +c INPUT: +c imdep, jmdep: dimensions X and Y input field +c xdata, ydata: coordinates X and Y input field +c zdata: Input field +c In this version it is assumed that the entry data come from +c the USNavy dataset: imdep=iusn=2160, jmdep=jusn=1080. +c OUTPUT: +c imar, jmar: dimensions X and Y Output field +c x, y: ccordinates X and Y Output field. +c zmea: Mean orographie +c zstd: Standard deviation +c zsig: Slope +c zgam: Anisotropy +c zthe: Orientation of the small axis +c zpic: Maximum altitude +c zval: Minimum altitude +C======================================================================= + + IMPLICIT INTEGER (I,J) + IMPLICIT REAL(X,Z) + + parameter(iusn=2160,jusn=1080,iext=216, epsfra = 1.e-5) +#include "dimensions.h" + REAL xusn(iusn+2*iext),yusn(jusn+2) + REAL zusn(iusn+2*iext,jusn+2) + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL zdata(imdep,jmdep) +c + INTEGER imar, jmar + +C INTERMEDIATE FIELDS (CORRELATIONS OF OROGRAPHY GRADIENT) + + REAL ztz(iim+1,jjm+1),zxtzx(iim+1,jjm+1) + REAL zytzy(iim+1,jjm+1),zxtzy(iim+1,jjm+1) + REAL weight(iim+1,jjm+1) + +C CORRELATIONS OF USN OROGRAPHY GRADIENTS + + REAL zxtzxusn(iusn+2*iext,jusn+2),zytzyusn(iusn+2*iext,jusn+2) + REAL zxtzyusn(iusn+2*iext,jusn+2) + REAL x(imar+1),y(jmar),zphi(imar+1,jmar) + REAL zmea(imar+1,jmar),zstd(imar+1,jmar) + REAL zmea0(imar+1,jmar) ! GK211005 (CG) + REAL zsig(imar+1,jmar),zgam(imar+1,jmar),zthe(imar+1,jmar) + REAL zpic(imar+1,jmar),zval(imar+1,jmar) +cxxx PB integer mask(imar+1,jmar) + real mask(imar+1,jmar), mask_tmp(imar+1,jmar) + real num_tot(2200,1100),num_lan(2200,1100) +c + REAL a(2200),b(2200),c(1100),d(1100) + logical masque_lu +c + print *,' parametres de l orographie a l echelle sous maille' + xpi=acos(-1.) + rad = 6 371 229. + zdeltay=2.*xpi/float(jusn)*rad +c +c utilise-t'on un masque lu? +c + masque_lu = .true. + if (maxval(mask) == -99999 .and. minval(mask) == -99999) then + masque_lu= .false. + masque = 0.0 + endif + write(*,*)'Masque lu', masque_lu +c +c quelques tests de dimensions: +c +c + if(iim.ne.imar) STOP 'Problem dim. x' + if(jjm.ne.jmar-1) STOP 'Problem dim. y' + IF (imar.GT.2200 .OR. jmar.GT.1100) THEN + PRINT*, 'imar or jmar too big', imar, jmar + CALL ABORT + ENDIF + + IF(imdep.ne.iusn.or.jmdep.ne.jusn)then + print *,' imdep or jmdep bad dimensions:',imdep,jmdep + call abort + ENDIF + + IF(imar+1.ne.iim+1.or.jmar.ne.jjm+1)THEN + print *,' imar or jmar bad dimensions:',imar,jmar + call abort + ENDIF + + +c print *,'xdata:',xdata +c print *,'ydata:',ydata +c print *,'x:',x +c print *,'y:',y +c +C EXTENSION OF THE USN DATABASE TO POCEED COMPUTATIONS AT +C BOUNDARIES: +c + DO j=1,jusn + yusn(j+1)=ydata(j) + DO i=1,iusn + zusn(i+iext,j+1)=zdata(i,j) + xusn(i+iext)=xdata(i) + ENDDO + DO i=1,iext + zusn(i,j+1)=zdata(iusn-iext+i,j) + xusn(i)=xdata(iusn-iext+i)-2.*xpi + zusn(iusn+iext+i,j+1)=zdata(i,j) + xusn(iusn+iext+i)=xdata(i)+2.*xpi + ENDDO + ENDDO + + yusn(1)=ydata(1)+(ydata(1)-ydata(2)) + yusn(jusn+2)=ydata(jusn)+(ydata(jusn)-ydata(jusn-1)) + DO i=1,iusn/2+iext + zusn(i,1)=zusn(i+iusn/2,2) + zusn(i+iusn/2+iext,1)=zusn(i,2) + zusn(i,jusn+2)=zusn(i+iusn/2,jusn+1) + zusn(i+iusn/2+iext,jusn+2)=zusn(i,jusn+1) + ENDDO +c +c COMPUTE LIMITS OF MODEL GRIDPOINT AREA +C ( REGULAR GRID) +c + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar+1) = b(imar) + b(imar+1) = x(imar+1) + (x(imar+1)-x(imar))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 +c +c initialisations: +c + DO i = 1, imar+1 + DO j = 1, jmar + weight(i,j) = 0.0 + zxtzx(i,j) = 0.0 + zytzy(i,j) = 0.0 + zxtzy(i,j) = 0.0 + ztz(i,j) = 0.0 + zmea(i,j) = 0.0 + zpic(i,j) =-1.E+10 + zval(i,j) = 1.E+10 + ENDDO + ENDDO +c +c COMPUTE SLOPES CORRELATIONS ON USN GRID +c + DO j = 1,jusn+2 + DO i = 1, iusn+2*iext + zytzyusn(i,j)=0.0 + zxtzxusn(i,j)=0.0 + zxtzyusn(i,j)=0.0 + ENDDO + ENDDO + + + DO j = 2,jusn+1 + zdeltax=zdeltay*cos(yusn(j)) + DO i = 2, iusn+2*iext-1 + zytzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))**2/zdeltay**2 + zxtzxusn(i,j)=(zusn(i+1,j)-zusn(i-1,j))**2/zdeltax**2 + zxtzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))/zdeltay + * *(zusn(i+1,j)-zusn(i-1,j))/zdeltax + ENDDO + ENDDO +c +c SUMMATION OVER GRIDPOINT AREA +c + zleny=xpi/float(jusn)*rad + xincr=xpi/2./float(jusn) + DO ii = 1, imar+1 + DO jj = 1, jmar + num_tot(ii,jj)=0. + num_lan(ii,jj)=0. +c PRINT *,' iteration ii jj:',ii,jj + DO j = 2,jusn+1 +c DO j = 3,jusn + zlenx=zleny*cos(yusn(j)) + zdeltax=zdeltay*cos(yusn(j)) + zbordnor=(c(jj)-yusn(j)+xincr)*rad + zbordsud=(yusn(j)-d(jj)+xincr)*rad + weighy=AMAX1(0., + * amin1(zbordnor,zbordsud,zleny)) + IF(weighy.ne.0)THEN + DO i = 2, iusn+2*iext-1 + zbordest=(xusn(i)-a(ii)+xincr)*rad*cos(yusn(j)) + zbordoue=(b(ii)+xincr-xusn(i))*rad*cos(yusn(j)) + weighx=AMAX1(0., + * amin1(zbordest,zbordoue,zlenx)) + IF(weighx.ne.0)THEN + num_tot(ii,jj)=num_tot(ii,jj)+1.0 + if(zusn(i,j).ge.1.)num_lan(ii,jj)=num_lan(ii,jj)+1.0 + weight(ii,jj)=weight(ii,jj)+weighx*weighy + zxtzx(ii,jj)=zxtzx(ii,jj)+zxtzxusn(i,j)*weighx*weighy + zytzy(ii,jj)=zytzy(ii,jj)+zytzyusn(i,j)*weighx*weighy + zxtzy(ii,jj)=zxtzy(ii,jj)+zxtzyusn(i,j)*weighx*weighy + ztz(ii,jj) =ztz(ii,jj) +zusn(i,j)*zusn(i,j)*weighx*weighy +c mean + zmea(ii,jj) =zmea(ii,jj)+zusn(i,j)*weighx*weighy +c peacks + zpic(ii,jj)=amax1(zpic(ii,jj),zusn(i,j)) +c valleys + zval(ii,jj)=amin1(zval(ii,jj),zusn(i,j)) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c COMPUTE PARAMETERS NEEDED BY THE LOTT & MILLER (1997) AND +C LOTT (1999) SSO SCHEME. +c + zllmmea=0. + zllmstd=0. + zllmsig=0. + zllmgam=0. + zllmpic=0. + zllmval=0. + zllmthe=0. + zminthe=0. +c print 100,' ' +c100 format(1X,A1,'II JJ',4X,'H',8X,'SD',8X,'SI',3X,'GA',3X,'TH') + DO ii = 1, imar+1 + DO jj = 1, jmar + IF (weight(ii,jj) .NE. 0.0) THEN +c Mask +cXXX if(num_lan(ii,jj)/num_tot(ii,jj).ge.0.5)then +cXXX mask(ii,jj)=1 +cXXX else +cXXX mask(ii,jj)=0 +cXXX ENDIF + if (.not. masque_lu) then + mask(ii,jj) = num_lan(ii,jj)/num_tot(ii,jj) + endif +c Mean Orography: + zmea (ii,jj)=zmea (ii,jj)/weight(ii,jj) + zxtzx(ii,jj)=zxtzx(ii,jj)/weight(ii,jj) + zytzy(ii,jj)=zytzy(ii,jj)/weight(ii,jj) + zxtzy(ii,jj)=zxtzy(ii,jj)/weight(ii,jj) + ztz(ii,jj) =ztz(ii,jj)/weight(ii,jj) +c Standard deviation: + zstd(ii,jj)=sqrt(AMAX1(0.,ztz(ii,jj)-zmea(ii,jj)**2)) + ELSE + PRINT*, 'probleme,ii,jj=', ii,jj + ENDIF + ENDDO + ENDDO + +C CORRECT VALUES OF HORIZONTAL SLOPE NEAR THE POLES: + + DO ii = 1, imar+1 + zxtzx(ii,1)=zxtzx(ii,2) + zxtzx(ii,jmar)=zxtzx(ii,jmar-1) + zxtzy(ii,1)=zxtzy(ii,2) + zxtzy(ii,jmar)=zxtzy(ii,jmar-1) + zytzy(ii,1)=zytzy(ii,2) + zytzy(ii,jmar)=zytzy(ii,jmar-1) + ENDDO + +C FILTERS TO SMOOTH OUT FIELDS FOR INPUT INTO SSO SCHEME. + +C FIRST FILTER, MOVING AVERAGE OVER 9 POINTS. + + zmea0(:,:) = zmea(:,:) ! GK211005 (CG) on sauvegarde la topo non lissee + CALL MVA9(zmea,iim+1,jjm+1) + CALL MVA9(zstd,iim+1,jjm+1) + CALL MVA9(zpic,iim+1,jjm+1) + CALL MVA9(zval,iim+1,jjm+1) + CALL MVA9(zxtzx,iim+1,jjm+1) + CALL MVA9(zxtzy,iim+1,jjm+1) + CALL MVA9(zytzy,iim+1,jjm+1) +CXXX Masque prenant en compte maximum de terre +CXXX On seuil a 10% de terre de terre car en dessous les parametres de surface n'on +CXXX pas de sens (PB) + mask_tmp= 0.0 + WHERE(mask .GE. 0.1) mask_tmp = 1. + + DO ii = 1, imar + DO jj = 1, jmar + IF (weight(ii,jj) .NE. 0.0) THEN +c Coefficients K, L et M: + xk=(zxtzx(ii,jj)+zytzy(ii,jj))/2. + xl=(zxtzx(ii,jj)-zytzy(ii,jj))/2. + xm=zxtzy(ii,jj) + xp=xk-sqrt(xl**2+xm**2) + xq=xk+sqrt(xl**2+xm**2) + xw=1.e-8 + if(xp.le.xw) xp=0. + if(xq.le.xw) xq=xw + if(abs(xm).le.xw) xm=xw*sign(1.,xm) +c slope: +cXXX zsig(ii,jj)=sqrt(xq)*mask(ii,jj) +cXXXc isotropy: +cXXX zgam(ii,jj)=xp/xq*mask(ii,jj) +cXXXc angle theta: +cXXX zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask(ii,jj) +cXXX zphi(ii,jj)=zmea(ii,jj)*mask(ii,jj) +cXXX zmea(ii,jj)=zmea(ii,jj)*mask(ii,jj) +cXXX zpic(ii,jj)=zpic(ii,jj)*mask(ii,jj) +cXXX zval(ii,jj)=zval(ii,jj)*mask(ii,jj) +cXXX zstd(ii,jj)=zstd(ii,jj)*mask(ii,jj) +CXX* PB modif pour maque de terre fractionnaire +c slope: + zsig(ii,jj)=sqrt(xq)*mask_tmp(ii,jj) +c isotropy: + zgam(ii,jj)=xp/xq*mask_tmp(ii,jj) +c angle theta: + zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask_tmp(ii,jj) + ! GK211005 (CG) ne pas forcement lisser la topo + ! zphi(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj) + zphi(ii,jj)=zmea0(ii,jj)*mask_tmp(ii,jj) + ! + zmea(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj) + zpic(ii,jj)=zpic(ii,jj)*mask_tmp(ii,jj) + zval(ii,jj)=zval(ii,jj)*mask_tmp(ii,jj) + zstd(ii,jj)=zstd(ii,jj)*mask_tmp(ii,jj) +c print 101,ii,jj, +c * zmea(ii,jj),zstd(ii,jj),zsig(ii,jj),zgam(ii,jj), +c * zthe(ii,jj) +c101 format(1x,2(1x,i2),2(1x,f7.1),1x,f7.4,2x,f4.2,1x,f5.1) + ELSE +c PRINT*, 'probleme,ii,jj=', ii,jj + ENDIF + zllmmea=AMAX1(zmea(ii,jj),zllmmea) + zllmstd=AMAX1(zstd(ii,jj),zllmstd) + zllmsig=AMAX1(zsig(ii,jj),zllmsig) + zllmgam=AMAX1(zgam(ii,jj),zllmgam) + zllmthe=AMAX1(zthe(ii,jj),zllmthe) + zminthe=amin1(zthe(ii,jj),zminthe) + zllmpic=AMAX1(zpic(ii,jj),zllmpic) + zllmval=AMAX1(zval(ii,jj),zllmval) + ENDDO + ENDDO + print *,' MEAN ORO:',zllmmea + print *,' ST. DEV.:',zllmstd + print *,' PENTE:',zllmsig + print *,' ANISOTROP:',zllmgam + print *,' ANGLE:',zminthe,zllmthe + print *,' pic:',zllmpic + print *,' val:',zllmval + +C +c gamma and theta a 1. and 0. at poles +c + DO jj=1,jmar + zmea(imar+1,jj)=zmea(1,jj) + zphi(imar+1,jj)=zphi(1,jj) + zpic(imar+1,jj)=zpic(1,jj) + zval(imar+1,jj)=zval(1,jj) + zstd(imar+1,jj)=zstd(1,jj) + zsig(imar+1,jj)=zsig(1,jj) + zgam(imar+1,jj)=zgam(1,jj) + zthe(imar+1,jj)=zthe(1,jj) + ENDDO + + + zmeanor=0.0 + zmeasud=0.0 + zstdnor=0.0 + zstdsud=0.0 + zsignor=0.0 + zsigsud=0.0 + zweinor=0.0 + zweisud=0.0 + zpicnor=0.0 + zpicsud=0.0 + zvalnor=0.0 + zvalsud=0.0 + + DO ii=1,imar + zweinor=zweinor+ weight(ii, 1) + zweisud=zweisud+ weight(ii,jmar) + zmeanor=zmeanor+zmea(ii, 1)*weight(ii, 1) + zmeasud=zmeasud+zmea(ii,jmar)*weight(ii,jmar) + zstdnor=zstdnor+zstd(ii, 1)*weight(ii, 1) + zstdsud=zstdsud+zstd(ii,jmar)*weight(ii,jmar) + zsignor=zsignor+zsig(ii, 1)*weight(ii, 1) + zsigsud=zsigsud+zsig(ii,jmar)*weight(ii,jmar) + zpicnor=zpicnor+zpic(ii, 1)*weight(ii, 1) + zpicsud=zpicsud+zpic(ii,jmar)*weight(ii,jmar) + zvalnor=zvalnor+zval(ii, 1)*weight(ii, 1) + zvalsud=zvalsud+zval(ii,jmar)*weight(ii,jmar) + ENDDO + + DO ii=1,imar+1 + zmea(ii, 1)=zmeanor/zweinor + zmea(ii,jmar)=zmeasud/zweisud + zphi(ii, 1)=zmeanor/zweinor + zphi(ii,jmar)=zmeasud/zweisud + zpic(ii, 1)=zpicnor/zweinor + zpic(ii,jmar)=zpicsud/zweisud + zval(ii, 1)=zvalnor/zweinor + zval(ii,jmar)=zvalsud/zweisud + zstd(ii, 1)=zstdnor/zweinor + zstd(ii,jmar)=zstdsud/zweisud + zsig(ii, 1)=zsignor/zweinor + zsig(ii,jmar)=zsigsud/zweisud + zgam(ii, 1)=1. + zgam(ii,jmar)=1. + zthe(ii, 1)=0. + zthe(ii,jmar)=0. + ENDDO + + RETURN + END + + SUBROUTINE MVA9(X,IMAR,JMAR) + +C MAKE A MOVING AVERAGE OVER 9 GRIDPOINTS OF THE X FIELDS + + PARAMETER (ISMo=300,JSMo=200) + REAL X(IMAR,JMAR),XF(ISMo,JSMo) + real WEIGHTpb(-1:1,-1:1) + + if(imar.gt.ismo) stop'surdimensionner ismo dans mva9 (grid_noro)' + if(jmar.gt.jsmo) stop'surdimensionner jsmo dans mva9 (grid_noro)' + + SUM=0. + DO IS=-1,1 + DO JS=-1,1 + WEIGHTpb(IS,JS)=1./FLOAT((1+IS**2)*(1+JS**2)) + SUM=SUM+WEIGHTpb(IS,JS) + ENDDO + ENDDO + +c WRITE(*,*) 'MVA9 ', IMAR, JMAR +c WRITE(*,*) 'MVA9 ', WEIGHTpb +c WRITE(*,*) 'MVA9 SUM ', SUM + DO IS=-1,1 + DO JS=-1,1 + WEIGHTpb(IS,JS)=WEIGHTpb(IS,JS)/SUM + ENDDO + ENDDO + + DO J=2,JMAR-1 + DO I=2,IMAR-1 + XF(I,J)=0. + DO IS=-1,1 + DO JS=-1,1 + XF(I,J)=XF(I,J)+X(I+IS,J+JS)*WEIGHTpb(IS,JS) + ENDDO + ENDDO + ENDDO + ENDDO + + DO J=2,JMAR-1 + XF(1,J)=0. + IS=IMAR-1 + DO JS=-1,1 + XF(1,J)=XF(1,J)+X(IS,J+JS)*WEIGHTpb(-1,JS) + ENDDO + DO IS=0,1 + DO JS=-1,1 + XF(1,J)=XF(1,J)+X(1+IS,J+JS)*WEIGHTpb(IS,JS) + ENDDO + ENDDO + XF(IMAR,J)=XF(1,J) + ENDDO + + DO I=1,IMAR + XF(I,1)=XF(I,2) + XF(I,JMAR)=XF(I,JMAR-1) + ENDDO + + DO I=1,IMAR + DO J=1,JMAR + X(I,J)=XF(I,J) + ENDDO + ENDDO + + RETURN + END + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/grilles_gcm_netcdf.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/grilles_gcm_netcdf.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/grilles_gcm_netcdf.F (revision 1280) @@ -0,0 +1,305 @@ +! +! $Header$ +! +c +c + + PROGRAM create_fausse_var +C + IMPLICIT NONE +C +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" + + real temp(iim+1,jjm+1) +#include "netcdf.inc" + +c Attributs netcdf sortie + character*64 fich_out + integer*4 ncid_out,rcode_out + integer*4 out_lonuid,out_lonvid,out_latuid,out_latvid + integer*4 out_varid + integer*4 out_lonudim,out_lonvdim + integer*4 out_latudim,out_latvdim,out_dim(3) + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + + integer start(4),count(4) + + integer status,i,j + real rlatudeg(jjp1),rlatvdeg(jjm) + real rlonudeg(iip1),rlonvdeg(iip1) + + real dlon1(iip1),dlon2(iip1),dlat1(jjp1),dlat2(jjp1) + real acoslat,dxkm,dykm,resol(iip1,jjp1) + +#include "serre.h" +#include "fxyprim.h" + + print*,'OK0' + + rad = 6400000 + omeg = 7.272205e-05 + g = 9.8 + kappa = 0.285716 + daysec = 86400 + cpp = 1004.70885 + + preff = 101325. + pa= 50000. + +c open(99,file='run.def',status='old',form='formatted') +c CALL defrun_new( 99, .TRUE.,clesphy0 ) +c close(99) + + CALL conf_gcm( 99, .TRUE. , clesphy0 ) + CALL iniconst + CALL inigeom + + + print*,'OK1' + do j=1,jjp1 + rlatudeg(j)=rlatu(j)*180./pi + enddo + do j=1,jjm + rlatvdeg(j)=rlatv(j)*180./pi + enddo + + do i=1,iip1 + rlonudeg(i)=rlonu(i)*180./pi + 360. + rlonvdeg(i)=rlonv(i)*180./pi + 360. + enddo + + + print*,'OK2' +c 2 ----- OUVERTURE DE LA SORTIE NETCDF +c --------------------------------------------------- +c CREATION OUTPUT +c ouverture fichier netcdf de sortie out + fich_out='grilles_gcm.nc' + + status=NF_CREATE(fich_out,NF_NOCLOBBER,ncid_out) + status=NF_DEF_DIM(ncid_out,'lonu',iim+1,out_lonudim) + status=NF_DEF_DIM(ncid_out,'lonv',iim+1,out_lonvdim) + status=NF_DEF_DIM(ncid_out,'latu',jjm+1,out_latudim) + status=NF_DEF_DIM(ncid_out,'latv',jjm,out_latvdim) + + + print*,'OK3' +c Longitudes en u + print *,'OUTID: ',ncid_out + status=NF_DEF_VAR(ncid_out,'lonu',NF_FLOAT,1,out_lonudim, + % out_lonuid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'units', + % 12,'degrees_east') + status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'long_name', + % 9,'Longitude en u') + +c Longitudes en v + print *,'OUTID: ',ncid_out + status=NF_DEF_VAR(ncid_out,'lonv',NF_FLOAT,1,out_lonvdim, + % out_lonvid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'units', + % 12,'degrees_east') + status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'long_name', + % 9,'Longitude en v') + +c Latitude en u + status=NF_DEF_VAR(ncid_out,'latu',NF_FLOAT,1,out_latudim, + % out_latuid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'units', + % 13,'degrees_north') + status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'long_name', + % 8,'Latitude en u') + +c Latitude en v + status=NF_DEF_VAR(ncid_out,'latv',NF_FLOAT,1,out_latvdim, + % out_latvid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'units', + % 13,'degrees_north') + status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'long_name', + % 8,'Latitude en v') + +c ecriture de la grille u + out_dim(1)=out_lonudim + out_dim(2)=out_latudim + status=NF_DEF_VAR(ncid_out,'grille_u',NF_FLOAT,2,out_dim, + % out_varid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', + % 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', + % 16,'Grille aux point u') + +c ecriture de la grille v + out_dim(1)=out_lonvdim + out_dim(2)=out_latvdim + status=NF_DEF_VAR(ncid_out,'grille_v',NF_FLOAT,2,out_dim, + % out_varid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', + % 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', + % 16,'Grille aux point v') + +c ecriture de la grille u + out_dim(1)=out_lonvdim + out_dim(2)=out_latudim + status=NF_DEF_VAR(ncid_out,'grille_s',NF_FLOAT,2,out_dim, + % out_varid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', + % 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', + % 16,'Grille aux point u') + + + print*,'OK4' + status=NF_ENDDEF(ncid_out) +c 5) ----- FERMETURE DES FICHIERS NETCDF------------------ +c -------------------------------------------------------- +c 3-b- Ecriture de la grille pour la sortie +c rajoute l'ecriture de la grille + +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonuid,1,iim+1,rlonudeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonvid,1,iim+1,rlonvdeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_latuid,1,jjm+1,rlatudeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_latvid,1,jjm,rlatvdeg) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_lonuid,1,iim+1,rlonudeg) + status=NF_PUT_VARA_REAL(ncid_out,out_lonvid,1,iim+1,rlonvdeg) + status=NF_PUT_VARA_REAL(ncid_out,out_latuid,1,jjm+1,rlatudeg) + status=NF_PUT_VARA_REAL(ncid_out,out_latvid,1,jjm,rlatvdeg) +#endif + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=1 + + count(1)=iim+1 + count(2)=jjm+1 + count(3)=1 + count(4)=1 + + do j=1,jjm+1 + do i=1,iim+1 + temp(i,j)=mod(i,2)+mod(j,2) + enddo + enddo + +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_varid,start, + s count,temp) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_varid,start, + s count,temp) +#endif + + +c fermeture du fichier netcdf + call ncclos(ncid_out,rcode_out) + write(*,*) 'Fermeture: ',fich_out + + + print*,'OK5' +c Ecriture grads + open (20,file='grille.dat',form='unformatted',access='direct' + s ,recl=4*ip1jmp1) + write(20,rec=1) ((float(mod(i,2)+mod(j,2)),i=1,iip1),j=1,jjp1) + write(20,rec=2) ((float(mod(i,2)*mod(j,2)),i=1,iip1),j=1,jjp1) + do j=2,jjm + dlat1(j)=180.*(rlatv(j)-rlatv(j-1))/pi +c dlat2(j)=180.*fyprim(float(j))/pi + enddo + do i=2,iip1 + dlon1(i)=180.*(rlonu(i)-rlonu(i-1))/pi +c dlon2(i)=180.*fxprim(float(i))/pi + enddo + do j=2,jjm + dykm=(rlatv(j)-rlatv(j-1))*6400. + acoslat=6400.*cos(rlatu(j)) + do i=2,iip1 + dxkm=acoslat*(rlonu(i)-rlonu(i-1)) + resol(i,j)=sqrt(dykm*dykm+dxkm*dxkm) + enddo + resol(1,j)=resol(iip1,j) + enddo + write(20,rec=3) resol + dlon1(1)=dlon1(iip1) + dlon2(1)=dlon2(iip1) + write(20,rec=4) ((dlon1(i),i=1,iip1),j=1,jjp1) + write(20,rec=5) ((dlon1(i)*pi/180.*0.001* + s cos(rlatu(j))*rad,i=1,iip1),j=1,jjp1) + write(20,rec=6) ((dlon2(i),i=1,iip1),j=1,jjp1) + write(20,rec=7) ((dlat1(j),i=1,iip1),j=1,jjp1) + write(20,rec=8) ((dlat1(j)*pi/180.*rad*0.001,i=1,iip1),j=1,jjp1) + write(20,rec=9) ((dlat2(j),i=1,iip1),j=1,jjp1) + + print*,'I, LON, DX (km)' + do i=1,iip1 + print*,i,rlonu(i)*180./pi,dlon1(i)*pi/180.*0.001* + s cos(clat*pi/180.)*rad + enddo + print*,'J, LAT, DY (km)' + do j=1,jjp1 + print*,j,rlatu(j)*180./pi,dlat1(j)*pi/180.*0.001*rad + enddo + + open (21,file='grille.ctl',form='formatted') + +c WARNING! on reecrase le fichier .ctl a chaque ecriture + write(21,'(a5,1x,a40)') + & 'DSET ','^grille.dat' + + write(21,'(a12)') 'UNDEF 1.0E30' + write(21,'(a5,1x,a40)') 'TITLE ','grille' + call formcoord(21,iip1,rlonv,180./pi,.false.,'XDEF') + call formcoord(21,jjp1,rlatu,180./pi,.true.,'YDEF') + call formcoord(21,1,0.,1.,.false.,'ZDEF') + write(21,'(a4,i10,a30)') + & 'TDEF ',1,' LINEAR 23OCT1994 3hr ' + write(21,'(a4,2x,i5)') 'VARS',9 + write(21,'(a18)') 'grille 0 99 grille' + write(21,'(a18)') 'gril 0 99 gril ' + write(21,'(a29)') 'resol 0 99 resolution (km) ' + write(21,'(a18)') 'dlon1 0 99 dlon1 ' + write(21,'(a20)') 'dx 0 99 dx (km) ' + write(21,'(a18)') 'dlon2 0 99 dlon2 ' + write(21,'(a18)') 'dlat1 0 99 dlat1 ' + write(21,'(a20)') 'dy 0 99 dy (km) ' + write(21,'(a18)') 'dlat2 0 99 dlat2 ' + write(21,'(a7)') 'ENDVARS' + + + + + + print*,'OK6' + end + + + + subroutine handle_err(status) +#include "netcdf.inc" + + + integer status + print *,'handle code err: ',NF_NOERR + IF (status.NE.nf_noerr) THEN + print *,NF_STRERROR(status) + stop 'stopped' + ENDIF + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/groupe_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/groupe_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/groupe_p.F (revision 1280) @@ -0,0 +1,130 @@ + subroutine groupe_p(pext,pbaru,pbarv,pbarum,pbarvm,wm) + USE parallel + implicit none + +c sous-programme servant a fitlrer les champs de flux de masse aux +c poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur +c et a mesure qu'on se rapproche du pole. +c +c en entree: pext, pbaru et pbarv +c +c en sortie: pbarum,pbarvm et wm. +c +c remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc +c pas besoin de w en entree. + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" +#include "comvert.h" + + integer ngroup + parameter (ngroup=3) + + + real pbaru(iip1,jjp1,llm),pbarv(iip1,jjm,llm) + real pext(iip1,jjp1,llm) + + real pbarum(iip1,jjp1,llm),pbarvm(iip1,jjm,llm) + real wm(iip1,jjp1,llm) + + real,save :: zconvm(iip1,jjp1,llm) + real,save :: zconvmm(iip1,jjp1,llm) + + real uu + + integer i,j,l + + logical firstcall + save firstcall +c$OMP THREADPRIVATE(firstcall) + + data firstcall/.true./ + integer ijb,ije,jjb,jje + + if (firstcall) then + if(mod(iim,2**ngroup).ne.0) stop'probleme du nombre ede point' + firstcall=.false. + endif + +c Champs 1D + + call convflu_p(pbaru,pbarv,llm,zconvm) + +c +c call scopy(ijp1llm,zconvm,1,zconvmm,1) +c call scopy(ijmllm,pbarv,1,pbarvm,1) + + jjb=jj_begin + jje=jj_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + zconvmm(:,jjb:jje,l)=zconvm(:,jjb:jje,l) + enddo +c$OMP END DO NOWAIT + + call groupeun_p(jjp1,llm,jjb,jje,zconvmm) + + jjb=jj_begin-1 + jje=jj_end + if (pole_nord) jjb=jj_begin + if (pole_sud) jje=jj_end-1 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + pbarvm(:,jjb:jje,l)=pbarv(:,jjb:jje,l) + enddo +c$OMP END DO NOWAIT + + call groupeun_p(jjm,llm,jjb,jje,pbarvm) + +c Champs 3D + + jjb=jj_begin + jje=jj_end + if (pole_nord) jjb=jj_begin+1 + if (pole_sud) jje=jj_end-1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + uu=pbaru(iim,j,l) + do i=1,iim + uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l) + pbarum(i,j,l)=uu +c zconvm(i,j,l ) = xflu(i-1,j,l)-xflu(i,j,l)+ +c * yflu(i,j,l)-yflu(i,j-1,l) + enddo + pbarum(iip1,j,l)=pbarum(1,j,l) + enddo + enddo +c$OMP END DO NOWAIT +c integration de la convergence de masse de haut en bas ...... + + jjb=jj_begin + jje=jj_end + +c$OMP BARRIER +c$OMP MASTER + do l = llm-1,1,-1 + do j=jjb,jje + do i=1,iip1 + zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1) + enddo + enddo + enddo + + if (.not. pole_sud) then + zconvmm(:,jj_end+1,:)=0 +cym wm(:,jj_end+1,:)=0 + endif + +c$OMP END MASTER +c$OMP BARRIER + + CALL vitvert_p(zconvmm(1,1,1),wm(1,1,1)) + + return + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/groupeun_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/groupeun_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/groupeun_p.F (revision 1280) @@ -0,0 +1,201 @@ + SUBROUTINE groupeun_p(jjmax,llmax,jjb,jje,q) + USE parallel + USE Write_Field_p + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" + + INTEGER jjmax,llmax,jjb,jje + REAL q(iip1,jjmax,llmax) + + INTEGER ngroup + PARAMETER (ngroup=3) + + REAL airecn,qn + REAL airecs,qs + + INTEGER i,j,l,ig,ig2,j1,j2,i0,jd + +c--------------------------------------------------------------------c +c Strategie d'optimisation c +c stocker les valeurs systematiquement recalculees c +c et identiques d'un pas de temps sur l'autre. Il s'agit des c +c aires des cellules qui sont sommees. S'il n'y a pas de changement c +c de grille au cours de la simulation tout devrait bien se passer. c +c Autre optimisation : determination des bornes entre lesquelles "j" c +c varie, au lieu de faire un test à chaque fois... +c--------------------------------------------------------------------c + + INTEGER j_start, j_finish + + REAL, SAVE :: airen_tab(iip1,jjp1,0:1) + REAL, SAVE :: aires_tab(iip1,jjp1,0:1) +!$OMP THREADPRIVATE(airen_tab, aires_tab) + + LOGICAL, SAVE :: first = .TRUE. +!$OMP THREADPRIVATE(first) + INTEGER,SAVE :: i_index(iim,ngroup) + INTEGER :: offset + REAL :: qsum(iim/ngroup) + + IF (first) THEN + CALL INIT_GROUPEUN_P(airen_tab, aires_tab) + first = .FALSE. + ENDIF + +c Champs 3D + jd=jjp1-jjmax +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + j1=1+jd + j2=2 + DO ig=1,ngroup + +c Concerne le pole nord + j_start = MAX(jjb, j1-jd) + j_finish = MIN(jje, j2-jd) + DO ig2=1,ngroup-ig+1 + offset=2**(ig2-1) + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i0=1,iim,2**ig2 + q(i0,j,l)=q(i0,j,l)+q(i0+offset,j,l) + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i=1,iim + q(i,j,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),j,l) + ENDDO + ENDDO + + DO j=j_start, j_finish +!CDIR ON_ADB(airen_tab) +!CDIR ON_ADB(q) + DO i=1,iim + q(i,j,l)=q(i,j,l)*airen_tab(i,j,jd) + ENDDO + q(iip1,j,l)=q(1,j,l) + ENDDO + +!c Concerne le pole sud + j_start = MAX(1+jjp1-jje-jd, j1-jd) + j_finish = MIN(1+jjp1-jjb-jd, j2-jd) + DO ig2=1,ngroup-ig+1 + offset=2**(ig2-1) + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i0=1,iim,2**ig2 + q(i0,jjp1-j+1-jd,l)= q(i0,jjp1-j+1-jd,l) + & +q(i0+offset,jjp1-j+1-jd,l) + ENDDO + ENDDO + ENDDO + + + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i=1,iim + q(i,jjp1-j+1-jd,l)=q(i-MOD(i-1,2**(ngroup-ig+1)), + & jjp1-j+1-jd,l) + ENDDO + ENDDO + + DO j=j_start, j_finish +!CDIR ON_ADB(aires_tab) +!CDIR ON_ADB(q) + DO i=1,iim + q(i,jjp1-j+1-jd,l)=q(i,jjp1-j+1-jd,l)* + & aires_tab(i,jjp1-j+1,jd) + ENDDO + q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l) + ENDDO + + + j1=j2+1 + j2=j2+2**ig + ENDDO + ENDDO +!$OMP END DO NOWAIT + + RETURN + END + + + + SUBROUTINE INIT_GROUPEUN_P(airen_tab, aires_tab) + + USE parallel + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" + + INTEGER ngroup + PARAMETER (ngroup=3) + + REAL airen,airecn + REAL aires,airecs + + INTEGER i,j,l,ig,j1,j2,i0,jd + + INTEGER j_start, j_finish + + REAL :: airen_tab(iip1,jjp1,0:1) + REAL :: aires_tab(iip1,jjp1,0:1) + + DO jd=0, 1 + j1=1+jd + j2=2 + DO ig=1,ngroup + +! c Concerne le pole nord + j_start = j1-jd + j_finish = j2-jd + DO j=j_start, j_finish + DO i0=1,iim,2**(ngroup-ig+1) + airen=0. + DO i=i0,i0+2**(ngroup-ig+1)-1 + airen = airen+aire(i,j) + ENDDO + DO i=i0,i0+2**(ngroup-ig+1)-1 + airen_tab(i,j,jd) = + & aire(i,j) / airen + ENDDO + ENDDO + ENDDO + +! c Concerne le pole sud + j_start = j1-jd + j_finish = j2-jd + DO j=j_start, j_finish + DO i0=1,iim,2**(ngroup-ig+1) + aires=0. + DO i=i0,i0+2**(ngroup-ig+1)-1 + aires=aires+aire(i,jjp1-j+1) + ENDDO + DO i=i0,i0+2**(ngroup-ig+1)-1 + aires_tab(i,jjp1-j+1,jd) = + & aire(i,jjp1-j+1) / aires + ENDDO + ENDDO + ENDDO + + j1=j2+1 + j2=j2+2**ig + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/guide_p_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/guide_p_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/guide_p_mod.F90 (revision 1280) @@ -0,0 +1,1630 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/guide.F,v 1.3.4.1 2006/11/06 15:51:16 fairhead Exp $ +! +MODULE guide_p_mod + +!======================================================================= +! Auteur: F.Hourdin +! F. Codron 01/09 +!======================================================================= + + USE getparam + USE Write_Field_p + use netcdf, only: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close + + IMPLICIT NONE + +! --------------------------------------------- +! Declarations des cles logiques et parametres +! --------------------------------------------- + INTEGER, PRIVATE, SAVE :: iguide_read,iguide_int,iguide_sav + INTEGER, PRIVATE, SAVE :: nlevnc + LOGICAL, PRIVATE, SAVE :: guide_u,guide_v,guide_T,guide_Q,guide_P + LOGICAL, PRIVATE, SAVE :: guide_hr,guide_teta + LOGICAL, PRIVATE, SAVE :: guide_BL,guide_reg,guide_add,gamma4,guide_zon + LOGICAL, PRIVATE, SAVE :: guide_modele,invert_p,invert_y,ini_anal + LOGICAL, PRIVATE, SAVE :: guide_2D,guide_sav + + REAL, PRIVATE, SAVE :: tau_min_u,tau_max_u + REAL, PRIVATE, SAVE :: tau_min_v,tau_max_v + REAL, PRIVATE, SAVE :: tau_min_T,tau_max_T + REAL, PRIVATE, SAVE :: tau_min_Q,tau_max_Q + REAL, PRIVATE, SAVE :: tau_min_P,tau_max_P + + REAL, PRIVATE, SAVE :: lat_min_g,lat_max_g + REAL, PRIVATE, SAVE :: lon_min_g,lon_max_g + REAL, PRIVATE, SAVE :: tau_lon,tau_lat + + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_u,alpha_v + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_T,alpha_Q + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_P,alpha_pcor + +! --------------------------------------------- +! Variables de guidage +! --------------------------------------------- +! Variables des fichiers de guidage + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: unat1,unat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: vnat1,vnat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: tnat1,tnat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: qnat1,qnat2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: psnat1,psnat2 + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: apnc,bpnc +! Variables aux dimensions du modele + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: ugui1,ugui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: vgui1,vgui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: tgui1,tgui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: qgui1,qgui2 + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: psgui1,psgui2 + + INTEGER,SAVE,PRIVATE :: ijb_u,ijb_v,ije_u,ije_v,ijn_u,ijn_v + INTEGER,SAVE,PRIVATE :: jjb_u,jjb_v,jje_u,jje_v,jjn_u,jjn_v + + +CONTAINS +!======================================================================= + + SUBROUTINE guide_init + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "netcdf.inc" + INCLUDE "control.h" + + INTEGER :: error,ncidpl,rid,rcod + CHARACTER (len = 80) :: abort_message + CHARACTER (len = 20) :: modname = 'guide_init' + +! --------------------------------------------- +! Lecture des parametres: +! --------------------------------------------- +! Variables guidees + CALL getpar('guide_u',.true.,guide_u,'guidage de u') + CALL getpar('guide_v',.true.,guide_v,'guidage de v') + CALL getpar('guide_T',.true.,guide_T,'guidage de T') + CALL getpar('guide_P',.true.,guide_P,'guidage de P') + CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q') + CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R') + CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta') + + CALL getpar('guide_add',.false.,guide_add,'for�age constant?') + CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale') + +! Constantes de rappel. Unite : fraction de jour + CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u') + CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u') + CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v') + CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v') + CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T') + CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T') + CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q') + CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q') + CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P') + CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P') + CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie') + CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim') + +! Sauvegarde du for�age + CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage') + CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage') + ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois. + IF (iguide_sav.GT.0) THEN + iguide_sav=day_step/iguide_sav + ELSE + iguide_sav=day_step*iguide_sav + ENDIF + +! Guidage regional seulement (sinon constant ou suivant le zoom) + CALL getpar('guide_reg',.false.,guide_reg,'guidage regional') + CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ') + CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ') + CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ') + CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ') + CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ') + CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ') + +! Parametres pour lecture des fichiers + CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage') + CALL getpar('iguide_int',4,iguide_int,'freq. lecture guidage') + IF (iguide_int.GT.0) THEN + iguide_int=day_step/iguide_int + ELSE + iguide_int=day_step*iguide_int + ENDIF + CALL getpar('guide_modele',.false.,guide_modele,'guidage niveaux modele') + CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse') + CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses') + CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S') + CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P') + +! --------------------------------------------- +! Determination du nombre de niveaux verticaux +! des fichiers guidage +! --------------------------------------------- + ncidpl=-99 + if (guide_modele) then + if (ncidpl.eq.-99) rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl) + else + if (guide_u) then + if (ncidpl.eq.-99) rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl) + elseif (guide_v) then + if (ncidpl.eq.-99) rcod=nf90_open('v.nc',nf90_nowrite,ncidpl) + elseif (guide_T) then + if (ncidpl.eq.-99) rcod=nf90_open('T.nc',nf90_nowrite,ncidpl) + elseif (guide_Q) then + if (ncidpl.eq.-99) rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl) + endif + endif + error=NF_INQ_DIMID(ncidpl,'LEVEL',rid) + IF (error.NE.NF_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid) + IF (error.NE.NF_NOERR) THEN + print *,'Guide: probleme lecture niveaux pression' + CALL abort_gcm(modname,abort_message,1) + ENDIF + error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc) + print *,'Guide: nombre niveaux vert. nlevnc', nlevnc + rcod = nf90_close(ncidpl) + +! --------------------------------------------- +! Allocation des variables +! --------------------------------------------- + abort_message='pb in allocation guide' + + ALLOCATE(apnc(nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(bpnc(nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + apnc=0.;bpnc=0. + + ALLOCATE(alpha_pcor(llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_u(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_v(ip1jm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_T(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_Q(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_P(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0 + + IF (guide_u) THEN + ALLOCATE(unat1(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(ugui1(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(unat2(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(ugui2(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + unat1=0.;unat2=0.;ugui1=0.;ugui2=0. + ENDIF + + IF (guide_T) THEN + ALLOCATE(tnat1(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tgui1(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tnat2(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tgui2(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0. + ENDIF + + IF (guide_Q) THEN + ALLOCATE(qnat1(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qgui1(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qnat2(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qgui2(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0. + ENDIF + + IF (guide_v) THEN + ALLOCATE(vnat1(iip1,jjm,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vgui1(ip1jm,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vnat2(iip1,jjm,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vgui2(ip1jm,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0. + ENDIF + + IF (guide_P.OR.guide_modele) THEN + ALLOCATE(psnat1(iip1,jjp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(psnat2(iip1,jjp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + psnat1=0.;psnat2=0.; + ENDIF + IF (guide_P) THEN + ALLOCATE(psgui2(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(psgui1(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + psgui1=0.;psgui2=0. + ENDIF + +! --------------------------------------------- +! Lecture du premier etat de guidage. +! --------------------------------------------- + IF (guide_2D) THEN + CALL guide_read2D(1) + ELSE + CALL guide_read(1) + ENDIF + IF (guide_v) vnat1=vnat2 + IF (guide_u) unat1=unat2 + IF (guide_T) tnat1=tnat2 + IF (guide_Q) qnat1=qnat2 + IF (guide_P.OR.guide_modele) psnat1=psnat2 + + END SUBROUTINE guide_init + +!======================================================================= + SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps) + use parallel + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "control.h" + INCLUDE "comconst.h" + INCLUDE "comvert.h" + + ! Variables entree + INTEGER, INTENT(IN) :: itau !pas de temps + REAL, DIMENSION (ip1jmp1,llm), INTENT(INOUT) :: ucov,teta,q,masse + REAL, DIMENSION (ip1jm,llm), INTENT(INOUT) :: vcov + REAL, DIMENSION (ip1jmp1), INTENT(INOUT) :: ps + + ! Variables locales + LOGICAL, SAVE :: first=.TRUE. + LOGICAL :: f_out ! sortie guidage + REAL, DIMENSION (ip1jmp1,llm) :: f_add ! var aux: champ de guidage + REAL, DIMENSION (ip1jmp1,llm) :: p ! besoin si guide_P + ! Compteurs temps: + INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage + REAL :: ditau, dday_step + REAL :: tau,reste ! position entre 2 etats de guidage + REAL, SAVE :: factt ! pas de temps en fraction de jour + + INTEGER :: l + + ijb_u=ij_begin ; ije_u=ij_end ; ijn_u=ije_u-ijb_u+1 + jjb_u=jj_begin ; jje_u=jj_end ; jjn_u=jje_u-jjb_u+1 + ijb_v=ij_begin ; ije_v=ij_end ; ijn_v=ije_v-ijb_v+1 + jjb_v=jj_begin ; jje_v=jj_end ; jjn_v=jje_v-jjb_v+1 + IF (pole_sud) THEN + ije_v=ij_end-iip1 + jje_v=jj_end-1 + ijn_v=ije_v-ijb_v+1 + jjn_v=jje_v-jjb_v+1 + ENDIF + + + + PRINT *,'---> on rentre dans guide_main' +! CALL AllGather_Field(ucov,ip1jmp1,llm) +! CALL AllGather_Field(vcov,ip1jm,llm) +! CALL AllGather_Field(teta,ip1jmp1,llm) +! CALL AllGather_Field(ps,ip1jmp1,1) +! CALL AllGather_Field(q,ip1jmp1,llm) + +!----------------------------------------------------------------------- +! Initialisations au premier passage +!----------------------------------------------------------------------- + + IF (first) THEN + first=.FALSE. + CALL guide_init + itau_test=1001 + step_rea=1 + count_no_rea=0 +! Calcul des constantes de rappel + factt=dtvr*iperiod/daysec + call tau2alpha(3,iip1,jjm ,factt,tau_min_v,tau_max_v,alpha_v) + call tau2alpha(2,iip1,jjp1,factt,tau_min_u,tau_max_u,alpha_u) + call tau2alpha(1,iip1,jjp1,factt,tau_min_T,tau_max_T,alpha_T) + call tau2alpha(1,iip1,jjp1,factt,tau_min_P,tau_max_P,alpha_P) + call tau2alpha(1,iip1,jjp1,factt,tau_min_Q,tau_max_Q,alpha_Q) +! correction de rappel dans couche limite + if (guide_BL) then + alpha_pcor(:)=1. + else + do l=1,llm + alpha_pcor(l)=(1.+tanh((0.85-presnivs(l)/preff)/0.05))/2. + enddo + endif +! ini_anal: etat initial egal au guidage + IF (ini_anal) THEN + CALL guide_interp(ps,teta) + IF (guide_u) ucov(ijb_u:ije_u,:)=ugui2(ijb_u:ije_u,:) + IF (guide_v) vcov(ijb_v:ije_v,:)=ugui2(ijb_v:ije_v,:) + IF (guide_T) teta(ijb_u:ije_u,:)=tgui2(ijb_u:ije_u,:) + IF (guide_Q) q(ijb_u:ije_u,:)=qgui2(ijb_u:ije_u,:) + IF (guide_P) THEN + ps(ijb_u:ije_u)=psgui2(ijb_u:ije_u) + CALL pression_p(ip1jmp1,ap,bp,ps,p) + CALL massdair_p(p,masse) + ENDIF + RETURN + ENDIF +! Verification structure guidage + IF (guide_u) THEN + CALL writefield_p('unat',unat1) + CALL writefield_p('ucov',RESHAPE(ucov,(/iip1,jjp1,llm/))) + ENDIF + IF (guide_T) THEN + CALL writefield_p('tnat',tnat1) + CALL writefield_p('teta',RESHAPE(teta,(/iip1,jjp1,llm/))) + ENDIF + + ENDIF !first + +!----------------------------------------------------------------------- +! Lecture des fichiers de guidage ? +!----------------------------------------------------------------------- + IF (iguide_read.NE.0) THEN + ditau=real(itau) + dday_step=real(day_step) + IF (iguide_read.LT.0) THEN + tau=ditau/dday_step/FLOAT(iguide_read) + ELSE + tau=FLOAT(iguide_read)*ditau/dday_step + ENDIF + reste=tau-AINT(tau) + IF (reste.EQ.0.) THEN + IF (itau_test.EQ.itau) THEN + write(*,*)'deuxieme passage de advreel a itau=',itau + stop + ELSE + IF (guide_v) vnat1(jjb_v:jje_v,:,:)=vnat2(jjb_v:jje_v,:,:) + IF (guide_u) unat1(jjb_u:jje_u,:,:)=unat2(jjb_u:jje_u,:,:) + IF (guide_T) tnat1(jjb_u:jje_u,:,:)=tnat2(jjb_u:jje_u,:,:) + IF (guide_Q) qnat1(jjb_u:jje_u,:,:)=qnat2(jjb_u:jje_u,:,:) + IF (guide_P.OR.guide_modele) psnat1(jjb_u:jje_u,:)=psnat2(jjb_u:jje_u,:) + step_rea=step_rea+1 + itau_test=itau + print*,'Lecture fichiers guidage, pas ',step_rea, & + 'apres ',count_no_rea,' non lectures' + IF (guide_2D) THEN + CALL guide_read2D(step_rea) + ELSE + CALL guide_read(step_rea) + ENDIF + count_no_rea=0 + ENDIF + ELSE + count_no_rea=count_no_rea+1 + + ENDIF + ENDIF !iguide_read=0 + +!----------------------------------------------------------------------- +! Interpolation et conversion des champs de guidage +!----------------------------------------------------------------------- + IF (MOD(itau,iguide_int).EQ.0) THEN + CALL guide_interp(ps,teta) + ENDIF +! Repartition entre 2 etats de guidage + IF (iguide_read.NE.0) THEN + tau=reste + ELSE + tau=1. + ENDIF + +!----------------------------------------------------------------------- +! Ajout des champs de guidage +!----------------------------------------------------------------------- +! Sauvegarde du guidage? + f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav) + IF (f_out) CALL guide_out("S",jjp1,1,ps) + + if (guide_u) then + if (guide_add) then + f_add(ijb_u:ije_u,:)=(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:) + else + f_add(ijb_u:ije_u,:)=(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:)-ucov(ijb_u:ije_u,:) + endif + + if (guide_zon) CALL guide_zonave(1,jjp1,llm,f_add) + CALL guide_addfield(ip1jmp1,llm,f_add,alpha_u) + IF (f_out) CALL guide_out("U",jjp1,llm,f_add/factt) + ucov(ijb_u:ije_u,:)=ucov(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:) + endif + + if (guide_T) then + if (guide_add) then + f_add(ijb_u:ije_u,:)=(1.-tau)*tgui1(ijb_u:ije_u,:)+tau*tgui2(ijb_u:ije_u,:) + else + f_add(ijb_u:ije_u,:)=(1.-tau)*tgui1(ijb_u:ije_u,:)+tau*tgui2(ijb_u:ije_u,:)-teta(ijb_u:ije_u,:) + endif + if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add) + CALL guide_addfield(ip1jmp1,llm,f_add,alpha_T) + IF (f_out) CALL guide_out("T",jjp1,llm,f_add/factt) + teta(ijb_u:ije_u,:)=teta(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:) + endif + + if (guide_P) then + if (guide_add) then + f_add(ijb_u:ije_u,1)=(1.-tau)*psgui1(ijb_u:ije_u)+tau*psgui2(ijb_u:ije_u) + else + f_add(ijb_u:ije_u,1)=(1.-tau)*psgui1(ijb_u:ije_u)+tau*psgui2(ijb_u:ije_u)-ps(ijb_u:ije_u) + endif + if (guide_zon) CALL guide_zonave(2,jjp1,1,f_add(1:ip1jmp1,1)) + CALL guide_addfield(ip1jmp1,1,f_add(1:ip1jmp1,1),alpha_P) + IF (f_out) CALL guide_out("P",jjp1,1,f_add(1:ip1jmp1,1)/factt) + ps(ijb_u:ije_u)=ps(ijb_u:ije_u)+f_add(ijb_u:ije_u,1) + CALL pression_p(ip1jmp1,ap,bp,ps,p) + CALL massdair_p(p,masse) + endif + + if (guide_Q) then + if (guide_add) then + f_add(ijb_u:ije_u,:)=(1.-tau)*qgui1(ijb_u:ije_u,:)+tau*qgui2(ijb_u:ije_u,:) + else + f_add(ijb_u:ije_u,:)=(1.-tau)*qgui1(ijb_u:ije_u,:)+tau*qgui2(ijb_u:ije_u,:)-q(ijb_u:ije_u,:) + endif + if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add) + CALL guide_addfield(ip1jmp1,llm,f_add,alpha_Q) + IF (f_out) CALL guide_out("Q",jjp1,llm,f_add/factt) + q(ijb_u:ije_u,:)=q(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:) + endif + + if (guide_v) then + if (guide_add) then + f_add(ijb_v:ije_v,:)=(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:) + else + f_add(ijb_v:ije_v,:)=(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:)-vcov(ijb_v:ije_v,:) + endif + + if (guide_zon) CALL guide_zonave(2,jjm,llm,f_add(1:ip1jm,:)) + CALL guide_addfield(ip1jm,llm,f_add(1:ip1jm,:),alpha_v) + IF (f_out) CALL guide_out("V",jjm,llm,f_add(1:ip1jm,:)/factt) + vcov(ijb_v:ije_v,:)=vcov(ijb_v:ije_v,:)+f_add(ijb_v:ije_v,:) + endif + + END SUBROUTINE guide_main + +!======================================================================= + SUBROUTINE guide_addfield(hsize,vsize,field,alpha) +! field1=a*field1+alpha*field2 + + IMPLICIT NONE + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + + ! input variables + INTEGER, INTENT(IN) :: hsize + INTEGER, INTENT(IN) :: vsize + REAL, DIMENSION(hsize), INTENT(IN) :: alpha + REAL, DIMENSION(hsize,vsize), INTENT(INOUT) :: field + + ! Local variables + INTEGER :: l + + IF (hsize==ip1jm) THEN + do l=1,vsize + field(ijb_v:ije_v,l)=alpha(ijb_v:ije_v)*field(ijb_v:ije_v,l)*alpha_pcor(l) + enddo + ELSE + do l=1,vsize + field(ijb_u:ije_u,l)=alpha(ijb_u:ije_u)*field(ijb_u:ije_u,l)*alpha_pcor(l) + enddo + ENDIF + + END SUBROUTINE guide_addfield + +!======================================================================= + SUBROUTINE guide_zonave(typ,hsize,vsize,field) + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "comgeom.h" + INCLUDE "comconst.h" + + ! input/output variables + INTEGER, INTENT(IN) :: typ + INTEGER, INTENT(IN) :: vsize + INTEGER, INTENT(IN) :: hsize + REAL, DIMENSION(hsize*iip1,vsize), INTENT(INOUT) :: field + + ! Local variables + LOGICAL, SAVE :: first=.TRUE. + INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain + INTEGER :: i,j,l,ij + REAL, DIMENSION (iip1) :: lond ! longitude in Deg. + REAL, DIMENSION (hsize,vsize):: fieldm ! zon-averaged field + + IF (first) THEN + first=.FALSE. +!Compute domain for averaging + lond=rlonu*180./pi + imin(1)=1;imax(1)=iip1; + imin(2)=1;imax(2)=iip1; + IF (guide_reg) THEN + DO i=1,iim + IF (lond(i).LT.lon_min_g) imin(1)=i + IF (lond(i).LE.lon_max_g) imax(1)=i + ENDDO + lond=rlonv*180./pi + DO i=1,iim + IF (lond(i).LT.lon_min_g) imin(2)=i + IF (lond(i).LE.lon_max_g) imax(2)=i + ENDDO + ENDIF + ENDIF + + fieldm=0. + + IF (hsize==jjm) THEN + DO l=1,vsize + ! Compute zonal average + DO j=jjb_v,jje_v + DO i=imin(typ),imax(typ) + ij=(j-1)*iip1+i + fieldm(j,l)=fieldm(j,l)+field(ij,l) + ENDDO + ENDDO + fieldm(:,l)=fieldm(:,l)/FLOAT(imax(typ)-imin(typ)+1) + ! Compute forcing + DO j=jjb_v,jje_v + DO i=1,iip1 + ij=(j-1)*iip1+i + field(ij,l)=fieldm(j,l) + ENDDO + ENDDO + ENDDO + ELSE + DO l=1,vsize + ! Compute zonal average + DO j=jjb_v,jje_v + DO i=imin(typ),imax(typ) + ij=(j-1)*iip1+i + fieldm(j,l)=fieldm(j,l)+field(ij,l) + ENDDO + ENDDO + fieldm(:,l)=fieldm(:,l)/FLOAT(imax(typ)-imin(typ)+1) + ! Compute forcing + DO j=jjb_u,jje_u + DO i=1,iip1 + ij=(j-1)*iip1+i + field(ij,l)=fieldm(j,l) + ENDDO + ENDDO + ENDDO + ENDIF + + END SUBROUTINE guide_zonave + +!======================================================================= + SUBROUTINE guide_interp(psi,teta) + USE parallel + USE mod_hallo + USE Bands + IMPLICIT NONE + + include "dimensions.h" + include "paramet.h" + include "comvert.h" + include "comgeom2.h" + include "comconst.h" + + REAL, DIMENSION (iip1,jjp1), INTENT(IN) :: psi ! Psol gcm + REAL, DIMENSION (iip1,jjp1,llm), INTENT(IN) :: teta ! Temp. Pot. gcm + + LOGICAL, SAVE :: first=.TRUE. + ! Variables pour niveaux pression: + REAL, DIMENSION (iip1,jjp1,nlevnc) :: plnc1,plnc2 !niveaux pression guidage + REAL, DIMENSION (iip1,jjp1,llm) :: plunc,plsnc !niveaux pression modele + REAL, DIMENSION (iip1,jjm,llm) :: plvnc !niveaux pression modele + REAL, DIMENSION (iip1,jjp1,llmp1) :: p ! pression intercouches + REAL, DIMENSION (iip1,jjp1,llm) :: pls, pext ! var intermediaire + REAL, DIMENSION (iip1,jjp1,llm) :: pbarx + REAL, DIMENSION (iip1,jjm,llm) :: pbary + ! Variables pour fonction Exner (P milieu couche) + REAL, DIMENSION (iip1,jjp1,llm) :: pk, pkf + REAL, DIMENSION (iip1,jjp1,llm) :: alpha, beta + REAL, DIMENSION (iip1,jjp1) :: pks + REAL :: prefkap,unskap + ! Pression de vapeur saturante + REAL, DIMENSION (ip1jmp1,llm) :: qsat + !Variables intermediaires interpolation + REAL, DIMENSION (iip1,jjp1,llm) :: zu1,zu2 + REAL, DIMENSION (iip1,jjm,llm) :: zv1,zv2 + + INTEGER :: i,j,l,ij + TYPE(Request) :: Req + + print *,'Guide: conversion variables guidage' +! ----------------------------------------------------------------- +! Calcul des niveaux de pression champs guidage +! ----------------------------------------------------------------- +if (guide_modele) then + do i=1,iip1 + do j=jjb_u,jje_u + do l=1,nlevnc + plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j) + plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j) + enddo + enddo + enddo +else + do i=1,iip1 + do j=jjb_u,jje_u + do l=1,nlevnc + plnc2(i,j,l)=apnc(l) + plnc1(i,j,l)=apnc(l) + enddo + enddo + enddo + +endif + if (first) then + first=.FALSE. + print*,'Guide: verification ordre niveaux verticaux' + print*,'LMDZ :' + do l=1,llm + print*,'PL(',l,')=',(ap(l)+ap(l+1))/2. & + +psi(1,jje_u)*(bp(l)+bp(l+1))/2. + enddo + print*,'Fichiers guidage' + do l=1,nlevnc + print*,'PL(',l,')=',plnc2(1,jjb_u,l) + enddo + print *,'inversion de l''ordre: invert_p=',invert_p + if (guide_u) then + do l=1,nlevnc + print*,'U(',l,')=',unat2(1,jjb_u,l) + enddo + endif + if (guide_T) then + do l=1,nlevnc + print*,'T(',l,')=',tnat2(1,jjb_u,l) + enddo + endif + endif + +! ----------------------------------------------------------------- +! Calcul niveaux pression modele +! ----------------------------------------------------------------- + CALL pression_p( ip1jmp1, ap, bp, psi, p ) + CALL exner_hyb_p(ip1jmp1,psi,p,alpha,beta,pks,pk,pkf) + +! .... Calcul de pls , pression au milieu des couches ,en Pascals + unskap=1./kappa + prefkap = preff ** kappa + DO l = 1, llm + DO j=jjb_u,jje_u + DO i =1, iip1 + pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap + ENDDO + ENDDO + ENDDO + +! calcul des pressions pour les grilles u et v + do l=1,llm + do j=jjb_u,jje_u + do i=1,iip1 + pext(i,j,l)=pls(i,j,l)*aire(i,j) + enddo + enddo + enddo + + CALL Register_SwapFieldHallo(pext,pext,ip1jmp1,llm,jj_Nb_caldyn,1,2,Req) + CALL SendRequest(Req) + CALL WaitRequest(Req) + + call massbar_p(pext, pbarx, pbary ) + do l=1,llm + do j=jjb_u,jje_u + do i=1,iip1 + plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j) + plsnc(i,j,l)=pls(i,j,l) + enddo + enddo + enddo + do l=1,llm + do j=jjb_v,jje_v + do i=1,iip1 + plvnc(i,j,l)=pbary(i,j,l)/airev(i,j) + enddo + enddo + enddo + +! ----------------------------------------------------------------- +! Interpolation champs guidage sur niveaux modele (+inversion N/S) +! Conversion en variables gcm (ucov, vcov...) +! ----------------------------------------------------------------- + if (guide_P) then + do j=jjb_u,jje_u + do i=1,iim + ij=(j-1)*iip1+i + psgui1(ij)=psnat1(i,j) + psgui2(ij)=psnat2(i,j) + enddo + psgui1(iip1*j)=psnat1(1,j) + psgui2(iip1*j)=psnat2(1,j) + enddo + endif + + IF (guide_u) THEN + CALL pres2lev(unat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc1(:,jjb_u:jje_u,:),plunc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + CALL pres2lev(unat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc2(:,jjb_u:jje_u,:),plunc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + + do l=1,llm + do j=jjb_u,jje_u + do i=1,iim + ij=(j-1)*iip1+i + ugui1(ij,l)=zu1(i,j,l)*cu(i,j) + ugui2(ij,l)=zu2(i,j,l)*cu(i,j) + enddo + ugui1(j*iip1,l)=ugui1((j-1)*iip1+1,l) + ugui2(j*iip1,l)=ugui2((j-1)*iip1+1,l) + enddo + do i=1,iip1 + ugui1(i,l)=0. + ugui1(ip1jm+i,l)=0. + ugui2(i,l)=0. + ugui2(ip1jm+i,l)=0. + enddo + enddo + ENDIF + + IF (guide_T) THEN + CALL pres2lev(tnat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc1(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + CALL pres2lev(tnat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc2(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + + do l=1,llm + do j=jjb_u,jje_u + IF (guide_teta) THEN + do i=1,iim + ij=(j-1)*iip1+i + tgui1(ij,l)=zu1(i,j,l) + tgui2(ij,l)=zu2(i,j,l) + enddo + ELSE + do i=1,iim + ij=(j-1)*iip1+i + tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l) + tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l) + enddo + ENDIF + tgui1(j*iip1,l)=tgui1((j-1)*iip1+1,l) + tgui2(j*iip1,l)=tgui2((j-1)*iip1+1,l) + enddo + do i=1,iip1 + tgui1(i,l)=tgui1(1,l) + tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l) + tgui2(i,l)=tgui2(1,l) + tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l) + enddo + enddo + ENDIF + + IF (guide_v) THEN + + CALL pres2lev(vnat1(:,jjb_v:jje_v,:),zv1(:,jjb_v:jje_v,:),nlevnc,llm, & + plnc1(:,jjb_v:jje_v,:),plvnc(:,jjb_v:jje_v,:),iip1,jjn_v,invert_p) + CALL pres2lev(vnat2(:,jjb_v:jje_v,:),zv2(:,jjb_v:jje_v,:),nlevnc,llm, & + plnc2(:,jjb_v:jje_v,:),plvnc(:,jjb_v:jje_v,:),iip1,jjn_v,invert_p) + + do l=1,llm + do j=jjb_v,jje_v + do i=1,iim + ij=(j-1)*iip1+i + vgui1(ij,l)=zv1(i,j,l)*cv(i,j) + vgui2(ij,l)=zv2(i,j,l)*cv(i,j) + enddo + vgui1(j*iip1,l)=vgui1((j-1)*iip1+1,l) + vgui2(j*iip1,l)=vgui2((j-1)*iip1+1,l) + enddo + enddo + ENDIF + + IF (guide_Q) THEN + ! On suppose qu'on a la bonne variable dans le fichier de guidage: + ! Hum.Rel si guide_hr, Hum.Spec. sinon. + CALL pres2lev(qnat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc1(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + CALL pres2lev(qnat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc2(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + + do l=1,llm + do j=jjb_u,jjb_v + do i=1,iim + ij=(j-1)*iip1+i + qgui1(ij,l)=zu1(i,j,l) + qgui2(ij,l)=zu2(i,j,l) + enddo + qgui1(j*iip1,l)=qgui1((j-1)*iip1+1,l) + qgui2(j*iip1,l)=qgui2((j-1)*iip1+1,l) + enddo + do i=1,iip1 + qgui1(i,l)=qgui1(1,l) + qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l) + qgui2(i,l)=qgui2(1,l) + qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l) + enddo + enddo + IF (guide_hr) THEN + CALL q_sat(iip1*jjn_u*llm,teta(:,jjb_u:jje_u,:)*pk(:,jjb_u:jje_u,:)/cpp, & + plsnc(:,jjb_u:jje_u,:),qsat(ijb_u:ije_u,:)) + qgui1(ijb_u:ije_u,:)=qgui1(ijb_u:ije_u,:)*qsat(ijb_u:ije_u,:)*0.01 !hum. rel. en % + qgui2(ijb_u:ije_u,:)=qgui2(ijb_u:ije_u,:)*qsat(ijb_u:ije_u,:)*0.01 + ENDIF + ENDIF + + END SUBROUTINE guide_interp + +!======================================================================= + SUBROUTINE tau2alpha(typ,pim,pjm,factt,taumin,taumax,alpha) + +! Calcul des constantes de rappel alpha (=1/tau) + + implicit none + + include "dimensions.h" + include "paramet.h" + include "comconst.h" + include "comgeom2.h" + include "serre.h" + +! input arguments : + INTEGER, INTENT(IN) :: typ ! u(2),v(3), ou scalaire(1) + INTEGER, INTENT(IN) :: pim,pjm ! dimensions en lat, lon + REAL, INTENT(IN) :: factt ! pas de temps en fraction de jour + REAL, INTENT(IN) :: taumin,taumax +! output arguments: + REAL, DIMENSION(pim,pjm), INTENT(OUT) :: alpha + +! local variables: + LOGICAL, SAVE :: first=.TRUE. + REAL, SAVE :: gamma,dxdy_min,dxdy_max + REAL, DIMENSION (iip1,jjp1) :: zdx,zdy + REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu + REAL, DIMENSION (iip1,jjm) :: dxdyv + real dxdy_ + real zlat,zlon + real alphamin,alphamax,xi + integer i,j,ilon,ilat + + + alphamin=factt/taumax + alphamax=factt/taumin + IF (guide_reg.OR.guide_add) THEN + alpha=alphamax +!----------------------------------------------------------------------- +! guide_reg: alpha=alpha_min dans region, 0. sinon. +!----------------------------------------------------------------------- + IF (guide_reg) THEN + do j=1,pjm + do i=1,pim + if (typ.eq.2) then + zlat=rlatu(j)*180./pi + zlon=rlonu(i)*180./pi + elseif (typ.eq.1) then + zlat=rlatu(j)*180./pi + zlon=rlonv(i)*180./pi + elseif (typ.eq.3) then + zlat=rlatv(j)*180./pi + zlon=rlonv(i)*180./pi + endif + alpha(i,j)=alphamax/16.* & + (1.+tanh((zlat-lat_min_g)/tau_lat))* & + (1.+tanh((lat_max_g-zlat)/tau_lat))* & + (1.+tanh((zlon-lon_min_g)/tau_lon))* & + (1.+tanh((lon_max_g-zlon)/tau_lon)) + enddo + enddo + ENDIF + ELSE +!----------------------------------------------------------------------- +! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom. +!----------------------------------------------------------------------- +!Calcul de l'aire des mailles + do j=2,jjm + do i=2,iip1 + zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j)) + enddo + zdx(1,j)=zdx(iip1,j) + enddo + do j=2,jjm + do i=1,iip1 + zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j)) + enddo + enddo + do i=1,iip1 + zdx(i,1)=zdx(i,2) + zdx(i,jjp1)=zdx(i,jjm) + zdy(i,1)=zdy(i,2) + zdy(i,jjp1)=zdy(i,jjm) + enddo + do j=1,jjp1 + do i=1,iip1 + dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j)) + enddo + enddo + IF (typ.EQ.2) THEN + do j=1,jjp1 + do i=1,iim + dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j)) + enddo + dxdyu(iip1,j)=dxdyu(1,j) + enddo + ENDIF + IF (typ.EQ.3) THEN + do j=1,jjm + do i=1,iip1 + dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1)) + enddo + enddo + ENDIF +! Premier appel: calcul des aires min et max et de gamma. + IF (first) THEN + first=.FALSE. + ! coordonnees du centre du zoom + CALL coordij(clon,clat,ilon,ilat) + ! aire de la maille au centre du zoom + dxdy_min=dxdys(ilon,ilat) + ! dxdy maximale de la maille + dxdy_max=0. + do j=1,jjp1 + do i=1,iip1 + dxdy_max=max(dxdy_max,dxdys(i,j)) + enddo + enddo + ! Calcul de gamma + if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then + print*,'ATTENTION modele peu zoome' + print*,'ATTENTION on prend une constante de guidage cste' + gamma=0. + else + gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min) + print*,'gamma=',gamma + if (gamma.lt.1.e-5) then + print*,'gamma =',gamma,'<1e-5' + stop + endif + gamma=log(0.5)/log(gamma) + if (gamma4) then + gamma=min(gamma,4.) + endif + print*,'gamma=',gamma + endif + ENDIF !first + + do j=1,pjm + do i=1,pim + if (typ.eq.1) then + dxdy_=dxdys(i,j) + zlat=rlatu(j)*180./pi + elseif (typ.eq.2) then + dxdy_=dxdyu(i,j) + zlat=rlatu(j)*180./pi + elseif (typ.eq.3) then + dxdy_=dxdyv(i,j) + zlat=rlatv(j)*180./pi + endif + if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then + ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin + alpha(i,j)=alphamin + else + xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma + xi=min(xi,1.) + if(lat_min_g.le.zlat .and. zlat.le.lat_max_g) then + alpha(i,j)=xi*alphamin+(1.-xi)*alphamax + else + alpha(i,j)=0. + endif + endif + enddo + enddo + ENDIF ! guide_reg + + END SUBROUTINE tau2alpha + +!======================================================================= + SUBROUTINE guide_read(timestep) + + IMPLICIT NONE + +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" + + INTEGER, INTENT(IN) :: timestep + + LOGICAL, SAVE :: first=.TRUE. +! Identification fichiers et variables NetCDF: + INTEGER, SAVE :: ncidu,varidu,ncidv,varidv,ncidQ + INTEGER, SAVE :: varidQ,ncidt,varidt,ncidps,varidps + INTEGER :: ncidpl,varidpl,varidap,varidbp +! Variables auxiliaires NetCDF: + INTEGER, DIMENSION(4) :: start,count + INTEGER :: status,rcode + +! ----------------------------------------------------------------- +! Premier appel: initialisation de la lecture des fichiers +! ----------------------------------------------------------------- + if (first) then + ncidpl=-99 + print*,'Guide: ouverture des fichiers guidage ' +! Niveaux de pression si non constants + if (guide_modele) then + print *,'Lecture du guidage sur niveaux mod�le' + rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl) + rcode = nf90_inq_varid(ncidpl, 'AP', varidap) + rcode = nf90_inq_varid(ncidpl, 'BP', varidbp) + print*,'ncidpl,varidap',ncidpl,varidap + endif +! Vent zonal + if (guide_u) then + rcode = nf90_open('u.nc', nf90_nowrite, ncidu) + rcode = nf90_inq_varid(ncidu, 'UWND', varidu) + print*,'ncidu,varidu',ncidu,varidu + if (ncidpl.eq.-99) ncidpl=ncidu + endif +! Vent meridien + if (guide_v) then + rcode = nf90_open('v.nc', nf90_nowrite, ncidv) + rcode = nf90_inq_varid(ncidv, 'VWND', varidv) + print*,'ncidv,varidv',ncidv,varidv + if (ncidpl.eq.-99) ncidpl=ncidv + endif +! Temperature + if (guide_T) then + rcode = nf90_open('T.nc', nf90_nowrite, ncidt) + rcode = nf90_inq_varid(ncidt, 'AIR', varidt) + print*,'ncidT,varidT',ncidt,varidt + if (ncidpl.eq.-99) ncidpl=ncidt + endif +! Humidite + if (guide_Q) then + rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ) + rcode = nf90_inq_varid(ncidQ, 'RH', varidQ) + print*,'ncidQ,varidQ',ncidQ,varidQ + if (ncidpl.eq.-99) ncidpl=ncidQ + endif +! Pression de surface + if ((guide_P).OR.(guide_modele)) then + rcode = nf90_open('ps.nc', nf90_nowrite, ncidps) + rcode = nf90_inq_varid(ncidps, 'SP', varidps) + print*,'ncidps,varidps',ncidps,varidps + endif +! Coordonnee verticale + if (.not.guide_modele) then + rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl) + IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl) + print*,'ncidpl,varidpl',ncidpl,varidpl + endif +! Coefs ap, bp pour calcul de la pression aux differents niveaux + if (guide_modele) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc) +#endif + else +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc) +#endif + apnc=apnc*100.! conversion en Pascals + bpnc(:)=0. + endif + first=.FALSE. + endif ! (first) + +! ----------------------------------------------------------------- +! lecture des champs u, v, T, Q, ps +! ----------------------------------------------------------------- + +! dimensions pour les champs scalaires et le vent zonal + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=timestep + + count(1)=iip1 + count(2)=jjp1 + count(3)=nlevnc + count(4)=1 + +! Vent zonal + if (guide_u) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,unat2) +#else + status=NF_GET_VARA_REAL(ncidu,varidu,start,count,unat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,unat2) + ENDIF + + endif + +! Temperature + if (guide_T) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,tnat2) +#else + status=NF_GET_VARA_REAL(ncidt,varidt,start,count,tnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,tnat2) + ENDIF + endif + +! Humidite + if (guide_Q) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,qnat2) +#else + status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,qnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,qnat2) + ENDIF + + endif + +! Vent meridien + if (guide_v) then + count(2)=jjm +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,vnat2) +#else + status=NF_GET_VARA_REAL(ncidv,varidv,start,count,vnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjm,llm,vnat2) + ENDIF + endif + +! Pression de surface + if ((guide_P).OR.(guide_modele)) then + start(3)=timestep + start(4)=0 + count(2)=jjp1 + count(3)=1 + count(4)=0 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,psnat2) +#else + status=NF_GET_VARA_REAL(ncidps,varidps,start,count,psnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,1,psnat2) + ENDIF + endif + + END SUBROUTINE guide_read + +!======================================================================= + SUBROUTINE guide_read2D(timestep) + + IMPLICIT NONE + +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" + + INTEGER, INTENT(IN) :: timestep + + LOGICAL, SAVE :: first=.TRUE. +! Identification fichiers et variables NetCDF: + INTEGER, SAVE :: ncidu,varidu,ncidv,varidv,ncidQ + INTEGER, SAVE :: varidQ,ncidt,varidt,ncidps,varidps + INTEGER :: ncidpl,varidpl,varidap,varidbp +! Variables auxiliaires NetCDF: + INTEGER, DIMENSION(4) :: start,count + INTEGER :: status,rcode +! Variables for 3D extension: + REAL, DIMENSION (jjp1,llm) :: zu + REAL, DIMENSION (jjm,llm) :: zv + INTEGER :: i + +! ----------------------------------------------------------------- +! Premier appel: initialisation de la lecture des fichiers +! ----------------------------------------------------------------- + if (first) then + ncidpl=-99 + print*,'Guide: ouverture des fichiers guidage ' +! Niveaux de pression si non constants + if (guide_modele) then + print *,'Lecture du guidage sur niveaux mod�le' + rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl) + rcode = nf90_inq_varid(ncidpl, 'AP', varidap) + rcode = nf90_inq_varid(ncidpl, 'BP', varidbp) + print*,'ncidpl,varidap',ncidpl,varidap + endif +! Vent zonal + if (guide_u) then + rcode = nf90_open('u.nc', nf90_nowrite, ncidu) + rcode = nf90_inq_varid(ncidu, 'UWND', varidu) + print*,'ncidu,varidu',ncidu,varidu + if (ncidpl.eq.-99) ncidpl=ncidu + endif +! Vent meridien + if (guide_v) then + rcode = nf90_open('v.nc', nf90_nowrite, ncidv) + rcode = nf90_inq_varid(ncidv, 'VWND', varidv) + print*,'ncidv,varidv',ncidv,varidv + if (ncidpl.eq.-99) ncidpl=ncidv + endif +! Temperature + if (guide_T) then + rcode = nf90_open('T.nc', nf90_nowrite, ncidt) + rcode = nf90_inq_varid(ncidt, 'AIR', varidt) + print*,'ncidT,varidT',ncidt,varidt + if (ncidpl.eq.-99) ncidpl=ncidt + endif +! Humidite + if (guide_Q) then + rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ) + rcode = nf90_inq_varid(ncidQ, 'RH', varidQ) + print*,'ncidQ,varidQ',ncidQ,varidQ + if (ncidpl.eq.-99) ncidpl=ncidQ + endif +! Pression de surface + if ((guide_P).OR.(guide_modele)) then + rcode = nf90_open('ps.nc', nf90_nowrite, ncidps) + rcode = nf90_inq_varid(ncidps, 'SP', varidps) + print*,'ncidps,varidps',ncidps,varidps + endif +! Coordonnee verticale + if (.not.guide_modele) then + rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl) + IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl) + print*,'ncidpl,varidpl',ncidpl,varidpl + endif +! Coefs ap, bp pour calcul de la pression aux differents niveaux + if (guide_modele) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc) +#endif + else +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc) +#endif + apnc=apnc*100.! conversion en Pascals + bpnc(:)=0. + endif + first=.FALSE. + endif ! (first) + +! ----------------------------------------------------------------- +! lecture des champs u, v, T, Q, ps +! ----------------------------------------------------------------- + +! dimensions pour les champs scalaires et le vent zonal + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=timestep + + count(1)=1 + count(2)=jjp1 + count(3)=nlevnc + count(4)=1 + +! Vent zonal + if (guide_u) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidu,varidu,start,count,zu) +#endif + DO i=1,iip1 + unat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,unat2) + ENDIF + + endif + +! Temperature + if (guide_T) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidt,varidt,start,count,zu) +#endif + DO i=1,iip1 + tnat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,tnat2) + ENDIF + + endif + +! Humidite + if (guide_Q) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,zu) +#endif + DO i=1,iip1 + qnat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,qnat2) + ENDIF + + endif + +! Vent meridien + if (guide_v) then + count(2)=jjm +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,zv) +#else + status=NF_GET_VARA_REAL(ncidv,varidv,start,count,zv) +#endif + DO i=1,iip1 + vnat2(i,:,:)=zv(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjm,llm,vnat2) + ENDIF + + endif + +! Pression de surface + if ((guide_P).OR.(guide_modele)) then + start(3)=timestep + start(4)=0 + count(2)=jjp1 + count(3)=1 + count(4)=0 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,zu(:,1)) +#else + status=NF_GET_VARA_REAL(ncidps,varidps,start,count,zu(:,1)) +#endif + DO i=1,iip1 + psnat2(i,:)=zu(:,1) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,1,psnat2) + ENDIF + + endif + + END SUBROUTINE guide_read2D + +!======================================================================= + SUBROUTINE guide_out(varname,hsize,vsize,field) + USE parallel + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "netcdf.inc" + INCLUDE "comgeom2.h" + INCLUDE "comconst.h" + INCLUDE "comvert.h" + + ! Variables entree + CHARACTER, INTENT(IN) :: varname + INTEGER, INTENT (IN) :: hsize,vsize + REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field + + ! Variables locales + INTEGER, SAVE :: timestep=0 + ! Identites fichier netcdf + INTEGER :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev + INTEGER :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev + INTEGER, DIMENSION (3) :: dim3 + INTEGER, DIMENSION (4) :: dim4,count,start + INTEGER :: ierr, varid + + CALL gather_field(field,iip1*hsize,vsize,0) + + IF (mpi_rank /= 0) RETURN + + print *,'Guide: output timestep',timestep,'var ',varname + IF (timestep.EQ.0) THEN +! ---------------------------------------------- +! initialisation fichier de sortie +! ---------------------------------------------- +! Ouverture du fichier + ierr=NF_CREATE("guide_ins.nc",NF_CLOBBER,nid) +! Definition des dimensions + ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu) + ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv) + ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu) + ierr=NF_DEF_DIM(nid,"LATV",jjm,id_latv) + ierr=NF_DEF_DIM(nid,"LEVEL",llm,id_lev) + ierr=NF_DEF_DIM(nid,"TIME",NF_UNLIMITED,id_tim) + +! Creation des variables dimensions + ierr=NF_DEF_VAR(nid,"LONU",NF_FLOAT,1,id_lonu,vid_lonu) + ierr=NF_DEF_VAR(nid,"LONV",NF_FLOAT,1,id_lonv,vid_lonv) + ierr=NF_DEF_VAR(nid,"LATU",NF_FLOAT,1,id_latu,vid_latu) + ierr=NF_DEF_VAR(nid,"LATV",NF_FLOAT,1,id_latv,vid_latv) + ierr=NF_DEF_VAR(nid,"LEVEL",NF_FLOAT,1,id_lev,vid_lev) + ierr=NF_DEF_VAR(nid,"cu",NF_FLOAT,2,(/id_lonu,id_latu/),vid_cu) + ierr=NF_DEF_VAR(nid,"cv",NF_FLOAT,2,(/id_lonv,id_latv/),vid_cv) + + ierr=NF_ENDDEF(nid) + +! Enregistrement des variables dimensions +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonu,rlonu*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonv,rlonv*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_latu,rlatu*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_latv,rlatv*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lev,presnivs) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_cu,cu) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_cv,cv) +#else + ierr = NF_PUT_VAR_REAL(nid,vid_lonu,rlonu*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_lonv,rlonv*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_latu,rlatu*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_latv,rlatv*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_lev,presnivs) + ierr = NF_PUT_VAR_REAL(nid,vid_cu,cu) + ierr = NF_PUT_VAR_REAL(nid,vid_cv,cv) +#endif +! -------------------------------------------------------------------- +! Cr�ation des variables sauvegard�es +! -------------------------------------------------------------------- + ierr = NF_REDEF(nid) +! Surface pressure (GCM) + dim3=(/id_lonv,id_latu,id_tim/) + ierr = NF_DEF_VAR(nid,"SP",NF_FLOAT,3,dim3,varid) +! Surface pressure (guidage) + IF (guide_P) THEN + dim3=(/id_lonv,id_latu,id_tim/) + ierr = NF_DEF_VAR(nid,"ps",NF_FLOAT,3,dim3,varid) + ENDIF +! Zonal wind + IF (guide_u) THEN + dim4=(/id_lonu,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"ucov",NF_FLOAT,4,dim4,varid) + ENDIF +! Merid. wind + IF (guide_v) THEN + dim4=(/id_lonv,id_latv,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"vcov",NF_FLOAT,4,dim4,varid) + ENDIF +! Pot. Temperature + IF (guide_T) THEN + dim4=(/id_lonv,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"teta",NF_FLOAT,4,dim4,varid) + ENDIF +! Specific Humidity + IF (guide_Q) THEN + dim4=(/id_lonv,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"q",NF_FLOAT,4,dim4,varid) + ENDIF + + ierr = NF_ENDDEF(nid) + ierr = NF_CLOSE(nid) + ENDIF ! timestep=0 + +! -------------------------------------------------------------------- +! Enregistrement du champ +! -------------------------------------------------------------------- + ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid) + + SELECT CASE (varname) + CASE ("S") + timestep=timestep+1 + ierr = NF_INQ_VARID(nid,"SP",varid) + start=(/1,1,timestep,0/) + count=(/iip1,jjp1,1,0/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("P") + ierr = NF_INQ_VARID(nid,"ps",varid) + start=(/1,1,timestep,0/) + count=(/iip1,jjp1,1,0/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("U") + ierr = NF_INQ_VARID(nid,"ucov",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("V") + ierr = NF_INQ_VARID(nid,"vcov",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjm,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("T") + ierr = NF_INQ_VARID(nid,"teta",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("Q") + ierr = NF_INQ_VARID(nid,"q",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + END SELECT + + ierr = NF_CLOSE(nid) + + END SUBROUTINE guide_out + + +!=========================================================================== + subroutine correctbid(iim,nl,x) + integer iim,nl + real x(iim+1,nl) + integer i,l + real zz + + do l=1,nl + do i=2,iim-1 + if(abs(x(i,l)).gt.1.e10) then + zz=0.5*(x(i-1,l)+x(i+1,l)) + print*,'correction ',i,l,x(i,l),zz + x(i,l)=zz + endif + enddo + enddo + return + end subroutine correctbid + +!=========================================================================== +END MODULE guide_p_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/heavyside.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/heavyside.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/heavyside.F (revision 1280) @@ -0,0 +1,23 @@ +! +! $Header$ +! +c +c + FUNCTION heavyside(a) + +c ... P. Le Van .... +c + IMPLICIT NONE + + REAL(KIND=8) heavyside , a + + IF ( a.LE.0. ) THEN + heavyside = 0. + ELSE + heavyside = 1. + ENDIF + + RETURN + END + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/infotrac.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/infotrac.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/infotrac.F90 (revision 1280) @@ -0,0 +1,335 @@ +! $Id$ +! +MODULE infotrac + +! nqtot : total number of tracers and higher order of moment, water vapor and liquid included + INTEGER, SAVE :: nqtot + +! nbtr : number of tracers not including higher order of moment or water vapor or liquid +! number of tracers used in the physics + INTEGER, SAVE :: nbtr + +! Name variables + CHARACTER(len=20), ALLOCATABLE, DIMENSION(:), SAVE :: tname ! tracer short name for restart and diagnostics + CHARACTER(len=23), ALLOCATABLE, DIMENSION(:), SAVE :: ttext ! tracer long name for diagnostics + +! iadv : index of trasport schema for each tracer + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: iadv + +! niadv : vector keeping the coorspondance between all tracers(nqtot) treated in the +! dynamic part of the code and the tracers (nbtr+2) used in the physics part of the code. + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: niadv ! equivalent dyn / physique + +! conv_flg(it)=0 : convection desactivated for tracer number it + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: conv_flg +! pbl_flg(it)=0 : boundary layer diffusion desactivaded for tracer number it + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: pbl_flg + + CHARACTER(len=4),SAVE :: type_trac + +CONTAINS + + SUBROUTINE infotrac_init + IMPLICIT NONE +!======================================================================= +! +! Auteur: P. Le Van /L. Fairhead/F.Hourdin +! ------- +! Modif special traceur F.Forget 05/94 +! Modif M-A Filiberti 02/02 lecture de traceur.def +! +! Objet: +! ------ +! GCM LMD nouvelle grille +! +!======================================================================= +! ... modification de l'integration de q ( 26/04/94 ) .... +!----------------------------------------------------------------------- +! Declarations + + INCLUDE "dimensions.h" + INCLUDE "control.h" + INCLUDE "iniprint.h" + +! Local variables + INTEGER, ALLOCATABLE, DIMENSION(:) :: hadv ! index of horizontal trasport schema + INTEGER, ALLOCATABLE, DIMENSION(:) :: vadv ! index of vertical trasport schema + + CHARACTER(len=15), ALLOCATABLE, DIMENSION(:) :: tnom_0 ! tracer short name + CHARACTER(len=8), ALLOCATABLE, DIMENSION(:) :: tracnam ! name from INCA + CHARACTER(len=3), DIMENSION(30) :: descrq + CHARACTER(len=1), DIMENSION(3) :: txts + CHARACTER(len=2), DIMENSION(9) :: txtp + CHARACTER(len=13) :: str1,str2 + + INTEGER :: nqtrue ! number of tracers read from tracer.def, without higer order of moment + INTEGER :: iq, new_iq, iiq, jq, ierr + INTEGER, EXTERNAL :: lnblnk + +!----------------------------------------------------------------------- +! Initialization : +! + txts=(/'x','y','z'/) + txtp=(/'x ','y ','z ','xx','xy','xz','yy','yz','zz'/) + + descrq(14)='VLH' + descrq(10)='VL1' + descrq(11)='VLP' + descrq(12)='FH1' + descrq(13)='FH2' + descrq(16)='PPM' + descrq(17)='PPS' + descrq(18)='PPP' + descrq(20)='SLP' + descrq(30)='PRA' + + + IF (config_inca=='none') THEN + type_trac='lmdz' + ELSE + type_trac='inca' + END IF + +!----------------------------------------------------------------------- +! +! 1) Get the true number of tracers + water vapor/liquid +! Here true tracers (nqtrue) means declared tracers (only first order) +! +!----------------------------------------------------------------------- + IF (type_trac == 'lmdz') THEN + OPEN(90,file='traceur.def',form='formatted',status='old', iostat=ierr) + IF(ierr.EQ.0) THEN + WRITE(lunout,*) 'Open traceur.def : ok' + READ(90,*) nqtrue + ELSE + WRITE(lunout,*) 'Problem in opening traceur.def' + WRITE(lunout,*) 'ATTENTION using defaut values' + nqtrue=4 ! Defaut value + END IF + ! Attention! Only for planet_type=='earth' + nbtr=nqtrue-2 + ELSE + ! nbtr has been read from INCA by init_cont_lmdz() in gcm.F + nqtrue=nbtr+2 + END IF + + IF (nqtrue < 2) THEN + WRITE(lunout,*) 'nqtrue=',nqtrue, ' is not allowded. 2 tracers is the minimum' + CALL abort_gcm('infotrac_init','Not enough tracers',1) + END IF +! +! Allocate variables depending on nqtrue and nbtr +! + ALLOCATE(tnom_0(nqtrue), hadv(nqtrue), vadv(nqtrue)) + ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), tracnam(nbtr)) + conv_flg(:) = 1 ! convection activated for all tracers + pbl_flg(:) = 1 ! boundary layer activated for all tracers + +!----------------------------------------------------------------------- +! 2) Choix des schemas d'advection pour l'eau et les traceurs +! +! iadv = 1 schema transport type "humidite specifique LMD" +! iadv = 2 schema amont +! iadv = 14 schema Van-leer + humidite specifique +! Modif F.Codron +! iadv = 10 schema Van-leer (retenu pour l'eau vapeur et liquide) +! iadv = 11 schema Van-Leer pour hadv et version PPM (Monotone) pour vadv +! iadv = 12 schema Frederic Hourdin I +! iadv = 13 schema Frederic Hourdin II +! iadv = 16 schema PPM Monotone(Collela & Woodward 1984) +! iadv = 17 schema PPM Semi Monotone (overshoots autorisés) +! iadv = 18 schema PPM Positif Defini (overshoots undershoots autorisés) +! iadv = 20 schema Slopes +! iadv = 30 schema Prather +! +! Dans le tableau q(ij,l,iq) : iq = 1 pour l'eau vapeur +! iq = 2 pour l'eau liquide +! Et eventuellement iq = 3,nqtot pour les autres traceurs +! +! iadv(1): choix pour l'eau vap. et iadv(2) : choix pour l'eau liq. +!------------------------------------------------------------------------ +! +! Get choice of advection schema from file tracer.def or from INCA +!--------------------------------------------------------------------- + IF (type_trac == 'lmdz') THEN + IF(ierr.EQ.0) THEN + ! Continue to read tracer.def + DO iq=1,nqtrue + READ(90,999) hadv(iq),vadv(iq),tnom_0(iq) + END DO + CLOSE(90) + ELSE ! Without tracer.def + hadv(1) = 14 + vadv(1) = 14 + tnom_0(1) = 'H2Ov' + hadv(2) = 10 + vadv(2) = 10 + tnom_0(2) = 'H2Ol' + hadv(3) = 10 + vadv(3) = 10 + tnom_0(3) = 'RN' + hadv(4) = 10 + vadv(4) = 10 + tnom_0(4) = 'PB' + END IF + + WRITE(lunout,*) 'Valeur de traceur.def :' + WRITE(lunout,*) 'nombre de traceurs ',nqtrue + DO iq=1,nqtrue + WRITE(lunout,*) hadv(iq),vadv(iq),tnom_0(iq) + END DO + + ELSE ! type_trac=inca : config_inca='aero' ou 'chem' +! le module de chimie fournit les noms des traceurs +! et les schemas d'advection associes. + +#ifdef INCA + CALL init_transport( & + hadv, & + vadv, & + conv_flg, & + pbl_flg, & + tracnam) +#endif + tnom_0(1)='H2Ov' + tnom_0(2)='H2Ol' + + DO iq =3,nqtrue + tnom_0(iq)=tracnam(iq-2) + END DO + + END IF ! type_trac + +!----------------------------------------------------------------------- +! +! 3) Verify if advection schema 20 or 30 choosen +! Calculate total number of tracers needed: nqtot +! Allocate variables depending on total number of tracers +!----------------------------------------------------------------------- + new_iq=0 + DO iq=1,nqtrue + ! Add tracers for certain advection schema + IF (hadv(iq)<20 .AND. vadv(iq)<20 ) THEN + new_iq=new_iq+1 ! no tracers added + ELSE IF (hadv(iq)==20 .AND. vadv(iq)==20 ) THEN + new_iq=new_iq+4 ! 3 tracers added + ELSE IF (hadv(iq)==30 .AND. vadv(iq)==30 ) THEN + new_iq=new_iq+10 ! 9 tracers added + ELSE + WRITE(lunout,*) 'This choice of advection schema is not available' + CALL abort_gcm('infotrac_init','Bad choice of advection schema - 1',1) + END IF + END DO + + IF (new_iq /= nqtrue) THEN + ! The choice of advection schema imposes more tracers + ! Assigne total number of tracers + nqtot = new_iq + + WRITE(lunout,*) 'The choice of advection schema for one or more tracers' + WRITE(lunout,*) 'makes it necessary to add tracers' + WRITE(lunout,*) nqtrue,' is the number of true tracers' + WRITE(lunout,*) nqtot, ' is the total number of tracers needed' + + ELSE + ! The true number of tracers is also the total number + nqtot = nqtrue + END IF + +! +! Allocate variables with total number of tracers, nqtot +! + ALLOCATE(tname(nqtot), ttext(nqtot)) + ALLOCATE(iadv(nqtot), niadv(nqtot)) + +!----------------------------------------------------------------------- +! +! 4) Determine iadv, long and short name +! +!----------------------------------------------------------------------- + new_iq=0 + DO iq=1,nqtrue + new_iq=new_iq+1 + + ! Verify choice of advection schema + IF (hadv(iq)==vadv(iq)) THEN + iadv(new_iq)=hadv(iq) + ELSE IF (hadv(iq)==10 .AND. vadv(iq)==16) THEN + iadv(new_iq)=11 + ELSE + WRITE(lunout,*)'This choice of advection schema is not available' + CALL abort_gcm('infotrac_init','Bad choice of advection schema - 2',1) + END IF + + str1=tnom_0(iq) + tname(new_iq)= tnom_0(iq) + IF (iadv(new_iq)==0) THEN + ttext(new_iq)=str1(1:lnblnk(str1)) + ELSE + ttext(new_iq)=str1(1:lnblnk(str1))//descrq(iadv(new_iq)) + END IF + + ! schemas tenant compte des moments d'ordre superieur + str2=ttext(new_iq) + IF (iadv(new_iq)==20) THEN + DO jq=1,3 + new_iq=new_iq+1 + iadv(new_iq)=-20 + ttext(new_iq)=str2(1:lnblnk(str2))//txts(jq) + tname(new_iq)=str1(1:lnblnk(str1))//txts(jq) + END DO + ELSE IF (iadv(new_iq)==30) THEN + DO jq=1,9 + new_iq=new_iq+1 + iadv(new_iq)=-30 + ttext(new_iq)=str2(1:lnblnk(str2))//txtp(jq) + tname(new_iq)=str1(1:lnblnk(str1))//txtp(jq) + END DO + END IF + END DO + +! +! Find vector keeping the correspodence between true and total tracers +! + niadv(:)=0 + iiq=0 + DO iq=1,nqtot + IF(iadv(iq).GE.0) THEN + ! True tracer + iiq=iiq+1 + niadv(iiq)=iq + ENDIF + END DO + + + WRITE(lunout,*) 'Information stored in infotrac :' + WRITE(lunout,*) 'iadv niadv tname ttext :' + DO iq=1,nqtot + WRITE(lunout,*) iadv(iq),niadv(iq), tname(iq), ttext(iq) + END DO + +! +! Test for advection schema. +! This version of LMDZ only garantees iadv=10 and iadv=14 (14 only for water vapour) . +! + DO iq=1,nqtot + IF (iadv(iq)/=10 .AND. iadv(iq)/=14 .AND. iadv(iq)/=0) THEN + WRITE(lunout,*)'STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ' + CALL abort_gcm('infotrac_init','In this version only iadv=10 and iadv=14 is tested!',1) + ELSE IF (iadv(iq)==14 .AND. iq/=1) THEN + WRITE(lunout,*)'STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ' + CALL abort_gcm('infotrac_init','In this version iadv=14 is only permitted for water vapour!',1) + END IF + END DO + +!----------------------------------------------------------------------- +! Finalize : +! + DEALLOCATE(tnom_0, hadv, vadv) + DEALLOCATE(tracnam) + +999 FORMAT (i2,1x,i2,1x,a15) + + END SUBROUTINE infotrac_init + +END MODULE infotrac Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/iniacademic.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/iniacademic.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/iniacademic.F (revision 1280) @@ -0,0 +1,201 @@ +! +! $Header$ +! +c +c + SUBROUTINE iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0) + + USE filtreg_mod + USE infotrac, ONLY : nqtot + +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 15/01/93 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +#include "academic.h" +#include "ener.h" +#include "temps.h" +#include "control.h" +#include "iniprint.h" + +c Arguments: +c ---------- + + real time_0 + +c variables dynamiques + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL q(ip1jmp1,llm,nqtot) ! champs advectes + REAL ps(ip1jmp1) ! pression au sol + REAL masse(ip1jmp1,llm) ! masse d'air + REAL phis(ip1jmp1) ! geopotentiel au sol + +c Local: +c ------ + + REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL pks(ip1jmp1) ! exner au sol + REAL pk(ip1jmp1,llm) ! exner au milieu des couches + REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches + REAL phi(ip1jmp1,llm) ! geopotentiel + REAL ddsin,tetarappelj,tetarappell,zsig + real tetajl(jjp1,llm) + INTEGER i,j,l,lsup,ij + + real zz,ran1 + integer idum + + REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm),zdtvr + +c----------------------------------------------------------------------- +! 1. Initializations for Earth-like case +! -------------------------------------- + if (planet_type=="earth") then +c + time_0=0. + day_ref=0 + annee_ref=0 + + im = iim + jm = jjm + day_ini = 0 + omeg = 4.*asin(1.)/86400. + rad = 6371229. + g = 9.8 + daysec = 86400. + dtvr = daysec/FLOAT(day_step) + zdtvr=dtvr + kappa = 0.2857143 + cpp = 1004.70885 + preff = 101325. + pa = 50000. + etot0 = 0. + ptot0 = 0. + ztot0 = 0. + stot0 = 0. + ang0 = 0. + + CALL iniconst + CALL inigeom + CALL inifilr + + ps=0. + phis=0. +c--------------------------------------------------------------------- + + taurappel=10.*daysec + +c--------------------------------------------------------------------- +c Calcul de la temperature potentielle : +c -------------------------------------- + + DO l=1,llm + zsig=ap(l)/preff+bp(l) + if (zsig.gt.0.3) then + lsup=l + tetarappell=1./8.*(-log(zsig)-.5) + DO j=1,jjp1 + ddsin=sin(rlatu(j))-sin(pi/20.) + tetajl(j,l)=300.*(1+1./18.*(1.-3.*ddsin*ddsin)+tetarappell) + ENDDO + else +c Choix isotherme au-dessus de 300 mbar + do j=1,jjp1 + tetajl(j,l)=tetajl(j,lsup)*(0.3/zsig)**kappa + enddo + endif ! of if (zsig.gt.0.3) + ENDDO ! of DO l=1,llm + + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + ij=(j-1)*iip1+i + tetarappel(ij,l)=tetajl(j,l) + enddo + enddo + enddo + +c call dump2d(jjp1,llm,tetajl,'TEQ ') + + ps=1.e5 + phis=0. + CALL pression ( ip1jmp1, ap, bp, ps, p ) + CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf ) + CALL massdair(p,masse) + +c intialisation du vent et de la temperature + teta(:,:)=tetarappel(:,:) + CALL geopot(ip1jmp1,teta,pk,pks,phis,phi) + call ugeostr(phi,ucov) + vcov=0. + q(:,:,1 )=1.e-10 + q(:,:,2 )=1.e-15 + q(:,:,3:nqtot)=0. + + +c perturbation aleatoire sur la temperature + idum = -1 + zz = ran1(idum) + idum = 0 + do l=1,llm + do ij=iip2,ip1jm + teta(ij,l)=teta(ij,l)*(1.+0.005*ran1(idum)) + enddo + enddo + + do l=1,llm + do ij=1,ip1jmp1,iip1 + teta(ij+iim,l)=teta(ij,l) + enddo + enddo + + + +c PRINT *,' Appel test_period avec tetarappel ' +c CALL test_period ( ucov,vcov,tetarappel,q,p,phis ) +c PRINT *,' Appel test_period avec teta ' +c CALL test_period ( ucov,vcov,teta,q,p,phis ) + +c initialisation d'un traceur sur une colonne + j=jjp1*3/4 + i=iip1/2 + ij=(j-1)*iip1+i + q(ij,:,3)=1. + + else + write(lunout,*)"iniacademic: planet types other than earth", + & " not implemented (yet)." + stop + endif ! of if (planet_type=="earth") + return + END +c----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/iniconst.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/iniconst.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/iniconst.F (revision 1280) @@ -0,0 +1,57 @@ +! +! $Header$ +! + SUBROUTINE iniconst + + IMPLICIT NONE +c +c P. Le Van +c +c----------------------------------------------------------------------- +c Declarations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "temps.h" +#include "control.h" +#include "comvert.h" + + +c +c +c +c----------------------------------------------------------------------- +c dimension des boucles: +c ---------------------- + + im = iim + jm = jjm + lllm = llm + imp1 = iim + jmp1 = jjm + 1 + lllmm1 = llm - 1 + lllmp1 = llm + 1 + +c----------------------------------------------------------------------- + + dtdiss = idissip * dtvr + dtphys = iphysiq * dtvr + unsim = 1./iim + pi = 2.*ASIN( 1. ) + +c----------------------------------------------------------------------- +c + + r = cpp * kappa + + PRINT*,' R CP Kappa ', r , cpp, kappa +c +c----------------------------------------------------------------------- + + CALL disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig) +c +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inidissip.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inidissip.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inidissip.F (revision 1280) @@ -0,0 +1,225 @@ +! +! $Id$ +! + SUBROUTINE inidissip ( lstardis,nitergdiv,nitergrot,niterh , + * tetagdiv,tetagrot,tetatemp ) +c======================================================================= +c initialisation de la dissipation horizontale +c======================================================================= +c----------------------------------------------------------------------- +c declarations: +c ------------- + + IMPLICIT NONE +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "comconst.h" +#include "comvert.h" +#include "control.h" +#include "logic.h" + + LOGICAL lstardis + INTEGER nitergdiv,nitergrot,niterh + REAL tetagdiv,tetagrot,tetatemp + REAL fact,zvert(llm),zz + REAL zh(ip1jmp1),zu(ip1jmp1),zv(ip1jm),deltap(ip1jmp1,llm) + REAL ullm,vllm,umin,vmin,zhmin,zhmax + REAL zllm,z1llm + + INTEGER l,ij,idum,ii + REAL tetamin + REAL pseudoz + + REAL ran1 + + +c----------------------------------------------------------------------- +c +c calcul des valeurs propres des operateurs par methode iterrative: +c ----------------------------------------------------------------- + + crot = -1. + cdivu = -1. + cdivh = -1. + +c calcul de la valeur propre de divgrad: +c -------------------------------------- + idum = 0 + DO l = 1, llm + DO ij = 1, ip1jmp1 + deltap(ij,l) = 1. + ENDDO + ENDDO + + idum = -1 + zh(1) = RAN1(idum)-.5 + idum = 0 + DO ij = 2, ip1jmp1 + zh(ij) = RAN1(idum) -.5 + ENDDO + + CALL filtreg (zh,jjp1,1,2,1,.TRUE.,1) + + CALL minmax(iip1*jjp1,zh,zhmin,zhmax ) + + IF ( zhmin .GE. zhmax ) THEN + PRINT*,' Inidissip zh min max ',zhmin,zhmax + STOP'probleme generateur alleatoire dans inidissip' + ENDIF + + zllm = ABS( zhmax ) + DO l = 1,50 + IF(lstardis) THEN + CALL divgrad2(1,zh,deltap,niterh,zh) + ELSE + CALL divgrad (1,zh,niterh,zh) + ENDIF + + CALL minmax(iip1*jjp1,zh,zhmin,zhmax ) + + zllm = ABS( zhmax ) + z1llm = 1./zllm + DO ij = 1,ip1jmp1 + zh(ij) = zh(ij)* z1llm + ENDDO + ENDDO + + IF(lstardis) THEN + cdivh = 1./ zllm + ELSE + cdivh = zllm ** ( -1./niterh ) + ENDIF + +c calcul des valeurs propres de gradiv (ii =1) et nxgrarot(ii=2) +c ----------------------------------------------------------------- + print*,'calcul des valeurs propres' + + DO 20 ii = 1, 2 +c + DO ij = 1, ip1jmp1 + zu(ij) = RAN1(idum) -.5 + ENDDO + CALL filtreg (zu,jjp1,1,2,1,.TRUE.,1) + DO ij = 1, ip1jm + zv(ij) = RAN1(idum) -.5 + ENDDO + CALL filtreg (zv,jjm,1,2,1,.FALSE.,1) + + CALL minmax(iip1*jjp1,zu,umin,ullm ) + CALL minmax(iip1*jjm, zv,vmin,vllm ) + + ullm = ABS ( ullm ) + vllm = ABS ( vllm ) + + DO 5 l = 1, 50 + IF(ii.EQ.1) THEN +ccccc CALL covcont( 1,zu,zv,zu,zv ) + IF(lstardis) THEN + CALL gradiv2( 1,zu,zv,nitergdiv,zu,zv ) + ELSE + CALL gradiv ( 1,zu,zv,nitergdiv,zu,zv ) + ENDIF + ELSE + IF(lstardis) THEN + CALL nxgraro2( 1,zu,zv,nitergrot,zu,zv ) + ELSE + CALL nxgrarot( 1,zu,zv,nitergrot,zu,zv ) + ENDIF + ENDIF + + CALL minmax(iip1*jjp1,zu,umin,ullm ) + CALL minmax(iip1*jjm, zv,vmin,vllm ) + + ullm = ABS ( ullm ) + vllm = ABS ( vllm ) + + zllm = MAX( ullm,vllm ) + z1llm = 1./ zllm + DO ij = 1, ip1jmp1 + zu(ij) = zu(ij)* z1llm + ENDDO + DO ij = 1, ip1jm + zv(ij) = zv(ij)* z1llm + ENDDO + 5 CONTINUE + + IF ( ii.EQ.1 ) THEN + IF(lstardis) THEN + cdivu = 1./zllm + ELSE + cdivu = zllm **( -1./nitergdiv ) + ENDIF + ELSE + IF(lstardis) THEN + crot = 1./ zllm + ELSE + crot = zllm **( -1./nitergrot ) + ENDIF + ENDIF + + 20 CONTINUE + +c petit test pour les operateurs non star: +c ---------------------------------------- + +c IF(.NOT.lstardis) THEN + fact = rad*24./float(jjm) + fact = fact*fact + PRINT*,'coef u ', fact/cdivu, 1./cdivu + PRINT*,'coef r ', fact/crot , 1./crot + PRINT*,'coef h ', fact/cdivh, 1./cdivh +c ENDIF + +c----------------------------------------------------------------------- +c variation verticale du coefficient de dissipation: +c -------------------------------------------------- + + if (ok_strato .and. llm==39) then + do l=1,llm + pseudoz=8.*log(preff/presnivs(l)) + zvert(l)=1+ + s (tanh((pseudoz-dissip_zref)/dissip_deltaz)+1.)/2. + s *(dissip_factz-1.) + enddo + else + DO l=1,llm + zvert(l)=1. + ENDDO + fact=2. + DO l = 1, llm + zz = 1. - preff/presnivs(l) + zvert(l)= fact -( fact-1.)/( 1.+zz*zz ) + ENDDO + endif + + + PRINT*,'Constantes de temps de la diffusion horizontale' + + tetamin = 1.e+6 + + DO l=1,llm + tetaudiv(l) = zvert(l)/tetagdiv + tetaurot(l) = zvert(l)/tetagrot + tetah(l) = zvert(l)/tetatemp + + IF( tetamin.GT. (1./tetaudiv(l)) ) tetamin = 1./ tetaudiv(l) + IF( tetamin.GT. (1./tetaurot(l)) ) tetamin = 1./ tetaurot(l) + IF( tetamin.GT. (1./ tetah(l)) ) tetamin = 1./ tetah(l) + ENDDO + + PRINT *,' INIDI tetamin dtvr ',tetamin,dtvr,iperiod + idissip = INT( tetamin/( 2.*dtvr*iperiod) ) * iperiod + PRINT *,' INIDI tetamin idissip ',tetamin,idissip + idissip = MAX(iperiod,idissip) + dtdiss = idissip * dtvr + PRINT *,' INIDI idissip dtdiss ',idissip,dtdiss + + DO l = 1,llm + PRINT*,zvert(l),dtdiss*tetaudiv(l),dtdiss*tetaurot(l), + * dtdiss*tetah(l) + ENDDO + +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inigeom.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inigeom.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inigeom.F (revision 1280) @@ -0,0 +1,699 @@ +! +! $Header$ +! +c +c + SUBROUTINE inigeom +c +c Auteur : P. Le Van +c +c ............ Version du 01/04/2001 ........................ +c +c Calcul des elongations cuij1,.cuij4 , cvij1,..cvij4 aux memes en- +c endroits que les aires aireij1,..aireij4 . + +c Choix entre f(y) a derivee sinusoid. ou a derivee tangente hyperbol. +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" +#include "serre.h" +#include "logic.h" +#include "comdissnew.h" + +c----------------------------------------------------------------------- +c .... Variables locales .... +c + INTEGER i,j,itmax,itmay,iter + REAL cvu(iip1,jjp1),cuv(iip1,jjm) + REAL ai14,ai23,airez,rlatp,rlatm,xprm,xprp,un4rad2,yprp,yprm + REAL eps,x1,xo1,f,df,xdm,y1,yo1,ydm + REAL coslatm,coslatp,radclatm,radclatp + REAL cuij1(iip1,jjp1),cuij2(iip1,jjp1),cuij3(iip1,jjp1), + * cuij4(iip1,jjp1) + REAL cvij1(iip1,jjp1),cvij2(iip1,jjp1),cvij3(iip1,jjp1), + * cvij4(iip1,jjp1) + REAL rlonvv(iip1),rlatuu(jjp1) + REAL rlatu1(jjm),yprimu1(jjm),rlatu2(jjm),yprimu2(jjm) , + * yprimv(jjm),yprimu(jjp1) + REAL gamdi_gdiv, gamdi_grot, gamdi_h + + REAL rlonm025(iip1),xprimm025(iip1), rlonp025(iip1), + , xprimp025(iip1) + SAVE rlatu1,yprimu1,rlatu2,yprimu2,yprimv,yprimu + SAVE rlonm025,xprimm025,rlonp025,xprimp025 + + REAL SSUM +c +c +c ------------------------------------------------------------------ +c - - +c - calcul des coeff. ( cu, cv , 1./cu**2, 1./cv**2 ) - +c - - +c ------------------------------------------------------------------ +c +c les coef. ( cu, cv ) permettent de passer des vitesses naturelles +c aux vitesses covariantes et contravariantes , ou vice-versa ... +c +c +c on a : u (covariant) = cu * u (naturel) , u(contrav)= u(nat)/cu +c v (covariant) = cv * v (naturel) , v(contrav)= v(nat)/cv +c +c on en tire : u(covariant) = cu * cu * u(contravariant) +c v(covariant) = cv * cv * v(contravariant) +c +c +c on a l'application ( x(X) , y(Y) ) avec - im/2 +1 < X < im/2 +c = = +c et - jm/2 < Y < jm/2 +c = = +c +c ................................................... +c ................................................... +c . x est la longitude du point en radians . +c . y est la latitude du point en radians . +c . . +c . on a : cu(i,j) = rad * COS(y) * dx/dX . +c . cv( j ) = rad * dy/dY . +c . aire(i,j) = cu(i,j) * cv(j) . +c . . +c . y, dx/dX, dy/dY calcules aux points concernes . +c . . +c ................................................... +c ................................................... +c +c +c +c , +c cv , bien que dependant de j uniquement,sera ici indice aussi en i +c pour un adressage plus facile en ij . +c +c +c +c ************** aux points u et v , ***************** +c xprimu et xprimv sont respectivement les valeurs de dx/dX +c yprimu et yprimv . . . . . . . . . . . dy/dY +c rlatu et rlatv . . . . . . . . . . .la latitude +c cvu et cv . . . . . . . . . . . cv +c +c ************** aux points u, v, scalaires, et z **************** +c cu, cuv, cuscal, cuz sont respectiv. les valeurs de cu +c +c +c +c Exemple de distribution de variables sur la grille dans le +c domaine de travail ( X,Y ) . +c ................................................................ +c DX=DY= 1 +c +c +c + represente un point scalaire ( p.exp la pression ) +c > represente la composante zonale du vent +c V represente la composante meridienne du vent +c o represente la vorticite +c +c ---- , car aux poles , les comp.zonales covariantes sont nulles +c +c +c +c i -> +c +c 1 2 3 4 5 6 7 8 +c j +c v 1 + ---- + ---- + ---- + ---- + ---- + ---- + ---- + -- +c +c V o V o V o V o V o V o V o V o +c +c 2 + > + > + > + > + > + > + > + > +c +c V o V o V o V o V o V o V o V o +c +c 3 + > + > + > + > + > + > + > + > +c +c V o V o V o V o V o V o V o V o +c +c 4 + > + > + > + > + > + > + > + > +c +c V o V o V o V o V o V o V o V o +c +c 5 + ---- + ---- + ---- + ---- + ---- + ---- + ---- + -- +c +c +c Ci-dessus, on voit que le nombre de pts.en longitude est egal +c a IM = 8 +c De meme , le nombre d'intervalles entre les 2 poles est egal +c a JM = 4 +c +c Les points scalaires ( + ) correspondent donc a des valeurs +c entieres de i ( 1 a IM ) et de j ( 1 a JM +1 ) . +c +c Les vents U ( > ) correspondent a des valeurs semi- +c entieres de i ( 1+ 0.5 a IM+ 0.5) et entieres de j ( 1 a JM+1) +c +c Les vents V ( V ) correspondent a des valeurs entieres +c de i ( 1 a IM ) et semi-entieres de j ( 1 +0.5 a JM +0.5) +c +c +c + WRITE(6,3) + 3 FORMAT( // 10x,' .... INIGEOM date du 01/06/98 ..... ', + * //5x,' Calcul des elongations cu et cv comme sommes des 4 ' / + * 5x,' elong. cuij1, .. 4 , cvij1,.. 4 qui les entourent , aux + * '/ 5x,' memes endroits que les aires aireij1,...j4 . ' / ) +c +c + IF( nitergdiv.NE.2 ) THEN + gamdi_gdiv = coefdis/ ( float(nitergdiv) -2. ) + ELSE + gamdi_gdiv = 0. + ENDIF + IF( nitergrot.NE.2 ) THEN + gamdi_grot = coefdis/ ( float(nitergrot) -2. ) + ELSE + gamdi_grot = 0. + ENDIF + IF( niterh.NE.2 ) THEN + gamdi_h = coefdis/ ( float(niterh) -2. ) + ELSE + gamdi_h = 0. + ENDIF + + WRITE(6,*) ' gamdi_gd ',gamdi_gdiv,gamdi_grot,gamdi_h,coefdis, + * nitergdiv,nitergrot,niterh +c + pi = 2.* ASIN(1.) +c + WRITE(6,990) + +c ---------------------------------------------------------------- +c + IF( .NOT.fxyhypb ) THEN +c +c + IF( ysinus ) THEN +c + WRITE(6,*) ' *** Inigeom , Y = Sinus ( Latitude ) *** ' +c +c .... utilisation de f(x,y ) avec y = sinus de la latitude ..... + + CALL fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + ELSE +c + WRITE(6,*) '*** Inigeom , Y = Latitude , der. sinusoid . ***' + +c .... utilisation de f(x,y) a tangente sinusoidale , y etant la latit. ... +c + + pxo = clon *pi /180. + pyo = 2.* clat* pi /180. +c +c .... determination de transx ( pour le zoom ) par Newton-Raphson ... +c + itmax = 10 + eps = .1e-7 +c + xo1 = 0. + DO 10 iter = 1, itmax + x1 = xo1 + f = x1+ alphax *SIN(x1-pxo) + df = 1.+ alphax *COS(x1-pxo) + x1 = x1 - f/df + xdm = ABS( x1- xo1 ) + IF( xdm.LE.eps )GO TO 11 + xo1 = x1 + 10 CONTINUE + 11 CONTINUE +c + transx = xo1 + + itmay = 10 + eps = .1e-7 +C + yo1 = 0. + DO 15 iter = 1,itmay + y1 = yo1 + f = y1 + alphay* SIN(y1-pyo) + df = 1. + alphay* COS(y1-pyo) + y1 = y1 -f/df + ydm = ABS(y1-yo1) + IF(ydm.LE.eps) GO TO 17 + yo1 = y1 + 15 CONTINUE +c + 17 CONTINUE + transy = yo1 + + CALL fxy ( rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + ENDIF +c + ELSE +c +c .... Utilisation de fxyhyper , f(x,y) a derivee tangente hyperbol. +c ..................................................................... + + WRITE(6,*)'*** Inigeom , Y = Latitude , der.tg. hyperbolique ***' + + CALL fxyhyper( clat, grossismy, dzoomy, tauy , + , clon, grossismx, dzoomx, taux , + , rlatu,yprimu,rlatv, yprimv,rlatu1, yprimu1,rlatu2,yprimu2 , + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025 ) + + + ENDIF +c +c ------------------------------------------------------------------- + +c + rlatu(1) = ASIN(1.) + rlatu(jjp1) = - rlatu(1) +c +c +c .... calcul aux poles .... +c + yprimu(1) = 0. + yprimu(jjp1) = 0. +c +c + un4rad2 = 0.25 * rad * rad +c +c -------------------------------------------------------------------- +c -------------------------------------------------------------------- +c - - +c - calcul des aires ( aire,aireu,airev, 1./aire, 1./airez ) - +c - et de fext , force de coriolis extensive . - +c - - +c -------------------------------------------------------------------- +c -------------------------------------------------------------------- +c +c +c +c A 1 point scalaire P (i,j) de la grille, reguliere en (X,Y) , sont +c affectees 4 aires entourant P , calculees respectivement aux points +c ( i + 1/4, j - 1/4 ) : aireij1 (i,j) +c ( i + 1/4, j + 1/4 ) : aireij2 (i,j) +c ( i - 1/4, j + 1/4 ) : aireij3 (i,j) +c ( i - 1/4, j - 1/4 ) : aireij4 (i,j) +c +c , +c Les cotes de chacun de ces 4 carres etant egaux a 1/2 suivant (X,Y). +c Chaque aire centree en 1 point scalaire P(i,j) est egale a la somme +c des 4 aires aireij1,aireij2,aireij3,aireij4 qui sont affectees au +c point (i,j) . +c On definit en outre les coefficients alpha comme etant egaux a +c (aireij / aire), c.a.d par exp. alpha1(i,j)=aireij1(i,j)/aire(i,j) +c +c De meme, toute aire centree en 1 point U est egale a la somme des +c 4 aires aireij1,aireij2,aireij3,aireij4 entourant le point U . +c Idem pour airev, airez . +c +c On a ,pour chaque maille : dX = dY = 1 +c +c +c . V +c +c aireij4 . . aireij1 +c +c U . . P . U +c +c aireij3 . . aireij2 +c +c . V +c +c +c +c +c +c .................................................................... +c +c Calcul des 4 aires elementaires aireij1,aireij2,aireij3,aireij4 +c qui entourent chaque aire(i,j) , ainsi que les 4 elongations elemen +c taires cuij et les 4 elongat. cvij qui sont calculees aux memes +c endroits que les aireij . +c +c .................................................................... +c +c ....... do 35 : boucle sur les jjm + 1 latitudes ..... +c +c + DO 35 j = 1, jjp1 +c + IF ( j. eq. 1 ) THEN +c + yprm = yprimu1(j) + rlatm = rlatu1(j) +c + coslatm = COS( rlatm ) + radclatm = 0.5* rad * coslatm +c + DO 30 i = 1, iim + xprp = xprimp025( i ) + xprm = xprimm025( i ) + aireij2( i,1 ) = un4rad2 * coslatm * xprp * yprm + aireij3( i,1 ) = un4rad2 * coslatm * xprm * yprm + cuij2 ( i,1 ) = radclatm * xprp + cuij3 ( i,1 ) = radclatm * xprm + cvij2 ( i,1 ) = 0.5* rad * yprm + cvij3 ( i,1 ) = cvij2(i,1) + 30 CONTINUE +c + DO i = 1, iim + aireij1( i,1 ) = 0. + aireij4( i,1 ) = 0. + cuij1 ( i,1 ) = 0. + cuij4 ( i,1 ) = 0. + cvij1 ( i,1 ) = 0. + cvij4 ( i,1 ) = 0. + ENDDO +c + END IF +c + IF ( j. eq. jjp1 ) THEN + yprp = yprimu2(j-1) + rlatp = rlatu2 (j-1) +ccc yprp = fyprim( FLOAT(j) - 0.25 ) +ccc rlatp = fy ( FLOAT(j) - 0.25 ) +c + coslatp = COS( rlatp ) + radclatp = 0.5* rad * coslatp +c + DO 31 i = 1,iim + xprp = xprimp025( i ) + xprm = xprimm025( i ) + aireij1( i,jjp1 ) = un4rad2 * coslatp * xprp * yprp + aireij4( i,jjp1 ) = un4rad2 * coslatp * xprm * yprp + cuij1(i,jjp1) = radclatp * xprp + cuij4(i,jjp1) = radclatp * xprm + cvij1(i,jjp1) = 0.5 * rad* yprp + cvij4(i,jjp1) = cvij1(i,jjp1) + 31 CONTINUE +c + DO i = 1, iim + aireij2( i,jjp1 ) = 0. + aireij3( i,jjp1 ) = 0. + cvij2 ( i,jjp1 ) = 0. + cvij3 ( i,jjp1 ) = 0. + cuij2 ( i,jjp1 ) = 0. + cuij3 ( i,jjp1 ) = 0. + ENDDO +c + END IF +c + + IF ( j .gt. 1 .AND. j .lt. jjp1 ) THEN +c + rlatp = rlatu2 ( j-1 ) + yprp = yprimu2( j-1 ) + rlatm = rlatu1 ( j ) + yprm = yprimu1( j ) +cc rlatp = fy ( FLOAT(j) - 0.25 ) +cc yprp = fyprim( FLOAT(j) - 0.25 ) +cc rlatm = fy ( FLOAT(j) + 0.25 ) +cc yprm = fyprim( FLOAT(j) + 0.25 ) + + coslatm = COS( rlatm ) + coslatp = COS( rlatp ) + radclatp = 0.5* rad * coslatp + radclatm = 0.5* rad * coslatm +c + DO 32 i = 1,iim + xprp = xprimp025( i ) + xprm = xprimm025( i ) + + ai14 = un4rad2 * coslatp * yprp + ai23 = un4rad2 * coslatm * yprm + aireij1 ( i,j ) = ai14 * xprp + aireij2 ( i,j ) = ai23 * xprp + aireij3 ( i,j ) = ai23 * xprm + aireij4 ( i,j ) = ai14 * xprm + cuij1 ( i,j ) = radclatp * xprp + cuij2 ( i,j ) = radclatm * xprp + cuij3 ( i,j ) = radclatm * xprm + cuij4 ( i,j ) = radclatp * xprm + cvij1 ( i,j ) = 0.5* rad * yprp + cvij2 ( i,j ) = 0.5* rad * yprm + cvij3 ( i,j ) = cvij2(i,j) + cvij4 ( i,j ) = cvij1(i,j) + 32 CONTINUE +c + END IF +c +c ........ periodicite ............ +c + cvij1 (iip1,j) = cvij1 (1,j) + cvij2 (iip1,j) = cvij2 (1,j) + cvij3 (iip1,j) = cvij3 (1,j) + cvij4 (iip1,j) = cvij4 (1,j) + cuij1 (iip1,j) = cuij1 (1,j) + cuij2 (iip1,j) = cuij2 (1,j) + cuij3 (iip1,j) = cuij3 (1,j) + cuij4 (iip1,j) = cuij4 (1,j) + aireij1 (iip1,j) = aireij1 (1,j ) + aireij2 (iip1,j) = aireij2 (1,j ) + aireij3 (iip1,j) = aireij3 (1,j ) + aireij4 (iip1,j) = aireij4 (1,j ) + + 35 CONTINUE +c +c .............................................................. +c + DO 37 j = 1, jjp1 + DO 36 i = 1, iim + aire ( i,j ) = aireij1(i,j) + aireij2(i,j) + aireij3(i,j) + + * aireij4(i,j) + alpha1 ( i,j ) = aireij1(i,j) / aire(i,j) + alpha2 ( i,j ) = aireij2(i,j) / aire(i,j) + alpha3 ( i,j ) = aireij3(i,j) / aire(i,j) + alpha4 ( i,j ) = aireij4(i,j) / aire(i,j) + alpha1p2( i,j ) = alpha1 (i,j) + alpha2 (i,j) + alpha1p4( i,j ) = alpha1 (i,j) + alpha4 (i,j) + alpha2p3( i,j ) = alpha2 (i,j) + alpha3 (i,j) + alpha3p4( i,j ) = alpha3 (i,j) + alpha4 (i,j) + 36 CONTINUE +c +c + aire (iip1,j) = aire (1,j) + alpha1 (iip1,j) = alpha1 (1,j) + alpha2 (iip1,j) = alpha2 (1,j) + alpha3 (iip1,j) = alpha3 (1,j) + alpha4 (iip1,j) = alpha4 (1,j) + alpha1p2(iip1,j) = alpha1p2(1,j) + alpha1p4(iip1,j) = alpha1p4(1,j) + alpha2p3(iip1,j) = alpha2p3(1,j) + alpha3p4(iip1,j) = alpha3p4(1,j) + 37 CONTINUE +c + + DO 42 j = 1,jjp1 + DO 41 i = 1,iim + aireu (i,j)= aireij1(i,j) + aireij2(i,j) + aireij4(i+1,j) + + * aireij3(i+1,j) + unsaire ( i,j)= 1./ aire(i,j) + unsair_gam1( i,j)= unsaire(i,j)** ( - gamdi_gdiv ) + unsair_gam2( i,j)= unsaire(i,j)** ( - gamdi_h ) + airesurg ( i,j)= aire(i,j)/ g + 41 CONTINUE + aireu (iip1,j) = aireu (1,j) + unsaire (iip1,j) = unsaire(1,j) + unsair_gam1(iip1,j) = unsair_gam1(1,j) + unsair_gam2(iip1,j) = unsair_gam2(1,j) + airesurg (iip1,j) = airesurg(1,j) + 42 CONTINUE +c +c + DO 48 j = 1,jjm +c + DO i=1,iim + airev (i,j) = aireij2(i,j)+ aireij3(i,j)+ aireij1(i,j+1) + + * aireij4(i,j+1) + ENDDO + DO i=1,iim + airez = aireij2(i,j)+aireij1(i,j+1)+aireij3(i+1,j) + + * aireij4(i+1,j+1) + unsairez(i,j) = 1./ airez + unsairz_gam(i,j)= unsairez(i,j)** ( - gamdi_grot ) + fext (i,j) = airez * SIN(rlatv(j))* 2.* omeg + ENDDO + airev (iip1,j) = airev(1,j) + unsairez (iip1,j) = unsairez(1,j) + fext (iip1,j) = fext(1,j) + unsairz_gam(iip1,j) = unsairz_gam(1,j) +c + 48 CONTINUE +c +c +c ..... Calcul des elongations cu,cv, cvu ......... +c + DO j = 1, jjm + DO i = 1, iim + cv(i,j) = 0.5 *( cvij2(i,j)+cvij3(i,j)+cvij1(i,j+1)+cvij4(i,j+1)) + cvu(i,j)= 0.5 *( cvij1(i,j)+cvij4(i,j)+cvij2(i,j) +cvij3(i,j) ) + cuv(i,j)= 0.5 *( cuij2(i,j)+cuij3(i,j)+cuij1(i,j+1)+cuij4(i,j+1)) + unscv2(i,j) = 1./ ( cv(i,j)*cv(i,j) ) + ENDDO + DO i = 1, iim + cuvsurcv (i,j) = airev(i,j) * unscv2(i,j) + cvsurcuv (i,j) = 1./cuvsurcv(i,j) + cuvscvgam1(i,j) = cuvsurcv (i,j) ** ( - gamdi_gdiv ) + cuvscvgam2(i,j) = cuvsurcv (i,j) ** ( - gamdi_h ) + cvscuvgam(i,j) = cvsurcuv (i,j) ** ( - gamdi_grot ) + ENDDO + cv (iip1,j) = cv (1,j) + cvu (iip1,j) = cvu (1,j) + unscv2 (iip1,j) = unscv2 (1,j) + cuv (iip1,j) = cuv (1,j) + cuvsurcv (iip1,j) = cuvsurcv (1,j) + cvsurcuv (iip1,j) = cvsurcuv (1,j) + cuvscvgam1(iip1,j) = cuvscvgam1(1,j) + cuvscvgam2(iip1,j) = cuvscvgam2(1,j) + cvscuvgam(iip1,j) = cvscuvgam(1,j) + ENDDO + + DO j = 2, jjm + DO i = 1, iim + cu(i,j) = 0.5*(cuij1(i,j)+cuij4(i+1,j)+cuij2(i,j)+cuij3(i+1,j)) + unscu2 (i,j) = 1./ ( cu(i,j) * cu(i,j) ) + cvusurcu (i,j) = aireu(i,j) * unscu2(i,j) + cusurcvu (i,j) = 1./ cvusurcu(i,j) + cvuscugam1 (i,j) = cvusurcu(i,j) ** ( - gamdi_gdiv ) + cvuscugam2 (i,j) = cvusurcu(i,j) ** ( - gamdi_h ) + cuscvugam (i,j) = cusurcvu(i,j) ** ( - gamdi_grot ) + ENDDO + cu (iip1,j) = cu(1,j) + unscu2 (iip1,j) = unscu2(1,j) + cvusurcu (iip1,j) = cvusurcu(1,j) + cusurcvu (iip1,j) = cusurcvu(1,j) + cvuscugam1(iip1,j) = cvuscugam1(1,j) + cvuscugam2(iip1,j) = cvuscugam2(1,j) + cuscvugam (iip1,j) = cuscvugam(1,j) + ENDDO + +c +c .... calcul aux poles .... +c + DO i = 1, iip1 + cu ( i, 1 ) = 0. + unscu2( i, 1 ) = 0. + cvu ( i, 1 ) = 0. +c + cu (i, jjp1) = 0. + unscu2(i, jjp1) = 0. + cvu (i, jjp1) = 0. + ENDDO +c +c .............................................................. +c + DO j = 1, jjm + DO i= 1, iim + airvscu2 (i,j) = airev(i,j)/ ( cuv(i,j) * cuv(i,j) ) + aivscu2gam(i,j) = airvscu2(i,j)** ( - gamdi_grot ) + ENDDO + airvscu2 (iip1,j) = airvscu2(1,j) + aivscu2gam(iip1,j) = aivscu2gam(1,j) + ENDDO + + DO j=2,jjm + DO i=1,iim + airuscv2 (i,j) = aireu(i,j)/ ( cvu(i,j) * cvu(i,j) ) + aiuscv2gam (i,j) = airuscv2(i,j)** ( - gamdi_grot ) + ENDDO + airuscv2 (iip1,j) = airuscv2 (1,j) + aiuscv2gam(iip1,j) = aiuscv2gam(1,j) + ENDDO + +c +c calcul des aires aux poles : +c ----------------------------- +c + apoln = SSUM(iim,aire(1,1),1) + apols = SSUM(iim,aire(1,jjp1),1) + unsapolnga1 = 1./ ( apoln ** ( - gamdi_gdiv ) ) + unsapolsga1 = 1./ ( apols ** ( - gamdi_gdiv ) ) + unsapolnga2 = 1./ ( apoln ** ( - gamdi_h ) ) + unsapolsga2 = 1./ ( apols ** ( - gamdi_h ) ) +c +c----------------------------------------------------------------------- +c gtitre='Coriolis version ancienne' +c gfichier='fext1' +c CALL writestd(fext,iip1*jjm) +c +c changement F. Hourdin calcul conservatif pour fext +c constang contient le produit a * cos ( latitude ) * omega +c + DO i=1,iim + constang(i,1) = 0. + ENDDO + DO j=1,jjm-1 + DO i=1,iim + constang(i,j+1) = rad*omeg*cu(i,j+1)*COS(rlatu(j+1)) + ENDDO + ENDDO + DO i=1,iim + constang(i,jjp1) = 0. + ENDDO +c +c periodicite en longitude +c + DO j=1,jjm + fext(iip1,j) = fext(1,j) + ENDDO + DO j=1,jjp1 + constang(iip1,j) = constang(1,j) + ENDDO + +c fin du changement + +c +c----------------------------------------------------------------------- +c + WRITE(6,*) ' *** Coordonnees de la grille *** ' + WRITE(6,995) +c + WRITE(6,*) ' LONGITUDES aux pts. V ( degres ) ' + WRITE(6,995) + DO i=1,iip1 + rlonvv(i) = rlonv(i)*180./pi + ENDDO + WRITE(6,400) rlonvv +c + WRITE(6,995) + WRITE(6,*) ' LATITUDES aux pts. V ( degres ) ' + WRITE(6,995) + DO i=1,jjm + rlatuu(i)=rlatv(i)*180./pi + ENDDO + WRITE(6,400) (rlatuu(i),i=1,jjm) +c + DO i=1,iip1 + rlonvv(i)=rlonu(i)*180./pi + ENDDO + WRITE(6,995) + WRITE(6,*) ' LONGITUDES aux pts. U ( degres ) ' + WRITE(6,995) + WRITE(6,400) rlonvv + WRITE(6,995) + + WRITE(6,*) ' LATITUDES aux pts. U ( degres ) ' + WRITE(6,995) + DO i=1,jjp1 + rlatuu(i)=rlatu(i)*180./pi + ENDDO + WRITE(6,400) (rlatuu(i),i=1,jjp1) + WRITE(6,995) +c +444 format(f10.3,f6.0) +400 FORMAT(1x,8f8.2) +990 FORMAT(//) +995 FORMAT(/) +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inigrads.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inigrads.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inigrads.F (revision 1280) @@ -0,0 +1,92 @@ +! +! $Header$ +! + subroutine inigrads(if,im + s ,x,fx,xmin,xmax,jm,y,ymin,ymax,fy,lm,z,fz + s ,dt,file,titlel) + + + implicit none + + integer if,im,jm,lm,i,j,l,lnblnk + real x(im),y(jm),z(lm),fx,fy,fz,dt + real xmin,xmax,ymin,ymax + + character file*10,titlel*40 + +#include "gradsdef.h" + +c data unit/66,32,34,36,38,40,42,44,46,48/ + integer nf + save nf + data nf/0/ + + unit(1)=66 + unit(2)=32 + unit(3)=34 + unit(4)=36 + unit(5)=38 + unit(6)=40 + unit(7)=42 + unit(8)=44 + unit(9)=46 + + if (if.le.nf) stop'verifier les appels a inigrads' + + print*,'Entree dans inigrads' + + nf=if + title(if)=titlel + ivar(if)=0 + + fichier(if)=file(1:lnblnk(file)) + + firsttime(if)=.true. + dtime(if)=dt + + iid(if)=1 + ifd(if)=im + imd(if)=im + do i=1,im + xd(i,if)=x(i)*fx + if(xd(i,if).lt.xmin) iid(if)=i+1 + if(xd(i,if).le.xmax) ifd(if)=i + enddo + print*,'On stoke du point ',iid(if),' a ',ifd(if),' en x' + + jid(if)=1 + jfd(if)=jm + jmd(if)=jm + do j=1,jm + yd(j,if)=y(j)*fy + if(yd(j,if).gt.ymax) jid(if)=j+1 + if(yd(j,if).ge.ymin) jfd(if)=j + enddo + print*,'On stoke du point ',jid(if),' a ',jfd(if),' en y' + + print*,'Open de dat' + print*,'file=',file + print*,'fichier(if)=',fichier(if) + + print*,4*(ifd(if)-iid(if))*(jfd(if)-jid(if)) + print*,file(1:lnblnk(file))//'.dat' + + OPEN (unit(if)+1,FILE=file(1:lnblnk(file))//'.dat' + s ,FORM='unformatted', + s ACCESS='direct' + s ,RECL=4*(ifd(if)-iid(if)+1)*(jfd(if)-jid(if)+1)) + + print*,'Open de dat ok' + + lmd(if)=lm + do l=1,lm + zd(l,if)=z(l)*fz + enddo + + irec(if)=0 + + print*,if,imd(if),jmd(if),lmd(if) + print*,'if,imd(if),jmd(if),lmd(if)' + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/iniprint.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/iniprint.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/iniprint.h (revision 1280) @@ -0,0 +1,11 @@ +! +! $Header$ +! +! +! gestion des impressions de sorties et de débogage +! lunout: unité du fichier dans lequel se font les sorties +! (par defaut 6, la sortie standard) +! prt_level: niveau d'impression souhaité (0 = minimum) +! + INTEGER lunout, prt_level + COMMON /comprint/ lunout, prt_level Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/initdynav_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/initdynav_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/initdynav_p.F (revision 1280) @@ -0,0 +1,204 @@ +! +! $Id$ +! + subroutine initdynav_p(infile,day0,anne0,tstep,t_ops,t_wrt,fileid) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE IOIPSL +#endif + use parallel + use Write_field + use misc_mod + USE infotrac + + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL. Initialisation du fichier histoire moyenne. +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C infile: nom du fichier histoire a creer +C day0,anne0: date de reference +C tstep : frequence d'ecriture +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C +C Sortie: +C fileid: ID du fichier netcdf cree +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C Arguments +C + character*(*) infile + integer*4 day0, anne0 + real tstep, t_ops, t_wrt + integer fileid + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + integer thoriid, zvertiid + integer tau0 + real zjulian + integer iq + real rlong(iip1,jjp1), rlat(iip1,jjp1) + integer ii,jj + integer zan, dayref + integer :: jjb,jje,jjn + +! definition du domaine d'ecriture pour le rebuild + + INTEGER,DIMENSION(2) :: ddid + INTEGER,DIMENSION(2) :: dsg + INTEGER,DIMENSION(2) :: dsl + INTEGER,DIMENSION(2) :: dpf + INTEGER,DIMENSION(2) :: dpl + INTEGER,DIMENSION(2) :: dhs + INTEGER,DIMENSION(2) :: dhe + + INTEGER :: dynave_domain_id + + if (adjust) return +C +C Initialisations +C + pi = 4. * atan (1.) +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = anne0 + dayref = day0 + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjp1 /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynave_domain_id) + + call histbeg(trim(infile),iip1, rlong(:,1), jjn, rlat(1,jjb:jje), + . 1, iip1, 1, jjn,tau0, zjulian, tstep, thoriid, + . fileid,dynave_domain_id) + +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'sigss', 'Niveaux sigma','Pa', + . llm, nivsigs, zvertiid) +C +C Appels a histdef pour la definition des variables a sauvegarder +C +C Vents U +C + write(6,*)'inithistave',tstep + call histdef(fileid, 'u', 'vents u scalaires moyennes', + . 'm/s', iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + +C +C Vents V +C + call histdef(fileid, 'v', 'vents v scalaires moyennes', + . 'm/s', iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + +C +C Temperature +C + call histdef(fileid, 'temp', 'temperature moyennee', 'K', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Temperature potentielle +C + call histdef(fileid, 'theta', 'temperature potentielle', 'K', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + + +C +C Geopotentiel +C + call histdef(fileid, 'phi', 'geopotentiel moyenne', '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Traceurs +C + DO iq=1,nqtot + call histdef(fileid, ttext(iq), ttext(iq), '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + enddo +C +C Masse +C + call histdef(fileid, 'masse', 'masse', 'kg', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(fileid, 'phis', 'geopotentiel au sol', '-', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Fin +C + call histend(fileid) +#else + write(lunout,*)'initdynav_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/initfluxsto_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/initfluxsto_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/initfluxsto_p.F (revision 1280) @@ -0,0 +1,296 @@ +! +! $Id$ +! + subroutine initfluxsto_p + . (infile,tstep,t_ops,t_wrt, + . fileid,filevid,filedid) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE IOIPSL +#endif + use parallel + use Write_field + use misc_mod + + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C infile: nom du fichier histoire a creer +C day0,anne0: date de reference +C tstep: duree du pas de temps en seconde +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C +C Sortie: +C fileid: ID du fichier netcdf cree +C filevid:ID du fichier netcdf pour la grille v +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C Arguments +C + character*(*) infile + real tstep, t_ops, t_wrt + integer fileid, filevid,filedid + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + real nivd(1) + integer tau0 + real zjulian + character*3 str + character*10 ctrac + integer iq + real rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1) + integer uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid + integer ii,jj + integer zan, idayref + logical ok_sync + integer :: jjb,jje,jjn + +! definition du domaine d'ecriture pour le rebuild + + INTEGER,DIMENSION(2) :: ddid + INTEGER,DIMENSION(2) :: dsg + INTEGER,DIMENSION(2) :: dsl + INTEGER,DIMENSION(2) :: dpf + INTEGER,DIMENSION(2) :: dpl + INTEGER,DIMENSION(2) :: dhs + INTEGER,DIMENSION(2) :: dhe + + INTEGER :: dynu_domain_id + INTEGER :: dynv_domain_id + +C +C Initialisations +C + pi = 4. * atan (1.) + str='q ' + ctrac = 'traceur ' + ok_sync = .true. +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = annee_ref + idayref = day_ref + CALL ymds2ju(zan, 1, idayref, 0.0, zjulian) + tau0 = itau_dyn + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonu(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjp1 /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynu_domain_id) + + call histbeg(trim(infile),iip1, rlong(:,1), jjn, rlat(1,jjb:jje), + . 1, iip1, 1, jjn, tau0, zjulian, tstep, uhoriid, + . fileid,dynu_domain_id) +C +C Creation du fichier histoire pour la grille en V (oblige pour l'instant, +C IOIPSL ne permet pas de grilles avec des nombres de point differents dans +C un meme fichier) + + + do jj = 1, jjm + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatv(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + if (pole_sud) jje=jj_end-1 + if (pole_sud) jjn=jj_nb-1 + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjm /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynv_domain_id) + + call histbeg('fluxstokev',iip1, rlong(:,1), jjn, rlat(1,jjb:jje), + . 1, iip1, 1, jjn,tau0, zjulian, tstep, vhoriid, + . filevid,dynv_domain_id) + + rl(1,1) = 1. + + if (mpi_rank==0) then + + call histbeg('defstoke.nc', 1, rl, 1, rl, + . 1, 1, 1, 1, + . tau0, zjulian, tstep, dhoriid, filedid) + + endif +C +C Appel a histhori pour rajouter les autres grilles horizontales +C + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + call histhori(fileid, iip1, rlong(:,jjb:jje),jjn,rlat(:,jjb:jje), + . 'scalar','Grille points scalaires', thoriid) + +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'sig_s', 'Niveaux sigma', + . 'sigma_level', + . llm, nivsigs, zvertiid) +C Pour le fichier V + call histvert(filevid, 'sig_s', 'Niveaux sigma', + . 'sigma_level', + . llm, nivsigs, zvertiid) +c pour le fichier def + nivd(1) = 1 + call histvert(filedid, 'sig_s', 'Niveaux sigma', + . 'sigma_level', + . 1, nivd, dvertiid) + +C +C Appels a histdef pour la definition des variables a sauvegarder + + CALL histdef(fileid, "phis", "Surface geop. height", "-", + . iip1,jjn,thoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(fileid, "aire", "Grid area", "-", + . iip1,jjn,thoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + if (mpi_rank==0) then + + CALL histdef(filedid, "dtvr", "tps dyn", "s", + . 1,1,dhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(filedid, "istdyn", "tps stock", "s", + . 1,1,dhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(filedid, "istphy", "tps stock phy", "s", + . 1,1,dhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + endif +C +C Masse +C + call histdef(fileid, 'masse', 'Masse', 'kg', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Pbaru +C + call histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s', + . iip1, jjn, uhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +C +C Pbarv +C + if (pole_sud) jjn=jj_nb-1 + + call histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s', + . iip1, jjn, vhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C w +C + if (pole_sud) jjn=jj_nb + call histdef(fileid, 'w', 'flx de masse vert', 'kg m/s', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +C +C Temperature potentielle +C + call histdef(fileid, 'teta', 'temperature potentielle', '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C + +C +C Geopotentiel +C + call histdef(fileid, 'phi', 'geopotentiel instantane', '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Fin +C + call histend(fileid) + call histend(filevid) + call histend(filedid) + if (ok_sync) then + call histsync(fileid) + call histsync(filevid) + call histsync(filedid) + endif + +#else + write(lunout,*)'initfluxsto_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inithist_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inithist_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inithist_p.F (revision 1280) @@ -0,0 +1,257 @@ +! +! $Id$ +! + subroutine inithist_p(infile,day0,anne0,tstep,t_ops,t_wrt, + . fileid,filevid) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE IOIPSL +#endif + use parallel + use Write_field + use misc_mod + USE infotrac + + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C infile: nom du fichier histoire a creer +C day0,anne0: date de reference +C tstep: duree du pas de temps en seconde +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C +C Sortie: +C fileid: ID du fichier netcdf cree +C filevid:ID du fichier netcdf pour la grille v +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C Arguments +C + character*(*) infile + integer*4 day0, anne0 + real tstep, t_ops, t_wrt + integer fileid, filevid + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + integer tau0 + real zjulian + integer iq + real rlong(iip1,jjp1), rlat(iip1,jjp1) + integer uhoriid, vhoriid, thoriid, zvertiid + integer ii,jj + integer zan, dayref + integer :: jjb,jje,jjn + +! definition du domaine d'ecriture pour le rebuild + + INTEGER,DIMENSION(2) :: ddid + INTEGER,DIMENSION(2) :: dsg + INTEGER,DIMENSION(2) :: dsl + INTEGER,DIMENSION(2) :: dpf + INTEGER,DIMENSION(2) :: dpl + INTEGER,DIMENSION(2) :: dhs + INTEGER,DIMENSION(2) :: dhe + + INTEGER :: dynu_domain_id + INTEGER :: dynv_domain_id + +C +C Initialisations +C + if (adjust) return + + pi = 4. * atan (1.) +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = anne0 + dayref = day0 + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonu(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjp1 /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynu_domain_id) + + call histbeg(trim(infile),iip1, rlong(:,1), jjn, + . rlat(1,jjb:jje), 1, iip1, 1, jjn, tau0, + . zjulian, tstep, uhoriid, fileid,dynu_domain_id) +C +C Creation du fichier histoire pour la grille en V (oblige pour l'instant, +C IOIPSL ne permet pas de grilles avec des nombres de point differents dans +C un meme fichier) + + do jj = 1, jjm + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatv(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + if (pole_sud) jje=jj_end-1 + if (pole_sud) jjn=jj_nb-1 + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjm /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynv_domain_id) + + call histbeg('dyn_histv', iip1, rlong(:,1), jjn, rlat(1,jjb:jje), + . 1, iip1, 1, jjn, tau0, zjulian, tstep, vhoriid, + . filevid,dynv_domain_id) +C +C Appel a histhori pour rajouter les autres grilles horizontales +C + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + call histhori(fileid, iip1, rlong(:,jjb:jje),jjn,rlat(:,jjb:jje), + . 'scalar','Grille points scalaires', thoriid) +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'sig_s', 'Niveaux sigma','-', + . llm, nivsigs, zvertiid) +C Pour le fichier V + call histvert(filevid, 'sig_s', 'Niveaux sigma','-', + . llm, nivsigs, zvertiid) +C +C Appels a histdef pour la definition des variables a sauvegarder +C +C Vents U +C + jjn=jj_nb + + call histdef(fileid, 'ucov', 'vents u covariants', 'm/s', + . iip1, jjn, uhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Vents V +C + if (pole_sud) jjn=jj_nb-1 + + call histdef(filevid, 'vcov', 'vents v covariants', 'm/s', + . iip1, jjn, vhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +C +C Temperature potentielle +C + jjn=jj_nb + + call histdef(fileid, 'teta', 'temperature potentielle', '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Geopotentiel +C + call histdef(fileid, 'phi', 'geopotentiel instantane', '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Traceurs +C + DO iq=1,nqtot + call histdef(fileid, ttext(iq), ttext(iq), '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + enddo +C +C Masse +C + call histdef(fileid, 'masse', 'masse', 'kg', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(fileid, 'phis', 'geopotentiel au sol', '-', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Fin +C + call histend(fileid) + call histend(filevid) +#else + write(lunout,*)'inithist_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/initial0.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/initial0.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/initial0.F (revision 1280) @@ -0,0 +1,12 @@ +! +! $Header$ +! + SUBROUTINE initial0(n,x) + IMPLICIT NONE + INTEGER n,i + REAL x(n) + DO 10 i=1,n + x(i)=0. +10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/integrd_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/integrd_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/integrd_p.F (revision 1280) @@ -0,0 +1,371 @@ +! +! $Id$ +! + SUBROUTINE integrd_p + $ ( nq,vcovm1,ucovm1,tetam1,psm1,massem1, + $ dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps0,masse,phis,finvmaold) + USE parallel + IMPLICIT NONE + + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c objet: +c ------ +c +c Incrementation des tendances dynamiques +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" +#include "logic.h" +#include "temps.h" +#include "serre.h" +#include "control.h" + +c Arguments: +c ---------- + + INTEGER nq + + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nq) + REAL ps0(ip1jmp1),masse(ip1jmp1,llm),phis(ip1jmp1) + + REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm) + REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1),massem1(ip1jmp1,llm) + + REAL dv(ip1jm,llm),du(ip1jmp1,llm) + REAL dteta(ip1jmp1,llm),dp(ip1jmp1) + REAL dq(ip1jmp1,llm,nq), finvmaold(ip1jmp1,llm) + +c Local: +c ------ + + REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1) + REAL massescr( ip1jmp1,llm ), finvmasse(ip1jmp1,llm) + REAL,SAVE :: p(ip1jmp1,llmp1) + REAL tpn,tps,tppn(iim),tpps(iim) + REAL qpn,qps,qppn(iim),qpps(iim) + REAL,SAVE :: deltap( ip1jmp1,llm ) + + INTEGER l,ij,iq + + REAL SSUM + EXTERNAL SSUM + INTEGER ijb,ije,jjb,jje + REAL,SAVE :: ps(ip1jmp1) + LOGICAL :: checksum + INTEGER :: stop_it +c----------------------------------------------------------------------- +c$OMP BARRIER + if (pole_nord) THEN +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + DO ij = 1,iip1 + ucov( ij , l) = 0. + uscr( ij ) = 0. + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDIF + + if (pole_sud) THEN +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + DO ij = 1,iip1 + ucov( ij +ip1jm, l) = 0. + uscr( ij +ip1jm ) = 0. + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDIF + +c ............ integration de ps .............. + +c CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1) + + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + massescr(ijb:ije,l)=masse(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC) + DO 2 ij = ijb,ije + pscr (ij) = ps0(ij) + ps (ij) = psm1(ij) + dt * dp(ij) + 2 CONTINUE +c$OMP END DO +c$OMP BARRIER +c --> ici synchro OPENMP pour ps + + checksum=.TRUE. + stop_it=0 + +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb,ije + IF( ps(ij).LT.0. ) THEN + IF (checksum) stop_it=ij + checksum=.FALSE. + ENDIF + ENDDO +c$OMP END DO NOWAIT + + IF( .NOT. checksum ) THEN + PRINT*,' Au point ij = ',stop_it, ' , pression sol neg. ' + & , ps(stop_it) + STOP' dans integrd' + ENDIF + +c +C$OMP MASTER + if (pole_nord) THEN + + DO ij = 1, iim + tppn(ij) = aire( ij ) * ps( ij ) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + DO ij = 1, iip1 + ps( ij ) = tpn + ENDDO + + ENDIF + + if (pole_sud) THEN + + DO ij = 1, iim + tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm) + ENDDO + tps = SSUM(iim,tpps,1)/apols + DO ij = 1, iip1 + ps(ij+ip1jm) = tps + ENDDO + + ENDIF +c$OMP END MASTER +c$OMP BARRIER +c +c ... Calcul de la nouvelle masse d'air au dernier temps integre t+1 ... +c + + CALL pression_p ( ip1jmp1, ap, bp, ps, p ) +c$OMP BARRIER + CALL massdair_p ( p , masse ) + +c CALL SCOPY( ijp1llm , masse, 1, finvmasse, 1 ) + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + finvmasse(ijb:ije,l)=masse(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + jjb=jj_begin + jje=jj_end + CALL filtreg_p( finvmasse,jjb,jje, jjp1, llm, -2, 2, .TRUE., 1 ) +c + +c ............ integration de ucov, vcov, h .............. + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,llm + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO 4 ij = ijb,ije + uscr( ij ) = ucov( ij,l ) + ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l ) + 4 CONTINUE + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO 5 ij = ijb,ije + vscr( ij ) = vcov( ij,l ) + vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l ) + 5 CONTINUE + + ijb=ij_begin + ije=ij_end + + DO 6 ij = ijb,ije + hscr( ij ) = teta(ij,l) + teta ( ij,l ) = tetam1(ij,l) * massem1(ij,l) / masse(ij,l) + $ + dt * dteta(ij,l) / masse(ij,l) + 6 CONTINUE + +c .... Calcul de la valeur moyenne, unique aux poles pour teta ...... +c +c + IF (pole_nord) THEN + + DO ij = 1, iim + tppn(ij) = aire( ij ) * teta( ij ,l) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + + DO ij = 1, iip1 + teta( ij ,l) = tpn + ENDDO + + ENDIF + + IF (pole_sud) THEN + + DO ij = 1, iim + tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l) + ENDDO + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + teta(ij+ip1jm,l) = tps + ENDDO + + ENDIF +c + + IF(leapf) THEN +c CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 ) +c CALL SCOPY ( ip1jm, vscr(1), 1, vcovm1(1, l), 1 ) +c CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 ) + ijb=ij_begin + ije=ij_end + ucovm1(ijb:ije,l)=uscr(ijb:ije) + tetam1(ijb:ije,l)=hscr(ijb:ije) + if (pole_sud) ije=ij_end-iip1 + vcovm1(ijb:ije,l)=vscr(ijb:ije) + + END IF + + 10 CONTINUE +c$OMP END DO NOWAIT + +c +c ....... integration de q ...... +c + ijb=ij_begin + ije=ij_end + + if (planet_type.eq."earth") then +! Earth-specific treatment of first 2 tracers (water) +c$OMP BARRIER +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije + deltap(ij,l) = p(ij,l) - p(ij,l+1) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c$OMP BARRIER + + CALL qminimum_p( q, nq, deltap ) + endif ! of if (planet_type.eq."earth") +c +c ..... Calcul de la valeur moyenne, unique aux poles pour q ..... +c +c$OMP BARRIER + IF (pole_nord) THEN + + DO iq = 1, nq + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + + DO ij = 1, iim + qppn(ij) = aire( ij ) * q( ij ,l,iq) + ENDDO + qpn = SSUM(iim,qppn,1)/apoln + + DO ij = 1, iip1 + q( ij ,l,iq) = qpn + ENDDO + + ENDDO +c$OMP END DO NOWAIT + + ENDDO + + ENDIF + + IF (pole_sud) THEN + + DO iq = 1, nq + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + + DO ij = 1, iim + qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq) + ENDDO + qps = SSUM(iim,qpps,1)/apols + + DO ij = 1, iip1 + q(ij+ip1jm,l,iq) = qps + ENDDO + + ENDDO +c$OMP END DO NOWAIT + + ENDDO + + ENDIF + +c CALL SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT +c +c +c ..... FIN de l'integration de q ....... + +15 continue + +c$OMP DO SCHEDULE(STATIC) + DO ij=ijb,ije + ps0(ij)=ps(ij) + ENDDO +c$OMP END DO NOWAIT + +c ................................................................. + + + IF( leapf ) THEN +c CALL SCOPY ( ip1jmp1 , pscr , 1, psm1 , 1 ) +c CALL SCOPY ( ip1jmp1*llm, massescr, 1, massem1, 1 ) +c$OMP DO SCHEDULE(STATIC) + DO ij=ijb,ije + psm1(ij)=pscr(ij) + ENDDO +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + massem1(ijb:ije,l)=massescr(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + END IF +c$OMP BARRIER + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inter_barx.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inter_barx.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inter_barx.F (revision 1280) @@ -0,0 +1,218 @@ +! +! $Header$ +! + SUBROUTINE inter_barx ( idatmax,xidat,fdat,imodmax,ximod,fmod ) + +c .... Auteurs : Robert Sadourny , P. Le Van ..... +c + IMPLICIT NONE +c ---------------------------------------------------------- +c INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES +c VERSION UNIDIMENSIONNELLE , EN LONGITUDE . +c ---------------------------------------------------------- +c +c idat : indice du champ de donnees, de 1 a idatmax +c imod : indice du champ du modele, de 1 a imodmax +c fdat(idat) : champ de donnees (entrees) +c fmod(imod) : champ du modele (sorties) +c xidat(idat): abscisses des interfaces des mailles donnees +c ximod(imod): abscisses des interfaces des mailles modele +c ( L'indice 1 correspond a l'interface mailLE 1 / maille 2) +c ( Les abscisses sont exprimes en degres) + + + INTEGER idatmax, imodmax + REAL xidat(idatmax),fdat(idatmax),ximod(imodmax),fmod(imodmax) + +c ... Variables locales ... + + REAL xxid(idatmax+1), xxd(idatmax+1), fdd(idatmax+1) + REAL fxd(idatmax+1), xchan(idatmax+1), fdchan(idatmax+1) + REAL xxim(imodmax) + + REAL x0,xim0,dx,dxm + REAL chmin,chmax,pi + + INTEGER imod,idat,i,ichang,id0,id1,nid,idatmax1 + + pi = 2. * ASIN(1.) + +c ----------------------------------------------------- +c REDEFINITION DE L'ORIGINE DES ABSCISSES +c A L'INTERFACE OUEST DE LA PREMIERE MAILLE DU MODELE +c ----------------------------------------------------- + DO imod = 1,imodmax + xxim(imod) = ximod(imod) + ENDDO + + CALL minmax( imodmax,xxim,chmin,chmax) + IF( chmax.LT.6.50 ) THEN +c PRINT 3 +c PRINT *,' conversion des longit. ximod (donnees en radians)' +c , ,' en degres .' +c PRINT 3 + DO imod = 1, imodmax + xxim(imod) = xxim(imod) * 180./pi + ENDDO + ENDIF + + xim0 = xxim(imodmax) - 360. + + DO imod = 1, imodmax + xxim(imod) = xxim(imod) - xim0 + ENDDO + + idatmax1 = idatmax +1 + + DO idat = 1, idatmax + xxd(idat) = xidat(idat) + ENDDO + + CALL minmax( idatmax,xxd,chmin,chmax) + IF( chmax.LT.6.50 ) THEN +c PRINT 3 +c PRINT *,' conversion des longit. ximod (donnees en radians)' +c , ,' en degres .' +c PRINT 3 + DO idat = 1, idatmax + xxd(idat) = xxd(idat) * 180./pi + ENDDO + ENDIF + + DO idat = 1, idatmax + xxd(idat) = MOD( xxd(idat) - xim0, 360. ) + fdd(idat) = fdat (idat) + ENDDO +c PRINT *,' xxd redef. origine abscisses ' +c PRINT 2,(xxd(i),i=1,idatmax) + + DO i = 2, idatmax + IF( ( xxd(i) - xxd(i-1)).LT.0. ) THEN + ichang = i + GO TO 5 + ENDIF + ENDDO + GO TO 6 +c +c *** reorganisation des longitudes entre 0. et 360. degres **** +c + 5 nid = idatmax - ichang +1 + DO i = 1, nid + xchan (i) = xxd(i+ichang -1 ) + fdchan(i) = fdd(i+ichang -1 ) + ENDDO + DO i=1,ichang -1 + xchan (i+ nid) = xxd(i) + fdchan(i+nid) = fdd(i) + ENDDO + DO i =1,idatmax + xxd(i) = xchan(i) + fdd(i) = fdchan(i) + ENDDO + + 6 continue + + +c ------------------------------------------------ +c translation des champs de donnees par rapport +c a la nouvelle origine, avec redondance de la +c maille a cheval sur les bords +c ----------------------------------------------- + + id0 = 0 + id1 = 0 + + DO idat = 1, idatmax + IF ( xxd( idatmax1- idat ).LT.360.) GO TO 10 + id1 = id1 + 1 + ENDDO + + 10 DO idat = 1, idatmax + IF (xxd(idat).GT.0.) GO TO 20 + id0 = id0 + 1 + END DO + + 20 IF( id1.EQ.0 ) GO TO 30 + DO idat = 1, id1 + xxid(idat) = xxd(idatmax - id1 + idat) - 360. + fxd (idat) = fdd(idatmax - id1 + idat) + END DO + DO idat = 1, idatmax - id1 + xxid(idat + id1) = xxd(idat) + fxd (idat + id1) = fdd(idat) + END DO + + 30 IF(id0.EQ.0) GO TO 40 + DO idat = 1, idatmax - id0 + xxid(idat) = xxd(idat + id0) + fxd (idat) = fdd(idat + id0) + END DO + + DO idat = 1, id0 + xxid (idatmax - id0 + idat) = xxd(idat) + 360. + fxd (idatmax - id0 + idat) = fdd(idat) + END DO + GO TO 50 + + 40 DO idat = 1, idatmax + xxid(idat) = xxd(idat) + fxd (idat) = fdd(idat) + ENDDO + + 50 xxid(idatmax1) = xxid(1) + 360. + fxd (idatmax1) = fxd(1) + +c ------------------------------------ +c initialisation du champ du modele + + DO imod = 1, imodmax + fmod(imod) = 0. + END DO + +c PRINT *,' id0 id1 ',id0,id1 +c PRINT *,' xxim apres translation ' +c PRINT 2,(xxim(i),i=1,imodmax) +c PRINT *,' xxid apres translation ' +c PRINT 2,(xxid(i),i=1,idatmax) +c --------------------------------------- +c iteration + + x0 = xim0 + dxm = 0. + imod = 1 + idat = 1 + + 100 IF (xxim(imod).LT.xxid(idat)) THEN + dx = xxim(imod) - x0 + dxm = dxm + dx + fmod(imod) = (fmod(imod) + dx * fxd(idat)) / dxm + x0 = xxim(imod) + dxm = 0. + imod = imod + 1 + IF (imod.LE.imodmax) GO TO 100 + + ELSE IF (xxim(imod).GT.xxid(idat)) THEN + dx = xxid(idat) - x0 + dxm = dxm + dx + fmod(imod) = fmod(imod) + dx * fxd(idat) + x0 = xxid(idat) + idat = idat + 1 + GO TO 100 + + ELSE + dx = xxim(imod) - x0 + dxm = dxm + dx + fmod(imod) = (fmod(imod) + dx * fxd(idat)) / dxm + x0 = xxim(imod) + dxm = 0. + imod = imod + 1 + idat = idat + 1 + IF (imod.LE.imodmax) GO TO 100 + END IF + + +3 FORMAT(1x,70("-")) +2 FORMAT(1x,8f8.2) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inter_barxy.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inter_barxy.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inter_barxy.F (revision 1280) @@ -0,0 +1,59 @@ +! +! $Header$ +! + SUBROUTINE inter_barxy ( interfd,jnterfd,dlonid,dlatid , + , champ,imod,jmod,rlonimod,rlatimod, jsort,champint ) + +c Auteur : P. Le Van +c + INTEGER interfd,jnterfd,imod,jmod + REAL champ(interfd,jnterfd +1 ),dlonid(interfd),dlatid(jnterfd), + , champint(imod,jsort) + REAL rlonimod(imod),rlatimod(jmod) + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" + + REAL champx(imod),champy(jnterfd +1,imod),chpn(imod),chps(imod) + REAL chhpn,chhps + REAL fmody(jjp1) +c + + DO j = 1, jnterfd + 1 + CALL inter_barx( interfd, dlonid, champ( 1,j ), + , imod, rlonimod , champx ) + DO i = 1,imod + champy(j,i) = champx(i) + ENDDO + ENDDO + + DO i = 1, imod + CALL inter_bary( jjm,jnterfd,dlatid,champy(1,i), + , jmod ,rlatimod, fmody ) + DO j = 1, jsort + champint(i,j) = fmody(j) + ENDDO + ENDDO + + IF( jsort.EQ.jjp1) THEN + +c .... Valeurs uniques aux poles .... +c + DO i = 1,imod + chpn(i) = aire( i, 1 ) * champint( i, 1 ) + chps(i) = aire( i, jjp1 ) * champint( i,jjp1 ) + ENDDO + chhpn = SSUM(imod,chpn,1)/apoln + chhps = SSUM(imod,chps,1)/apols + + DO i = 1, imod + champint( i, 1 ) = chhpn + champint( i, jjp1) = chhps + ENDDO +c + ENDIF + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inter_bary.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inter_bary.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/inter_bary.F (revision 1280) @@ -0,0 +1,135 @@ +! +! $Header$ +! + SUBROUTINE inter_bary( jjm, jdatmax, yjdatt, fdatt , + , jmodmax, yjmodd, fmod ) +c +c ... Auteurs : Robert Sadourny , P. Le Van ... +c + IMPLICIT NONE + +c ---------------------------------------------------------- +c INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES . +c VERSION UNIDIMENSIONNELLE , EN LATITUDE . +c ---------------------------------------------------------- +c +c jdat : indice du champ de donnees, de 1 a jdatmax +c jmod : indice du champ du modele, de 1 a jmodmax +c fdatt(jdatmax) : champ de donnees (entrees) +c yjdatt(jdatmax): ordonnees des interfaces des mailles donnees +c yjmodd(jmodmax): ordonnees des interfaces des mailles modele +c fmod(jmodmax) : champ du modele (sorties) +c +c ( L'indice 1 correspond a l'interface maille 1 / maille 2) +c ( Les ordonnees sont exprimees en degres) +c +c jdatmax = nb. d'interfaces donnees = nombre de donnees - 1 +c jmodmax = nb. d'interfaces modele + +c Si jmodmax = jjm , on veut interpoler sur les jjm+1 latitudes +c rlatu du modele ( lat. des scalaires et de U ) +c +c Si jmodmax = jjp1 , on veut interpoler sur les jjm latitudes +c rlatv du modele ( lat. de V ) + +c .... Arguments en entree ....... + + INTEGER jjm , jdatmax, jmodmax + REAL yjdatt( jdatmax ) , fdatt( jdatmax +1 ) + REAL yjmodd( jmodmax ) + +c .... Arguments en sortie ....... +c + REAL fmod( jmodmax + 1 ) +c +c ...... Variables locales ...... + + INTEGER jmods + + REAL yjdat ( jdatmax +1 ), fdat( jdatmax +1) + REAL fscrat( jdatmax +1 ) + REAL yjmod ( jmodmax +1 ) + LOGICAL decrois + SAVE decrois +c + REAL y0,dy,dym + INTEGER jdat, jmod,i +c + + DO i = 1, jdatmax +1 + fdat (i) = fdatt (i) + ENDDO + + CALL ord_coord ( jdatmax , yjdatt(1), yjdat(1), decrois ) + + IF( decrois ) THEN + DO i = 1,jdatmax + 1 + fscrat(i) = fdat(i) + ENDDO + DO i = 1, jdatmax + 1 + fdat(i) = fscrat( jdatmax + 2 -i ) + ENDDO + + ENDIF + + CALL ord_coordm (jmodmax,yjmodd(1),yjmod(1),jjm,jmods,decrois ) +c +c Initialisation des variables +c -------------------------------- + + DO jmod = 1, jmods + fmod(jmod) = 0. + END DO + + y0 = 0. + dym = 0. + jmod = 1 + jdat = 1 +c -------------------- +c Iteration +c -------------------- + +100 IF ( yjmod(jmod).LT.yjdat(jdat) ) THEN + dy = yjmod(jmod) - y0 + dym = dym + dy + fmod(jmod) = (fmod(jmod) + dy * fdat(jdat)) / dym + y0 = yjmod(jmod) + dym = 0. + jmod = jmod + 1 + GO TO 100 + + ELSE IF ( yjmod(jmod).GT.yjdat(jdat) ) THEN + dy = yjdat(jdat) - y0 + dym = dym + dy + fmod(jmod) = fmod(jmod) + dy * fdat(jdat) + y0 = yjdat(jdat) + jdat = jdat + 1 + + GO TO 100 + + ELSE + dy = yjmod(jmod) - y0 + dym = dym + dy + fmod(jmod) = (fmod(jmod) + dy * fdat(jdat)) / dym + y0 = yjmod(jmod) + dym = 0. + jmod = jmod + 1 + jdat = jdat + 1 + + IF ( jmod.LE.jmods ) GO TO 100 + END IF +c --------------------------------------------- +c Le test de fin suppose que l'interface 0 +c est commune aux deux grilles yjdat et yjmod. +c ---------------------------------------------- + IF( decrois ) THEN + DO i = 1,jmods + fscrat(i) = fmod(i) + ENDDO + DO i = 1, jmods + fmod(i) = fscrat( jmods + 1 -i ) + ENDDO + ENDIF + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/interpost.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/interpost.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/interpost.F (revision 1280) @@ -0,0 +1,45 @@ +! +! $Header$ +! + subroutine interpost(q,qppm) + + implicit none + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +c Arguments + real q(iip1,jjp1,llm) + real qppm(iim,jjp1,llm) +c Local + integer l,i,j + +c RE-INVERSION DES NIVEAUX +c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport +c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface +c On passe donc des niveaux de Lin à ceux du LMDZ + + do l=1,llm + do j=1,jjp1 + do i=1,iim + q(i,j,l)=qppm(i,j,llm-l+1) + enddo + enddo + enddo + +c BOUCLAGE EN LONGITUDE PAS EFFECTUE DANS PPM3D + + do l=1,llm + do j=1,jjp1 + q(iip1,j,l)=q(1,j,l) + enddo + enddo + + + return + + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/interpre.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/interpre.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/interpre.F (revision 1280) @@ -0,0 +1,132 @@ +! +! $Header$ +! + subroutine interpre(q,qppm,w,fluxwppm,masse, + s apppm,bpppm,massebx,masseby,pbaru,pbarv, + s unatppm,vnatppm,psppm) + + implicit none + +#include "dimensions.h" +c#include "paramr2.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissip.h" +#include "comvert.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "control.h" +#include "ener.h" +#include "description.h" + +c--------------------------------------------------- +c Arguments + real apppm(llm+1),bpppm(llm+1) + real q(iip1,jjp1,llm),qppm(iim,jjp1,llm) +c--------------------------------------------------- + real masse(iip1,jjp1,llm) + real massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm) + real w(iip1,jjp1,llm+1) + real fluxwppm(iim,jjp1,llm) + real pbaru(iip1,jjp1,llm ) + real pbarv(iip1,jjm,llm) + real unatppm(iim,jjp1,llm) + real vnatppm(iim,jjp1,llm) + real psppm(iim,jjp1) +c--------------------------------------------------- +c Local + real vnat(iip1,jjp1,llm) + real unat(iip1,jjp1,llm) + real fluxw(iip1,jjp1,llm) + real smass(iip1,jjp1) +c---------------------------------------------------- + integer l,ij,i,j + +c CALCUL DE LA PRESSION DE SURFACE +c Les coefficients ap et bp sont passés en common +c Calcul de la pression au sol en mb optimisée pour +c la vectorialisation + + do j=1,jjp1 + do i=1,iip1 + smass(i,j)=0. + enddo + enddo + + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + smass(i,j)=smass(i,j)+masse(i,j,l) + enddo + enddo + enddo + + do j=1,jjp1 + do i=1,iim + psppm(i,j)=smass(i,j)/aire(i,j)*g*0.01 + end do + end do + +c RECONSTRUCTION DES CHAMPS CONTRAVARIANTS +c Le programme ppm3d travaille avec les composantes +c de vitesse et pas les flux, on doit donc passer de l'un à l'autre +c Dans le même temps, on fait le changement d'orientation du vent en v + do l=1,llm + do j=1,jjm + do i=1,iip1 + vnat(i,j,l)=-pbarv(i,j,l)/masseby(i,j,l)*cv(i,j) + enddo + enddo + do i=1,iim + vnat(i,jjp1,l)=0. + enddo + do j=1,jjp1 + do i=1,iip1 + unat(i,j,l)=pbaru(i,j,l)/massebx(i,j,l)*cu(i,j) + enddo + enddo + enddo + +c CALCUL DU FLUX MASSIQUE VERTICAL +c Flux en l=1 (sol) nul + fluxw=0. + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + fluxw(i,j,l)=w(i,j,l)*g*0.01/aire(i,j) +C print*,i,j,l,'fluxw(i,j,l)=',fluxw(i,j,l), +C c 'w(i,j,l)=',w(i,j,l) + enddo + enddo + enddo + +c INVERSION DES NIVEAUX +c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport +c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface +c On passe donc des niveaux du LMDZ à ceux de Lin + + do l=1,llm+1 + apppm(l)=ap(llm+2-l) + bpppm(l)=bp(llm+2-l) + enddo + + do l=1,llm + do j=1,jjp1 + do i=1,iim + unatppm(i,j,l)=unat(i,j,llm-l+1) + vnatppm(i,j,l)=vnat(i,j,llm-l+1) + fluxwppm(i,j,l)=fluxw(i,j,llm-l+1) + qppm(i,j,l)=q(i,j,llm-l+1) + enddo + enddo + enddo + + return + end + + + + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/invert_lat.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/invert_lat.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/invert_lat.F90 (revision 1280) @@ -0,0 +1,21 @@ + +SUBROUTINE invert_lat(xsize,ysize,vsize,field) + + IMPLICIT NONE + +! Input variables + INTEGER, INTENT(IN) :: xsize,ysize,vsize + REAL, DIMENSION (xsize,ysize,vsize), INTENT(INOUT) :: field +! Local variables + REAL, DIMENSION (xsize,ysize,vsize) :: f_aux + INTEGER :: l,j + + DO l=1,vsize + DO j=1,ysize + f_aux(:,j,l)=field(:,ysize+1-j,l) + END DO + END DO + + field=f_aux + + END SUBROUTINE invert_lat Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ismax.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ismax.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ismax.F (revision 1280) @@ -0,0 +1,24 @@ +! +! $Header$ +! + function ismax(n,sx,incx) +c + IMPLICIT NONE +c + INTEGER n,i,incx,ismax,ix + real sx((n-1)*incx+1),sxmax +c + ix=1 + ismax=1 + sxmax=sx(1) + do 10 i=1,n-1 + ix=ix+incx + if(sx(ix).gt.sxmax) then + sxmax=sx(ix) + ismax=i+1 + endif +10 continue +c + return + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ismin.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ismin.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ismin.F (revision 1280) @@ -0,0 +1,24 @@ +! +! $Header$ +! + FUNCTION ismin(n,sx,incx) +c + IMPLICIT NONE +c + integer n,i,incx,ismin,ix + real sx((n-1)*incx+1),sxmin +c + ix=1 + ismin=1 + sxmin=sx(1) + DO i=1,n-1 + ix=ix+incx + if(sx(ix).lt.sxmin) then + sxmin=sx(ix) + ismin=i+1 + endif + ENDDO +c + return + end +C Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/juldate.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/juldate.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/juldate.F (revision 1280) @@ -0,0 +1,33 @@ +! +! $Header$ +! + subroutine juldate(ian,imoi,ijou,oh,om,os,tjd,tjdsec) +c Sous-routine de changement de date: +c gregorien>>>date julienne +c En entree:an,mois,jour,heure,min.,sec. +c En sortie:tjd + implicit real (a-h,o-z) + frac=((os/60.+om)/60.+oh)/24. + ojou=dfloat(ijou)+frac + year=dfloat(ian) + rmon=dfloat(imoi) + if (imoi .le. 2) then + year=year-1. + rmon=rmon+12. + endif + cf=year+(rmon/100.)+(ojou/10000.) + if (cf .ge. 1582.1015) then + a=int(year/100) + b=2-a+int(a/4) + else + b=0 + endif + tjd=int(365.25*year)+int(30.6001*(rmon+1))+int(ojou) + + +1720994.5+b + tjdsec=(ojou-int(ojou))+(tjd-int(tjd)) + tjd=int(tjd)+int(tjdsec) + tjdsec=tjdsec-int(tjdsec) + return + end + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien.F (revision 1280) @@ -0,0 +1,40 @@ +! +! $Header$ +! + SUBROUTINE laplacien ( klevel, teta, divgra ) +c +c P. Le Van +c +c ************************************************************ +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ......... variables en arguments .............. +c + INTEGER klevel + REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) +c +c ............ variables locales .............. +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ....................................................... + + +c + CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) + + CALL filtreg( divgra, jjp1, klevel, 2, 1, .TRUE., 1 ) + CALL grad ( klevel,divgra, ghx , ghy ) + CALL divergf ( klevel, ghx , ghy , divgra ) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_gam.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_gam.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_gam.F (revision 1280) @@ -0,0 +1,53 @@ +! +! $Header$ +! + SUBROUTINE laplacien_gam ( klevel, cuvsga, cvusga, unsaigam , + * unsapolnga, unsapolsga, teta, divgra ) + +c P. Le Van +c +c ************************************************************ +c +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............ variables en arguments .......... +c + INTEGER klevel + REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) + REAL cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1), + * unsapolnga, unsapolsga +c +c ........... variables locales ................. +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ...................................................... + +c +c +c ... cvuscugam = ( cvu/ cu ) ** (- gamdissip ) +c ... cuvscvgam = ( cuv/ cv ) ** (- gamdissip ) calcules dans inigeom .. +c ... unsairegam = 1. / aire ** (- gamdissip ) +c + + CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) +c + CALL grad ( klevel, divgra, ghx, ghy ) +c + CALL diverg_gam ( klevel, cuvsga, cvusga, unsaigam , + * unsapolnga, unsapolsga, ghx , ghy , divgra ) + +c + + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_gam_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_gam_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_gam_p.F (revision 1280) @@ -0,0 +1,65 @@ + SUBROUTINE laplacien_gam_p ( klevel, cuvsga, cvusga, unsaigam , + * unsapolnga, unsapolsga, teta, divgra ) + +c P. Le Van +c +c ************************************************************ +c +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............ variables en arguments .......... +c + INTEGER klevel + REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) + REAL cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1), + * unsapolnga, unsapolsga +c +c ........... variables locales ................. +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ...................................................... + + INTEGER :: ijb,ije + INTEGER :: l +c +c +c ... cvuscugam = ( cvu/ cu ) ** (- gamdissip ) +c ... cuvscvgam = ( cuv/ cv ) ** (- gamdissip ) calcules dans inigeom .. +c ... unsairegam = 1. / aire ** (- gamdissip ) +c + +c CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud ) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,klevel + divgra(ijb:ije,l)=teta(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c + CALL grad_p ( klevel, divgra, ghx, ghy ) +c + CALL diverg_gam_p ( klevel, cuvsga, cvusga, unsaigam , + * unsapolnga, unsapolsga, ghx , ghy , divgra ) + +c + + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_p.F (revision 1280) @@ -0,0 +1,56 @@ + SUBROUTINE laplacien_p ( klevel, teta, divgra ) +c +c P. Le Van +c +c ************************************************************ +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ......... variables en arguments .............. +c + INTEGER klevel + REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) + INTEGER :: l +c +c ............ variables locales .............. +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ....................................................... + + + INTEGER :: ijb,ije,jjb,jje +c +c CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud ) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,klevel + divgra(ijb:ije,l)=teta(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + jjb=jj_begin-1 + jje=jj_end+1 + if (pole_nord) jjb=jj_begin + if (pole_sud ) jje=jj_end + + CALL filtreg_p( divgra,jjb,jje,jjp1, klevel, 2, 1, .TRUE., 1 ) + CALL grad_p ( klevel,divgra, ghx , ghy ) + CALL divergf_p ( klevel, ghx , ghy , divgra ) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_rot.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_rot.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_rot.F (revision 1280) @@ -0,0 +1,39 @@ +! +! $Header$ +! + SUBROUTINE laplacien_rot ( klevel, rotin, rotout,ghx,ghy ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de ( rotat x nxgrad ) du rotationnel rotin . +c ************************************************************ +c +c klevel et rotin sont des arguments d'entree pour le s-prog +c rotout est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c .......... variables en arguments ............. +c + INTEGER klevel + REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) +c +c .......... variables locales ................ +c + REAL ghy(ip1jm,klevel), ghx(ip1jmp1,klevel) +c ........................................................ +c +c + CALL filtreg ( rotin , jjm, klevel, 2, 1, .FALSE., 1 ) + + CALL nxgrad ( klevel, rotin, ghx , ghy ) + CALL rotatf ( klevel, ghx , ghy , rotout ) +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_rot_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_rot_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_rot_p.F (revision 1280) @@ -0,0 +1,45 @@ + SUBROUTINE laplacien_rot_p ( klevel, rotin, rotout,ghx,ghy ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de ( rotat x nxgrad ) du rotationnel rotin . +c ************************************************************ +c +c klevel et rotin sont des arguments d'entree pour le s-prog +c rotout est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c .......... variables en arguments ............. +c + INTEGER klevel + REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) +c +c .......... variables locales ................ +c + REAL ghy(ip1jm,klevel), ghx(ip1jmp1,klevel) +c ........................................................ +c +c + INTEGER :: ijb,ije,jjb,jje + + jjb=jj_begin-1 + jje=jj_end+1 + + if (pole_nord) jjb=jj_begin + if (pole_sud) jje=jj_end-1 + + CALL filtreg_p ( rotin ,jjb,jje,jjm, klevel,2, 1, .FALSE., 1) + + CALL nxgrad_p ( klevel, rotin, ghx , ghy ) + CALL rotatf_p ( klevel, ghx , ghy , rotout ) +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_rotgam.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_rotgam.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_rotgam.F (revision 1280) @@ -0,0 +1,44 @@ +! +! $Header$ +! + SUBROUTINE laplacien_rotgam ( klevel, rotin, rotout ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de (rotat x nxgrad)_gam du rotationnel rotin .. +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............. variables en arguments ........... +c + INTEGER klevel + REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) +c +c ............ variables locales ............... +c + INTEGER l, ij + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ........................................................ +c +c + + CALL nxgrad_gam ( klevel, rotin, ghx , ghy ) + CALL rotat_nfil ( klevel, ghx , ghy , rotout ) +c + DO l = 1, klevel + DO ij = 1, ip1jm + rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_rotgam_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_rotgam_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/laplacien_rotgam_p.F (revision 1280) @@ -0,0 +1,48 @@ + SUBROUTINE laplacien_rotgam_p ( klevel, rotin, rotout ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de (rotat x nxgrad)_gam du rotationnel rotin .. +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............. variables en arguments ........... +c + INTEGER klevel + REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) +c +c ............ variables locales ............... +c + INTEGER l, ij + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ........................................................ +c + INTEGER :: ijb,ije + +c + + CALL nxgrad_gam_p ( klevel, rotin, ghx , ghy ) + CALL rotat_nfil_p ( klevel, ghx , ghy , rotout ) +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/leapfrog_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/leapfrog_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/leapfrog_p.F (revision 1280) @@ -0,0 +1,1571 @@ +! +! $Id$ +! +c +c + + SUBROUTINE leapfrog_p(ucov,vcov,teta,ps,masse,phis,q,clesphy0, + & time_0) + + USE misc_mod + USE parallel + USE times + USE mod_hallo + USE Bands + USE Write_Field + USE Write_Field_p + USE vampir + USE timer_filtre, ONLY : print_filtre_timer + USE infotrac + USE guide_p_mod, ONLY : guide_main + USE getparam + + IMPLICIT NONE + +c ...... Version du 10/01/98 .......... + +c avec coordonnees verticales hybrides +c avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 ) + +c======================================================================= +c +c Auteur: P. Le Van /L. Fairhead/F.Hourdin +c ------- +c +c Objet: +c ------ +c +c GCM LMD nouvelle grille +c +c======================================================================= +c +c ... Dans inigeom , nouveaux calculs pour les elongations cu , cv +c et possibilite d'appeler une fonction f(y) a derivee tangente +c hyperbolique a la place de la fonction a derivee sinusoidale. + +c ... Possibilite de choisir le shema pour l'advection de +c q , en modifiant iadv dans traceur.def (10/02) . +c +c Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99) +c Pour Van-Leer iadv=10 +c +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissnew.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "temps.h" +#include "control.h" +#include "ener.h" +#include "description.h" +#include "serre.h" +#include "com_io_dyn.h" +#include "iniprint.h" +#include "academic.h" + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + + real zqmin,zqmax + INTEGER nbetatmoy, nbetatdem,nbetat + +c variables dynamiques + REAL :: vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL :: teta(ip1jmp1,llm) ! temperature potentielle + REAL :: q(ip1jmp1,llm,nqtot) ! champs advectes + REAL :: ps(ip1jmp1) ! pression au sol + REAL,SAVE :: p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL,SAVE :: pks(ip1jmp1) ! exner au sol + REAL,SAVE :: pk(ip1jmp1,llm) ! exner au milieu des couches + REAL,SAVE :: pkf(ip1jmp1,llm) ! exner filt.au milieu des couches + REAL :: masse(ip1jmp1,llm) ! masse d'air + REAL :: phis(ip1jmp1) ! geopotentiel au sol + REAL,SAVE :: phi(ip1jmp1,llm) ! geopotentiel + REAL,SAVE :: w(ip1jmp1,llm) ! vitesse verticale + +c variables dynamiques intermediaire pour le transport + REAL,SAVE :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse + +c variables dynamiques au pas -1 + REAL,SAVE :: vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm) + REAL,SAVE :: tetam1(ip1jmp1,llm),psm1(ip1jmp1) + REAL,SAVE :: massem1(ip1jmp1,llm) + +c tendances dynamiques + REAL,SAVE :: dv(ip1jm,llm),du(ip1jmp1,llm) + REAL,SAVE :: dteta(ip1jmp1,llm),dp(ip1jmp1) + REAL,DIMENSION(:,:,:), ALLOCATABLE, SAVE :: dq + +c tendances de la dissipation + REAL,SAVE :: dvdis(ip1jm,llm),dudis(ip1jmp1,llm) + REAL,SAVE :: dtetadis(ip1jmp1,llm) + +c tendances physiques + REAL,SAVE :: dvfi(ip1jm,llm),dufi(ip1jmp1,llm) + REAL,SAVE :: dtetafi(ip1jmp1,llm) + REAL,SAVE :: dpfi(ip1jmp1) + REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: dqfi + +c variables pour le fichier histoire + REAL dtav ! intervalle de temps elementaire + + REAL tppn(iim),tpps(iim),tpn,tps +c + INTEGER itau,itaufinp1,iav +! INTEGER iday ! jour julien + REAL time + + REAL SSUM + REAL time_0 + REAL,SAVE :: finvmaold(ip1jmp1,llm) + +cym LOGICAL lafin + LOGICAL :: lafin + INTEGER ij,iq,l + INTEGER ik + + real time_step, t_wrt, t_ops + +! jD_cur: jour julien courant +! jH_cur: heure julienne courante + REAL :: jD_cur, jH_cur + INTEGER :: an, mois, jour + REAL :: secondes + + LOGICAL first,callinigrads + + data callinigrads/.true./ + character*10 string10 + + REAL,SAVE :: alpha(ip1jmp1,llm),beta(ip1jmp1,llm) + REAL,SAVE :: flxw(ip1jmp1,llm) ! flux de masse verticale + +c+jld variables test conservation energie + REAL,SAVE :: ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm) +C Tendance de la temp. potentiel d (theta)/ d t due a la +C tansformation d'energie cinetique en energie thermique +C cree par la dissipation + REAL,SAVE :: dtetaecdt(ip1jmp1,llm) + REAL,SAVE :: vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL,SAVE :: vnat(ip1jm,llm),unat(ip1jmp1,llm) + REAL d_h_vcol, d_qt, d_qw, d_ql, d_ec + CHARACTER*15 ztit +! INTEGER ip_ebil_dyn ! PRINT level for energy conserv. diag. +! SAVE ip_ebil_dyn +! DATA ip_ebil_dyn/0/ +c-jld + + character*80 dynhist_file, dynhistave_file + character*20 modname + character*80 abort_message + + + logical,PARAMETER :: dissip_conservative=.TRUE. + + INTEGER testita + PARAMETER (testita = 9) + +c declaration liees au parallelisme + INTEGER :: ierr + LOGICAL :: FirstCaldyn + LOGICAL :: FirstPhysic + INTEGER :: ijb,ije,j,i + type(Request) :: TestRequest + type(Request) :: Request_Dissip + type(Request) :: Request_physic + REAL,SAVE :: dvfi_tmp(iip1,llm),dufi_tmp(iip1,llm) + REAL,SAVE :: dtetafi_tmp(iip1,llm) + REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: dqfi_tmp + REAL,SAVE :: dpfi_tmp(iip1) + + INTEGER :: true_itau + LOGICAL :: verbose=.true. + INTEGER :: iapptrac + INTEGER :: AdjustCount +! INTEGER :: var_time + LOGICAL :: ok_start_timer=.FALSE. + LOGICAL, SAVE :: firstcall=.TRUE. + +c$OMP MASTER + ItCount=0 +c$OMP END MASTER + true_itau=0 + FirstCaldyn=.TRUE. + FirstPhysic=.TRUE. + iapptrac=0 + AdjustCount = 0 + lafin=.false. + + itaufin = nday*day_step + itaufinp1 = itaufin +1 + modname="leapfrog_p" + + itau = 0 +! iday = day_ini+itau/day_step +! time = FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0 +! IF(time.GT.1.) THEN +! time = time-1. +! iday = iday+1 +! ENDIF + +c Allocate variables depending on dynamic variable nqtot +c$OMP MASTER + IF (firstcall) THEN + firstcall=.FALSE. + ALLOCATE(dq(ip1jmp1,llm,nqtot)) + ALLOCATE(dqfi(ip1jmp1,llm,nqtot)) + ALLOCATE(dqfi_tmp(iip1,llm,nqtot)) + END IF +c$OMP END MASTER +c$OMP BARRIER + +c----------------------------------------------------------------------- +c On initialise la pression et la fonction d'Exner : +c -------------------------------------------------- + +c$OMP MASTER + dq=0. + CALL pression ( ip1jmp1, ap, bp, ps, p ) + CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf ) +c$OMP END MASTER +c----------------------------------------------------------------------- +c Debut de l'integration temporelle: +c ---------------------------------- +c et du parallelisme !! + + 1 CONTINUE + + jD_cur = jD_ref + day_ini - day_ref + int (itau * dtvr / daysec) + jH_cur = jH_ref + & + & (itau * dtvr / daysec - int(itau * dtvr / daysec)) + + +#ifdef CPP_IOIPSL + if (ok_guide) then +!$OMP MASTER + call guide_main(itau,ucov,vcov,teta,q,masse,ps) +!$OMP END MASTER +!$OMP BARRIER + endif +#endif + +c +c IF( MOD( itau, 10* day_step ).EQ.0 ) THEN +c CALL test_period ( ucov,vcov,teta,q,p,phis ) +c PRINT *,' ---- Test_period apres continue OK ! -----', itau +c ENDIF +c +cym CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 ) +cym CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 ) +cym CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 ) +cym CALL SCOPY( ijp1llm,masse, 1, massem1, 1 ) +cym CALL SCOPY( ip1jmp1, ps , 1, psm1 , 1 ) + + if (FirstCaldyn) then +c$OMP MASTER + ucovm1=ucov + vcovm1=vcov + tetam1= teta + massem1= masse + psm1= ps + + finvmaold = masse + CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 ) +c$OMP END MASTER +c$OMP BARRIER + else +! Save fields obtained at previous time step as '...m1' + ijb=ij_begin + ije=ij_end + +c$OMP MASTER + psm1 (ijb:ije) = ps (ijb:ije) +c$OMP END MASTER + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + ije=ij_end + ucovm1 (ijb:ije,l) = ucov (ijb:ije,l) + tetam1 (ijb:ije,l) = teta (ijb:ije,l) + massem1 (ijb:ije,l) = masse (ijb:ije,l) + finvmaold(ijb:ije,l)=masse(ijb:ije,l) + + if (pole_sud) ije=ij_end-iip1 + vcovm1(ijb:ije,l) = vcov (ijb:ije,l) + + + ENDDO +c$OMP ENDDO + + + CALL filtreg_p ( finvmaold ,jj_begin,jj_end,jjp1, + . llm, -2,2, .TRUE., 1 ) + + endif ! of if (FirstCaldyn) + + forward = .TRUE. + leapf = .FALSE. + dt = dtvr + +c ... P.Le Van .26/04/94 .... + +cym CALL SCOPY ( ijp1llm, masse, 1, finvmaold, 1 ) +cym CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 ) + +cym ne sert a rien +cym call minmax(ijp1llm,q(:,:,3),zqmin,zqmax) + + 2 CONTINUE + +c$OMP MASTER + ItCount=ItCount+1 + if (MOD(ItCount,1)==1) then + debug=.true. + else + debug=.false. + endif +c$OMP END MASTER +c----------------------------------------------------------------------- + +c date: +c ----- + + +c gestion des appels de la physique et des dissipations: +c ------------------------------------------------------ +c +c ... P.Le Van ( 6/02/95 ) .... + + apphys = .FALSE. + statcl = .FALSE. + conser = .FALSE. + apdiss = .FALSE. +c idissip=1 + IF( purmats ) THEN + IF( MOD(itau,iconser) .EQ.0.AND. forward ) conser = .TRUE. + IF( MOD(itau,idissip ).EQ.0.AND..NOT.forward ) apdiss = .TRUE. + IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward + s .and. iflag_phys.EQ.1 ) apphys = .TRUE. + ELSE + IF( MOD(itau ,iconser) .EQ. 0 ) conser = .TRUE. + IF( MOD(itau+1,idissip) .EQ. 0 ) apdiss = .TRUE. + IF( MOD(itau+1,iphysiq).EQ.0.AND.iflag_phys.EQ.1) apphys=.TRUE. + END IF + +cym ---> Pour le moment +cym apphys = .FALSE. + statcl = .FALSE. + conser = .FALSE. + + if (firstCaldyn) then +c$OMP MASTER + call SetDistrib(jj_Nb_Caldyn) +c$OMP END MASTER +c$OMP BARRIER + firstCaldyn=.FALSE. +cym call InitTime +c$OMP MASTER + call Init_timer +c$OMP END MASTER + endif + +c$OMP MASTER + IF (ok_start_timer) THEN + CALL InitTime + ok_start_timer=.FALSE. + ENDIF +c$OMP END MASTER + + if (Adjust) then +c$OMP MASTER + AdjustCount=AdjustCount+1 + if (iapptrac==iapp_tracvl .and. (forward. OR . leapf) + & .and. itau/iphysiq>2 .and. Adjustcount>30) then + AdjustCount=0 + call allgather_timer_average + + if (Verbose) then + + print *,'*********************************' + print *,'****** TIMER CALDYN ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_caldyn(i), + & ' : temps moyen :', + & timer_average(jj_nb_caldyn(i),timer_caldyn,i), + & '+-',timer_delta(jj_nb_caldyn(i),timer_caldyn,i) + enddo + + print *,'*********************************' + print *,'****** TIMER VANLEER ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_vanleer(i), + & ' : temps moyen :', + & timer_average(jj_nb_vanleer(i),timer_vanleer,i), + & '+-',timer_delta(jj_nb_vanleer(i),timer_vanleer,i) + enddo + + print *,'*********************************' + print *,'****** TIMER DISSIP ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_dissip(i), + & ' : temps moyen :', + & timer_average(jj_nb_dissip(i),timer_dissip,i), + & '+-',timer_delta(jj_nb_dissip(i),timer_dissip,i) + enddo + + if (mpi_rank==0) call WriteBands + + endif + + call AdjustBands_caldyn + if (mpi_rank==0) call WriteBands + + call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(ucovm1,ucovm1,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(vcovm1,vcovm1,ip1jm,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(teta,teta,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(tetam1,tetam1,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(masse,masse,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(massem1,massem1,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(ps,ps,ip1jmp1,1, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(psm1,psm1,ip1jmp1,1, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(pkf,pkf,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(pk,pk,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(pks,pks,ip1jmp1,1, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(phis,phis,ip1jmp1,1, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(phi,phi,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(finvmaold,finvmaold,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + + do j=1,nqtot + call Register_SwapFieldHallo(q(1,1,j),q(1,1,j),ip1jmp1,llm, + & jj_nb_caldyn,0,0,TestRequest) + enddo + + call SetDistrib(jj_nb_caldyn) + call SendRequest(TestRequest) + call WaitRequest(TestRequest) + + call AdjustBands_dissip + call AdjustBands_physic + + endif +c$OMP END MASTER + endif + + + +c----------------------------------------------------------------------- +c calcul des tendances dynamiques: +c -------------------------------- +c$OMP BARRIER +c$OMP MASTER + call VTb(VThallo) +c$OMP END MASTER + + call Register_Hallo(ucov,ip1jmp1,llm,1,1,1,1,TestRequest) + call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,TestRequest) + call Register_Hallo(teta,ip1jmp1,llm,1,1,1,1,TestRequest) + call Register_Hallo(ps,ip1jmp1,1,1,2,2,1,TestRequest) + call Register_Hallo(pkf,ip1jmp1,llm,1,1,1,1,TestRequest) + call Register_Hallo(pk,ip1jmp1,llm,1,1,1,1,TestRequest) + call Register_Hallo(pks,ip1jmp1,1,1,1,1,1,TestRequest) + call Register_Hallo(p,ip1jmp1,llmp1,1,1,1,1,TestRequest) + +c do j=1,nqtot +c call Register_Hallo(q(1,1,j),ip1jmp1,llm,1,1,1,1, +c * TestRequest) +c enddo + + call SendRequest(TestRequest) +c$OMP BARRIER + call WaitRequest(TestRequest) + +c$OMP MASTER + call VTe(VThallo) +c$OMP END MASTER +c$OMP BARRIER + + if (debug) then +!$OMP BARRIER +!$OMP MASTER + call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/))) + call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/))) + call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/))) + call WriteField_p('ps',reshape(ps,(/iip1,jmp1/))) + call WriteField_p('masse',reshape(masse,(/iip1,jmp1,llm/))) + call WriteField_p('pk',reshape(pk,(/iip1,jmp1,llm/))) + call WriteField_p('pks',reshape(pks,(/iip1,jmp1/))) + call WriteField_p('pkf',reshape(pkf,(/iip1,jmp1,llm/))) + call WriteField_p('phis',reshape(phis,(/iip1,jmp1/))) + do j=1,nqtot + call WriteField_p('q'//trim(int2str(j)), + . reshape(q(:,:,j),(/iip1,jmp1,llm/))) + enddo +!$OMP END MASTER +c$OMP BARRIER + endif + + + True_itau=True_itau+1 + +c$OMP MASTER + IF (prt_level>9) THEN + WRITE(lunout,*)"leapfrog_p: Iteration No",True_itau + ENDIF + + + call start_timer(timer_caldyn) + + CALL geopot_p ( ip1jmp1, teta , pk , pks, phis , phi ) + + + call VTb(VTcaldyn) +c$OMP END MASTER +! var_time=time+iday-day_ini + +c$OMP BARRIER +! CALL FTRACE_REGION_BEGIN("caldyn") + time = jD_cur + jH_cur + CALL caldyn_p + $ ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , + $ phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time ) + +! CALL FTRACE_REGION_END("caldyn") + +c$OMP MASTER + call VTe(VTcaldyn) +c$OMP END MASTER + +cc$OMP BARRIER +cc$OMP MASTER +! call WriteField_p('du',reshape(du,(/iip1,jmp1,llm/))) +! call WriteField_p('dv',reshape(dv,(/iip1,jjm,llm/))) +! call WriteField_p('dteta',reshape(dteta,(/iip1,jmp1,llm/))) +! call WriteField_p('dp',reshape(dp,(/iip1,jmp1/))) +! call WriteField_p('w',reshape(w,(/iip1,jmp1,llm/))) +! call WriteField_p('pbaru',reshape(pbaru,(/iip1,jmp1,llm/))) +! call WriteField_p('pbarv',reshape(pbarv,(/iip1,jjm,llm/))) +! call WriteField_p('p',reshape(p,(/iip1,jmp1,llmp1/))) +! call WriteField_p('masse',reshape(masse,(/iip1,jmp1,llm/))) +! call WriteField_p('pk',reshape(pk,(/iip1,jmp1,llm/))) +cc$OMP END MASTER + +c----------------------------------------------------------------------- +c calcul des tendances advection des traceurs (dont l'humidite) +c ------------------------------------------------------------- + + IF( forward. OR . leapf ) THEN +cc$OMP PARALLEL DEFAULT(SHARED) +c + CALL caladvtrac_p(q,pbaru,pbarv, + * p, masse, dq, teta, + . flxw,pk, iapptrac) + + IF (offline) THEN +Cmaf stokage du flux de masse pour traceurs OFF-LINE + +#ifdef CPP_IOIPSL + CALL fluxstokenc_p(pbaru,pbarv,masse,teta,phi,phis, + . dtvr, itau) +#endif + + + ENDIF ! of IF (offline) +c + ENDIF ! of IF( forward. OR . leapf ) +cc$OMP END PARALLEL + +c----------------------------------------------------------------------- +c integrations dynamique et traceurs: +c ---------------------------------- + +c$OMP MASTER + call VTb(VTintegre) +c$OMP END MASTER +c call WriteField_p('ucovm1',reshape(ucovm1,(/iip1,jmp1,llm/))) +c call WriteField_p('vcovm1',reshape(vcovm1,(/iip1,jjm,llm/))) +c call WriteField_p('tetam1',reshape(tetam1,(/iip1,jmp1,llm/))) +c call WriteField_p('psm1',reshape(psm1,(/iip1,jmp1/))) +c call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/))) +c call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/))) +c call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/))) +c call WriteField_p('ps',reshape(ps,(/iip1,jmp1/))) +cc$OMP PARALLEL DEFAULT(SHARED) +c$OMP BARRIER +! CALL FTRACE_REGION_BEGIN("integrd") + + CALL integrd_p ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 , + $ dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis , + $ finvmaold ) + +! CALL FTRACE_REGION_END("integrd") +c$OMP BARRIER +cc$OMP MASTER +c call WriteField_p('ucovm1',reshape(ucovm1,(/iip1,jmp1,llm/))) +c call WriteField_p('vcovm1',reshape(vcovm1,(/iip1,jjm,llm/))) +c call WriteField_p('tetam1',reshape(tetam1,(/iip1,jmp1,llm/))) +c call WriteField_p('psm1',reshape(psm1,(/iip1,jmp1/))) +c call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/))) +c call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/))) +c call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/))) +c call WriteField_p('dteta',reshape(dteta,(/iip1,jmp1,llm/))) +c +c call WriteField_p('ps',reshape(ps,(/iip1,jmp1/))) +c do j=1,nqtot +c call WriteField_p('q'//trim(int2str(j)), +c . reshape(q(:,:,j),(/iip1,jmp1,llm/))) +c call WriteField_p('dq'//trim(int2str(j)), +c . reshape(dq(:,:,j),(/iip1,jmp1,llm/))) +c enddo +cc$OMP END MASTER + + +c$OMP MASTER + call VTe(VTintegre) +c$OMP END MASTER +c .P.Le Van (26/04/94 ajout de finvpold dans l'appel d'integrd) +c +c----------------------------------------------------------------------- +c calcul des tendances physiques: +c ------------------------------- +c ######## P.Le Van ( Modif le 6/02/95 ) ########### +c + IF( purmats ) THEN + IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE. + ELSE + IF( itau+1. EQ. itaufin ) lafin = .TRUE. + ENDIF + +cc$OMP END PARALLEL + +c +c + IF( apphys ) THEN +c +c ....... Ajout P.Le Van ( 17/04/96 ) ........... +c +cc$OMP PARALLEL DEFAULT(SHARED) +cc$OMP+ PRIVATE(rdaym_ini,rdayvrai,ijb,ije) + +c$OMP MASTER + call suspend_timer(timer_caldyn) + + write(lunout,*) + & 'leapfrog_p: Entree dans la physique : Iteration No ',true_itau +c$OMP END MASTER + + CALL pression_p ( ip1jmp1, ap, bp, ps, p ) + +c$OMP BARRIER + CALL exner_hyb_p( ip1jmp1, ps, p,alpha,beta,pks, pk, pkf ) +c$OMP BARRIER + jD_cur = jD_ref + day_ini - day_ref + $ + int (itau * dtvr / daysec) + jH_cur = jH_ref + & + & (itau * dtvr / daysec - int(itau * dtvr / daysec)) +! call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes) + +c rajout debug +c lafin = .true. + + +c Inbterface avec les routines de phylmd (phymars ... ) +c ----------------------------------------------------- + +c+jld + +c Diagnostique de conservation de l'energie : initialisation + IF (ip_ebil_dyn.ge.1 ) THEN + ztit='bil dyn' +! Ehouarn: be careful, diagedyn is Earth-specific (includes ../phylmd/..)! + IF (planet_type.eq."earth") THEN + CALL diagedyn(ztit,2,1,1,dtphys + & , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) + ENDIF + ENDIF +c-jld +c$OMP BARRIER +c$OMP MASTER + call VTb(VThallo) +c$OMP END MASTER + + call SetTag(Request_physic,800) + + call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm, + * jj_Nb_physic,2,2,Request_physic) + + call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm, + * jj_Nb_physic,2,2,Request_physic) + + call Register_SwapFieldHallo(teta,teta,ip1jmp1,llm, + * jj_Nb_physic,2,2,Request_physic) + + call Register_SwapFieldHallo(masse,masse,ip1jmp1,llm, + * jj_Nb_physic,1,2,Request_physic) + + call Register_SwapFieldHallo(p,p,ip1jmp1,llmp1, + * jj_Nb_physic,2,2,Request_physic) + + call Register_SwapFieldHallo(pk,pk,ip1jmp1,llm, + * jj_Nb_physic,2,2,Request_physic) + + call Register_SwapFieldHallo(phis,phis,ip1jmp1,1, + * jj_Nb_physic,2,2,Request_physic) + + call Register_SwapFieldHallo(phi,phi,ip1jmp1,llm, + * jj_Nb_physic,2,2,Request_physic) + + call Register_SwapFieldHallo(w,w,ip1jmp1,llm, + * jj_Nb_physic,2,2,Request_physic) + +c call SetDistrib(jj_nb_vanleer) + do j=1,nqtot + + call Register_SwapFieldHallo(q(1,1,j),q(1,1,j),ip1jmp1,llm, + * jj_Nb_physic,2,2,Request_physic) + enddo + + call Register_SwapFieldHallo(flxw,flxw,ip1jmp1,llm, + * jj_Nb_physic,2,2,Request_physic) + + call SendRequest(Request_Physic) +c$OMP BARRIER + call WaitRequest(Request_Physic) + +c$OMP BARRIER +c$OMP MASTER + call SetDistrib(jj_nb_Physic) + call VTe(VThallo) + + call VTb(VTphysiq) +c$OMP END MASTER +c$OMP BARRIER + +cc$OMP MASTER +c call WriteField_p('ucovfi',reshape(ucov,(/iip1,jmp1,llm/))) +c call WriteField_p('vcovfi',reshape(vcov,(/iip1,jjm,llm/))) +c call WriteField_p('tetafi',reshape(teta,(/iip1,jmp1,llm/))) +c call WriteField_p('pfi',reshape(p,(/iip1,jmp1,llmp1/))) +c call WriteField_p('pkfi',reshape(pk,(/iip1,jmp1,llm/))) +cc$OMP END MASTER +cc$OMP BARRIER +! CALL FTRACE_REGION_BEGIN("calfis") + CALL calfis_p(lafin ,jD_cur, jH_cur, + $ ucov,vcov,teta,q,masse,ps,p,pk,phis,phi , + $ du,dv,dteta,dq, + $ flxw, + $ clesphy0, dufi,dvfi,dtetafi,dqfi,dpfi ) +! CALL FTRACE_REGION_END("calfis") + ijb=ij_begin + ije=ij_end + if ( .not. pole_nord) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + dufi_tmp(1:iip1,l) = dufi(ijb:ijb+iim,l) + dvfi_tmp(1:iip1,l) = dvfi(ijb:ijb+iim,l) + dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l) + dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:) + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + dpfi_tmp(1:iip1) = dpfi(ijb:ijb+iim) +c$OMP END MASTER + endif ! of if ( .not. pole_nord) + +c$OMP BARRIER +c$OMP MASTER + call SetDistrib(jj_nb_Physic_bis) + + call VTb(VThallo) +c$OMP END MASTER +c$OMP BARRIER + + call Register_Hallo(dufi,ip1jmp1,llm, + * 1,0,0,1,Request_physic) + + call Register_Hallo(dvfi,ip1jm,llm, + * 1,0,0,1,Request_physic) + + call Register_Hallo(dtetafi,ip1jmp1,llm, + * 1,0,0,1,Request_physic) + + call Register_Hallo(dpfi,ip1jmp1,1, + * 1,0,0,1,Request_physic) + + do j=1,nqtot + call Register_Hallo(dqfi(1,1,j),ip1jmp1,llm, + * 1,0,0,1,Request_physic) + enddo + + call SendRequest(Request_Physic) +c$OMP BARRIER + call WaitRequest(Request_Physic) + +c$OMP BARRIER +c$OMP MASTER + call VTe(VThallo) + + call SetDistrib(jj_nb_Physic) +c$OMP END MASTER +c$OMP BARRIER + ijb=ij_begin + if (.not. pole_nord) then + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l) + dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l) + dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l) + & +dtetafi_tmp(1:iip1,l) + dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:) + & + dqfi_tmp(1:iip1,l,:) + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + dpfi(ijb:ijb+iim) = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1) +c$OMP END MASTER + + endif ! of if (.not. pole_nord) +c$OMP BARRIER +cc$OMP MASTER +c call WriteField_p('dufi',reshape(dufi,(/iip1,jmp1,llm/))) +c call WriteField_p('dvfi',reshape(dvfi,(/iip1,jjm,llm/))) +c call WriteField_p('dtetafi',reshape(dtetafi,(/iip1,jmp1,llm/))) +c call WriteField_p('dpfi',reshape(dpfi,(/iip1,jmp1/))) +cc$OMP END MASTER +c +c do j=1,nqtot +c call WriteField_p('dqfi'//trim(int2str(j)), +c . reshape(dqfi(:,:,j),(/iip1,jmp1,llm/))) +c enddo + +c ajout des tendances physiques: +c ------------------------------ + IF (ok_strato) THEN + CALL top_bound_p( vcov,ucov,teta,masse,dufi,dvfi,dtetafi) + ENDIF + + CALL addfi_p( dtphys, leapf, forward , + $ ucov, vcov, teta , q ,ps , + $ dufi, dvfi, dtetafi , dqfi ,dpfi ) + +c$OMP BARRIER +c$OMP MASTER + call VTe(VTphysiq) + + call VTb(VThallo) +c$OMP END MASTER + + call SetTag(Request_physic,800) + call Register_SwapField(ucov,ucov,ip1jmp1,llm, + * jj_Nb_caldyn,Request_physic) + + call Register_SwapField(vcov,vcov,ip1jm,llm, + * jj_Nb_caldyn,Request_physic) + + call Register_SwapField(teta,teta,ip1jmp1,llm, + * jj_Nb_caldyn,Request_physic) + + call Register_SwapField(masse,masse,ip1jmp1,llm, + * jj_Nb_caldyn,Request_physic) + + call Register_SwapField(p,p,ip1jmp1,llmp1, + * jj_Nb_caldyn,Request_physic) + + call Register_SwapField(pk,pk,ip1jmp1,llm, + * jj_Nb_caldyn,Request_physic) + + call Register_SwapField(phis,phis,ip1jmp1,1, + * jj_Nb_caldyn,Request_physic) + + call Register_SwapField(phi,phi,ip1jmp1,llm, + * jj_Nb_caldyn,Request_physic) + + call Register_SwapField(w,w,ip1jmp1,llm, + * jj_Nb_caldyn,Request_physic) + + do j=1,nqtot + + call Register_SwapField(q(1,1,j),q(1,1,j),ip1jmp1,llm, + * jj_Nb_caldyn,Request_physic) + + enddo + + call SendRequest(Request_Physic) +c$OMP BARRIER + call WaitRequest(Request_Physic) + +c$OMP BARRIER +c$OMP MASTER + call VTe(VThallo) + call SetDistrib(jj_Nb_caldyn) +c$OMP END MASTER +c$OMP BARRIER +c +c Diagnostique de conservation de l'energie : difference + IF (ip_ebil_dyn.ge.1 ) THEN + ztit='bil phys' + CALL diagedyn(ztit,2,1,1,dtphys + e , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) + ENDIF + +cc$OMP MASTER +c if (debug) then +c call WriteField_p('ucovfi',reshape(ucov,(/iip1,jmp1,llm/))) +c call WriteField_p('vcovfi',reshape(vcov,(/iip1,jjm,llm/))) +c call WriteField_p('tetafi',reshape(teta,(/iip1,jmp1,llm/))) +c endif +cc$OMP END MASTER + + +c-jld +c$OMP MASTER + call resume_timer(timer_caldyn) + if (FirstPhysic) then + ok_start_timer=.TRUE. + FirstPhysic=.false. + endif +c$OMP END MASTER + ENDIF ! of IF( apphys ) + + IF(iflag_phys.EQ.2) THEN ! "Newtonian" case +c Calcul academique de la physique = Rappel Newtonien + fritcion +c -------------------------------------------------------------- +cym teta(:,:)=teta(:,:) +cym s -iphysiq*dtvr*(teta(:,:)-tetarappel(:,:))/taurappel + ijb=ij_begin + ije=ij_end + teta(ijb:ije,:)=teta(ijb:ije,:) + s -iphysiq*dtvr*(teta(ijb:ije,:)-tetarappel(ijb:ije,:))/taurappel + + call Register_Hallo(ucov,ip1jmp1,llm,0,1,1,0,Request_Physic) + call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,Request_Physic) + call SendRequest(Request_Physic) +c$OMP BARRIER + call WaitRequest(Request_Physic) + + call friction_p(ucov,vcov,iphysiq*dtvr) + ENDIF ! of IF(iflag_phys.EQ.2) + + + CALL pression_p ( ip1jmp1, ap, bp, ps, p ) +c$OMP BARRIER + CALL exner_hyb_p( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf ) +c$OMP BARRIER + +cc$OMP END PARALLEL + +c----------------------------------------------------------------------- +c dissipation horizontale et verticale des petites echelles: +c ---------------------------------------------------------- + + IF(apdiss) THEN +cc$OMP PARALLEL DEFAULT(SHARED) +cc$OMP+ PRIVATE(ijb,ije,tppn,tpn,tpps,tps) +c$OMP MASTER + call suspend_timer(timer_caldyn) + +c print*,'Entree dans la dissipation : Iteration No ',true_itau +c calcul de l'energie cinetique avant dissipation +c print *,'Passage dans la dissipation' + + call VTb(VThallo) +c$OMP END MASTER + +c$OMP BARRIER + + call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm, + * jj_Nb_dissip,1,1,Request_dissip) + + call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm, + * jj_Nb_dissip,1,1,Request_dissip) + + call Register_SwapField(teta,teta,ip1jmp1,llm, + * jj_Nb_dissip,Request_dissip) + + call Register_SwapField(p,p,ip1jmp1,llmp1, + * jj_Nb_dissip,Request_dissip) + + call Register_SwapField(pk,pk,ip1jmp1,llm, + * jj_Nb_dissip,Request_dissip) + + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) + +c$OMP BARRIER +c$OMP MASTER + call SetDistrib(jj_Nb_dissip) + call VTe(VThallo) + call VTb(VTdissipation) + call start_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + + call covcont_p(llm,ucov,vcov,ucont,vcont) + call enercin_p(vcov,ucov,vcont,ucont,ecin0) + +c dissipation + +! CALL FTRACE_REGION_BEGIN("dissip") + CALL dissip_p(vcov,ucov,teta,p,dvdis,dudis,dtetadis) +! CALL FTRACE_REGION_END("dissip") + + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + ucov(ijb:ije,l)=ucov(ijb:ije,l)+dudis(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + if (pole_sud) ije=ije-iip1 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + vcov(ijb:ije,l)=vcov(ijb:ije,l)+dvdis(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c teta=teta+dtetadis + + +c------------------------------------------------------------------------ + if (dissip_conservative) then +C On rajoute la tendance due a la transform. Ec -> E therm. cree +C lors de la dissipation +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call VTb(VThallo) +c$OMP END MASTER + call Register_Hallo(ucov,ip1jmp1,llm,1,1,1,1,Request_Dissip) + call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,Request_Dissip) + call SendRequest(Request_Dissip) +c$OMP BARRIER + call WaitRequest(Request_Dissip) +c$OMP MASTER + call VTe(VThallo) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + call covcont_p(llm,ucov,vcov,ucont,vcont) + call enercin_p(vcov,ucov,vcont,ucont,ecin) + + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do ij=ijb,ije + dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l) + dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l) + enddo + enddo +c$OMP END DO NOWAIT + endif + + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do ij=ijb,ije + teta(ij,l)=teta(ij,l)+dtetadis(ij,l) + enddo + enddo +c$OMP END DO NOWAIT +c------------------------------------------------------------------------ + + +c ....... P. Le Van ( ajout le 17/04/96 ) ........... +c ... Calcul de la valeur moyenne, unique de h aux poles ..... +c + + ijb=ij_begin + ije=ij_end + + if (pole_nord) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = 1,iim + tppn(ij) = aire( ij ) * teta( ij ,l) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + + DO ij = 1, iip1 + teta( ij ,l) = tpn + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + DO ij = 1,iim + tppn(ij) = aire( ij ) * ps ( ij ) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + + DO ij = 1, iip1 + ps( ij ) = tpn + ENDDO +c$OMP END MASTER + endif + + if (pole_sud) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = 1,iim + tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l) + ENDDO + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + teta(ij+ip1jm,l) = tps + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + DO ij = 1,iim + tpps(ij) = aire(ij+ip1jm) * ps (ij+ip1jm) + ENDDO + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + ps(ij+ip1jm) = tps + ENDDO +c$OMP END MASTER + endif + + +c$OMP BARRIER +c$OMP MASTER + call VTe(VTdissipation) + + call stop_timer(timer_dissip) + + call VTb(VThallo) +c$OMP END MASTER + call Register_SwapField(ucov,ucov,ip1jmp1,llm, + * jj_Nb_caldyn,Request_dissip) + + call Register_SwapField(vcov,vcov,ip1jm,llm, + * jj_Nb_caldyn,Request_dissip) + + call Register_SwapField(teta,teta,ip1jmp1,llm, + * jj_Nb_caldyn,Request_dissip) + + call Register_SwapField(p,p,ip1jmp1,llmp1, + * jj_Nb_caldyn,Request_dissip) + + call Register_SwapField(pk,pk,ip1jmp1,llm, + * jj_Nb_caldyn,Request_dissip) + + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) + +c$OMP BARRIER +c$OMP MASTER + call SetDistrib(jj_Nb_caldyn) + call VTe(VThallo) + call resume_timer(timer_caldyn) +c print *,'fin dissipation' +c$OMP END MASTER +c$OMP BARRIER + END IF + +cc$OMP END PARALLEL + +c ajout debug +c IF( lafin ) then +c abort_message = 'Simulation finished' +c call abort_gcm(modname,abort_message,0) +c ENDIF + +c ******************************************************************** +c ******************************************************************** +c .... fin de l'integration dynamique et physique pour le pas itau .. +c ******************************************************************** +c ******************************************************************** + +c preparation du pas d'integration suivant ...... +cym call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/))) +cym call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/))) +c$OMP MASTER + call stop_timer(timer_caldyn) +c$OMP END MASTER + IF (itau==itaumax) then +c$OMP MASTER + call allgather_timer_average + + if (mpi_rank==0) then + + print *,'*********************************' + print *,'****** TIMER CALDYN ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_caldyn(i), + & ' : temps moyen :', + & timer_average(jj_nb_caldyn(i),timer_caldyn,i) + enddo + + print *,'*********************************' + print *,'****** TIMER VANLEER ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_vanleer(i), + & ' : temps moyen :', + & timer_average(jj_nb_vanleer(i),timer_vanleer,i) + enddo + + print *,'*********************************' + print *,'****** TIMER DISSIP ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_dissip(i), + & ' : temps moyen :', + & timer_average(jj_nb_dissip(i),timer_dissip,i) + enddo + + print *,'*********************************' + print *,'****** TIMER PHYSIC ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_physic(i), + & ' : temps moyen :', + & timer_average(jj_nb_physic(i),timer_physic,i) + enddo + + endif + + print *,'Taille du Buffer MPI (REAL*8)',MaxBufferSize + print *,'Taille du Buffer MPI utilise (REAL*8)',MaxBufferSize_Used + print *, 'Temps total ecoule sur la parallelisation :',DiffTime() + print *, 'Temps CPU ecoule sur la parallelisation :',DiffCpuTime() + CALL print_filtre_timer + call fin_getparam + call finalize_parallel +c$OMP END MASTER +c$OMP BARRIER + RETURN + ENDIF + + IF ( .NOT.purmats ) THEN +c ........................................................ +c .............. schema matsuno + leapfrog .............. +c ........................................................ + + IF(forward. OR. leapf) THEN + itau= itau + 1 +! iday= day_ini+itau/day_step +! time= FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0 +! IF(time.GT.1.) THEN +! time = time-1. +! iday = iday+1 +! ENDIF + ENDIF + + + IF( itau. EQ. itaufinp1 ) then + +c$OMP MASTER + call fin_getparam + call finalize_parallel +c$OMP END MASTER + abort_message = 'Simulation finished' + call abort_gcm(modname,abort_message,0) + RETURN + ENDIF +c----------------------------------------------------------------------- +c ecriture du fichier histoire moyenne: +c ------------------------------------- + + IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN +c$OMP BARRIER + IF(itau.EQ.itaufin) THEN + iav=1 + ELSE + iav=0 + ENDIF +#ifdef CPP_IOIPSL + IF (ok_dynzon) THEN + call Register_Hallo(vcov,ip1jm,llm,1,0,0,1,TestRequest) + call SendRequest(TestRequest) +c$OMP BARRIER + call WaitRequest(TestRequest) +c$OMP BARRIER +c$OMP MASTER +! CALL writedynav_p(histaveid, itau,vcov , +! , ucov,teta,pk,phi,q,masse,ps,phis) + +c ATTENTION!!! bilan_dyn_p ne marche probablement pas avec OpenMP + CALL bilan_dyn_p(2,dtvr*iperiod,dtvr*day_step*periodav, + , ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) +c$OMP END MASTER + ENDIF !ok_dynzon +#endif + ENDIF + +c----------------------------------------------------------------------- +c ecriture de la bande histoire: +c ------------------------------ + +c IF( MOD(itau,iecri ).EQ.0) THEN + + IF( MOD(itau,iecri*day_step).EQ.0) THEN +c$OMP BARRIER +c$OMP MASTER + nbetat = nbetatdem + CALL geopot_p(ip1jmp1,teta,pk,pks,phis,phi) + +cym unat=0. + + ijb=ij_begin + ije=ij_end + + if (pole_nord) then + ijb=ij_begin+iip1 + unat(1:iip1,:)=0. + endif + + if (pole_sud) then + ije=ij_end-iip1 + unat(ij_end-iip1+1:ij_end,:)=0. + endif + + do l=1,llm + unat(ijb:ije,l)=ucov(ijb:ije,l)/cu(ijb:ije) + enddo + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + do l=1,llm + vnat(ijb:ije,l)=vcov(ijb:ije,l)/cv(ijb:ije) + enddo + +#ifdef CPP_IOIPSL + +! CALL writehist_p(histid,histvid, itau,vcov, +! & ucov,teta,phi,q,masse,ps,phis) + +#endif +! For some Grads outputs of fields + if (output_grads_dyn) then +! Ehouarn: hope this works the way I think it does: + call Gather_Field(unat,ip1jmp1,llm,0) + call Gather_Field(vnat,ip1jm,llm,0) + call Gather_Field(teta,ip1jmp1,llm,0) + call Gather_Field(ps,ip1jmp1,1,0) + do iq=1,nqtot + call Gather_Field(q(1,1,iq),ip1jmp1,llm,0) + enddo + if (mpi_rank==0) then +#include "write_grads_dyn.h" + endif + endif ! of if (output_grads_dyn) +c$OMP END MASTER + ENDIF ! of IF(MOD(itau,iecri).EQ.0) + + IF(itau.EQ.itaufin) THEN + +c$OMP BARRIER +c$OMP MASTER + + if (planet_type.eq."earth") then +! Write an Earth-format restart file + CALL dynredem1_p("restart.nc",0.0, + & vcov,ucov,teta,q,masse,ps) + endif ! of if (planet_type.eq."earth") + +! CLOSE(99) +c$OMP END MASTER + ENDIF ! of IF (itau.EQ.itaufin) + +c----------------------------------------------------------------------- +c gestion de l'integration temporelle: +c ------------------------------------ + + IF( MOD(itau,iperiod).EQ.0 ) THEN + GO TO 1 + ELSE IF ( MOD(itau-1,iperiod). EQ. 0 ) THEN + + IF( forward ) THEN +c fin du pas forward et debut du pas backward + + forward = .FALSE. + leapf = .FALSE. + GO TO 2 + + ELSE +c fin du pas backward et debut du premier pas leapfrog + + leapf = .TRUE. + dt = 2.*dtvr + GO TO 2 + END IF + ELSE + +c ...... pas leapfrog ..... + + leapf = .TRUE. + dt = 2.*dtvr + GO TO 2 + END IF ! of IF (MOD(itau,iperiod).EQ.0) + ! ELSEIF (MOD(itau-1,iperiod).EQ.0) + + + ELSE ! of IF (.not.purmats) + +c ........................................................ +c .............. schema matsuno ............... +c ........................................................ + IF( forward ) THEN + + itau = itau + 1 +! iday = day_ini+itau/day_step +! time = FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0 +! +! IF(time.GT.1.) THEN +! time = time-1. +! iday = iday+1 +! ENDIF + + forward = .FALSE. + IF( itau. EQ. itaufinp1 ) then +c$OMP MASTER + call fin_getparam + call finalize_parallel +c$OMP END MASTER + abort_message = 'Simulation finished' + call abort_gcm(modname,abort_message,0) + RETURN + ENDIF + GO TO 2 + + ELSE ! of IF(forward) + + IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN + IF(itau.EQ.itaufin) THEN + iav=1 + ELSE + iav=0 + ENDIF +#ifdef CPP_IOIPSL + IF (ok_dynzon) THEN +c$OMP BARRIER + + call Register_Hallo(vcov,ip1jm,llm,1,0,0,1,TestRequest) + call SendRequest(TestRequest) +c$OMP BARRIER + call WaitRequest(TestRequest) + +c$OMP BARRIER +c$OMP MASTER +! CALL writedynav_p(histaveid, itau,vcov , +! , ucov,teta,pk,phi,q,masse,ps,phis) + CALL bilan_dyn_p(2,dtvr*iperiod,dtvr*day_step*periodav, + , ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) +c$OMP END MASTER + END IF !ok_dynzon +#endif + ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) + + +c IF(MOD(itau,iecri ).EQ.0) THEN + IF(MOD(itau,iecri*day_step).EQ.0) THEN +c$OMP BARRIER +c$OMP MASTER + nbetat = nbetatdem + CALL geopot_p(ip1jmp1,teta,pk,pks,phis,phi) + +cym unat=0. + ijb=ij_begin + ije=ij_end + + if (pole_nord) then + ijb=ij_begin+iip1 + unat(1:iip1,:)=0. + endif + + if (pole_sud) then + ije=ij_end-iip1 + unat(ij_end-iip1+1:ij_end,:)=0. + endif + + do l=1,llm + unat(ijb:ije,l)=ucov(ijb:ije,l)/cu(ijb:ije) + enddo + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + do l=1,llm + vnat(ijb:ije,l)=vcov(ijb:ije,l)/cv(ijb:ije) + enddo + +#ifdef CPP_IOIPSL + +! CALL writehist_p(histid, histvid, itau,vcov , +! & ucov,teta,phi,q,masse,ps,phis) +#endif +! For some Grads output (but does it work?) + if (output_grads_dyn) then + call Gather_Field(unat,ip1jmp1,llm,0) + call Gather_Field(vnat,ip1jm,llm,0) + call Gather_Field(teta,ip1jmp1,llm,0) + call Gather_Field(ps,ip1jmp1,1,0) + do iq=1,nqtot + call Gather_Field(q(1,1,iq),ip1jmp1,llm,0) + enddo +c + if (mpi_rank==0) then +#include "write_grads_dyn.h" + endif + endif ! of if (output_grads_dyn) + +c$OMP END MASTER + ENDIF ! of IF(MOD(itau,iecri*day_step).EQ.0) + + IF(itau.EQ.itaufin) THEN + if (planet_type.eq."earth") then +c$OMP MASTER + CALL dynredem1_p("restart.nc",0.0, + . vcov,ucov,teta,q,masse,ps) +c$OMP END MASTER + endif ! of if (planet_type.eq."earth") + ENDIF ! of IF(itau.EQ.itaufin) + + forward = .TRUE. + GO TO 1 + + ENDIF ! of IF (forward) + + END IF ! of IF(.not.purmats) +c$OMP MASTER + call fin_getparam + call finalize_parallel +c$OMP END MASTER + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/limit_netcdf.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/limit_netcdf.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/limit_netcdf.F (revision 1280) @@ -0,0 +1,1334 @@ +! +! $Id$ +! +C +C + SUBROUTINE limit_netcdf(interbar, extrap, oldice, masque) +#ifdef CPP_EARTH +! This routine is designed to work for Earth + USE dimphy + use phys_state_var_mod , ONLY : pctsrf + IMPLICIT none +c +c------------------------------------------------------------- +C Author : L. Fairhead +C Date : 27/01/94 +C Objet : Construction des fichiers de conditions aux limites +C pour le nouveau +C modele a partir de fichiers de climatologie. Les deux +C grilles doivent etre regulieres +c +c Modifie par z.x.li (le23mars1994) +c Modifie par L. Fairhead (fairhead@lmd.jussieu.fr) septembre 1999 +c pour lecture netcdf dans LMDZ.3.3 +c Modifie par P;Le Van , juillet 2001 +c------------------------------------------------------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "control.h" +#include "logic.h" +#include "netcdf.inc" +#include "comvert.h" +#include "comgeom2.h" +#include "comconst.h" +cy#include "dimphy.h" +#include "indicesol.h" +#include "iniprint.h" +c +c----------------------------------------------------------------------- + LOGICAL interbar, extrap, oldice + + REAL phy_nat(klon,360), phy_nat0(klon) + REAL phy_alb(klon,360) + REAL phy_sst(klon,360) + REAL phy_bil(klon,360) + REAL phy_rug(klon,360) + REAL phy_ice(klon) +c + real pctsrf_t(klon,nbsrf,360) + + REAL verif + + REAL masque(iip1,jjp1) + REAL mask(iim,jjp1) +CPB +C newlmt indique l'utilisation de la sous-maille fractionnelle +C tandis que l'ancien codage utilise l'indicateur du sol (0,1,2,3) + LOGICAL newlmt, fracterre + PARAMETER(newlmt=.TRUE.) + PARAMETER(fracterre = .TRUE.) + +C Declarations pour le champ de depart + INTEGER imdep, jmdep,lmdep + INTEGER tbid + PARAMETER ( tbid = 60 ) ! >52 semaines + REAL timecoord(tbid) +c + REAL , ALLOCATABLE :: dlon_msk(:), dlat_msk(:) + REAL , ALLOCATABLE :: lonmsk_ini(:), latmsk_ini(:) + REAL , ALLOCATABLE :: dlon(:), dlat(:) + REAL , ALLOCATABLE :: dlon_ini(:), dlat_ini(:) + REAL , ALLOCATABLE :: champ_msk(:), champ(:) + REAL , ALLOCATABLE :: work(:,:) + + CHARACTER*25 title + +C Declarations pour le champ interpole 2D + REAL champint(iim,jjp1) + real chmin,chmax + +C Declarations pour le champ interpole 3D + REAL champtime(iim,jjp1,tbid) + REAL timeyear(tbid) + REAL champan(iip1,jjp1,366) + +C Declarations pour l'inteprolation verticale + REAL ax(tbid), ay(tbid) + REAL by + REAL yder(tbid) + + + INTEGER ierr + INTEGER dimfirst(3) + INTEGER dimlast(3) +c + INTEGER nid, ndim, ntim + INTEGER dims(2), debut(2), epais(2) + INTEGER id_tim + INTEGER id_NAT, id_SST, id_BILS, id_RUG, id_ALB +CPB + INTEGER id_FOCE, id_FSIC, id_FTER, id_FLIC + + INTEGER i, j, k, l, ji +c declarations pour lecture glace de mer + INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret + INTEGER :: itaul(1), fid + REAL :: lev(1), date, dt + REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic + REAL, ALLOCATABLE, DIMENSION(:) :: dlon_lic, dlat_lic + REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic + REAL :: flic_tmp(iip1, jjp1) + +c Diverses variables locales + REAL time +! pour la lecture du fichier masque ocean + integer :: nid_o2a + logical :: couple = .false. + INTEGER :: iml_omask, jml_omask + REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_omask, lat_omask + REAL, ALLOCATABLE, DIMENSION(:) :: dlon_omask, dlat_omask + REAL, ALLOCATABLE, DIMENSION (:,:) :: ocemask, ocetmp + real, dimension(klon) :: ocemask_fi + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0 ( longcles ) +#include "serre.h" + INTEGER ncid,varid,ndimid(4),dimid + character*30 namedim + CHARACTER*80 :: varname + +cIM28/02/2002 <== PM + REAL tmidmonth(12) + SAVE tmidmonth + DATA tmidmonth/15,45,75,105,135,165,195,225,255,285,315,345/ + +c initialisations: + CALL conf_gcm( 99, .TRUE. , clesphy0 ) + + + pi = 4. * ATAN(1.) + rad = 6 371 229. + omeg = 4.* ASIN(1.)/(24.*3600.) + g = 9.8 + daysec = 86400. + kappa = 0.2857143 + cpp = 1004.70885 + dtvr = daysec/FLOAT(day_step) + CALL inigeom +c +C Traitement du relief au sol +c + write(*,*) 'Traitement du relief au sol pour fabriquer masque' + ierr = NF_OPEN('Relief.nc', NF_NOWRITE, ncid) + + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ierr = NF_INQ_VARID(ncid,'RELIEF',varid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', imdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( lonmsk_ini(imdep) ) + ALLOCATE( dlon_msk(imdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,lonmsk_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,lonmsk_ini) +#endif + +c + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', jmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( latmsk_ini(jmdep) ) + ALLOCATE( dlat_msk(jmdep) ) + ALLOCATE( champ_msk(imdep*jmdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,latmsk_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,latmsk_ini) +#endif +c + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,varid,champ_msk) +#else + ierr = NF_GET_VAR_REAL(ncid,varid,champ_msk) +#endif +c + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +c + title='RELIEF' + + CALL conf_dat2d(title,imdep, jmdep, lonmsk_ini, latmsk_ini, + . dlon_msk, dlat_msk, champ_msk, interbar ) + + DO i = 1, iim + DO j = 1, jjp1 + mask(i,j) = masque(i,j) + ENDDO + ENDDO + WRITE(*,*) 'MASK:' + WRITE(*,'(96i1)')INT(mask) + ierr = NF_CLOSE(ncid) +c +c +C Traitement de la rugosite +c + PRINT*, 'Traitement de la rugosite' + ierr = NF_OPEN('Rugos.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ierr = NF_INQ_VARID(ncid,'RUGOS',varid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', imdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( dlon_ini(imdep) ) + ALLOCATE( dlon(imdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', jmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( dlat_ini(jmdep) ) + ALLOCATE( dlat(jmdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', lmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +c + ALLOCATE( champ(imdep*jmdep) ) + + DO 200 l = 1, lmdep + dimfirst(1) = 1 + dimfirst(2) = 1 + dimfirst(3) = l +c + dimlast(1) = imdep + dimlast(2) = jmdep + dimlast(3) = 1 +c + PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l) + print*,dimfirst,dimlast +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ) +#else + ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + title = 'Rugosite Amip ' +c + CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini, + . dlon, dlat, champ, interbar ) + + IF ( interbar ) THEN + DO j = 1, imdep * jmdep + champ(j) = LOG(champ(j)) + ENDDO + + IF( l.EQ.1 ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour la rugosite $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + ENDIF + CALL inter_barxy ( imdep,jmdep -1,dlon,dlat,champ , + , iim,jjm,rlonu,rlatv, jjp1,champint ) + DO j=1,jjp1 + DO i=1,iim + champint(i,j)=EXP(champint(i,j)) + ENDDO + ENDDO + + DO j = 1, jjp1 + DO i = 1, iim + IF(NINT(mask(i,j)).NE.1) THEN + champint( i,j ) = 0.001 + ENDIF + ENDDO + ENDDO + ELSE + CALL rugosite(imdep, jmdep, dlon, dlat, champ, + . iim, jjp1, rlonv, rlatu, champint, mask) + ENDIF + DO j = 1,jjp1 + DO i = 1, iim + champtime (i,j,l) = champint(i,j) + ENDDO + ENDDO +200 CONTINUE +c + DO l = 1, lmdep + timeyear(l) = timecoord(l) + ENDDO + + PRINT 222, timeyear(:lmdep) +222 FORMAT(2x,' Time year ',10f6.1) +c + + PRINT*, 'Interpolation temporelle dans l annee' + + DO j = 1, jjp1 + DO i = 1, iim + DO l = 1, lmdep + ax(l) = timeyear(l) + ay(l) = champtime (i,j,l) + ENDDO + CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder) + DO k = 1, 360 + time = FLOAT(k-1) + CALL SPLINT(ax,ay,yder,lmdep,time,by) + champan(i,j,k) = by + ENDDO + ENDDO + ENDDO + DO k = 1, 360 + DO j = 1, jjp1 + champan(iip1,j,k) = champan(1,j,k) + ENDDO + IF ( k.EQ.10 ) THEN + DO j = 1, jjp1 + CALL minmax( iip1,champan(1,j,10),chmin,chmax ) + PRINT *,' Rugosite au temps 10 ', chmin,chmax,j + ENDDO + ENDIF + ENDDO +c + DO k = 1, 360 + CALL gr_dyn_fi(1,iip1,jjp1,klon,champan(1,1,k), phy_rug(1,k)) + ENDDO +c + ierr = NF_CLOSE(ncid) + + DEALLOCATE( dlon ) + DEALLOCATE( dlon_ini ) + DEALLOCATE( dlat ) + DEALLOCATE( dlat_ini ) + DEALLOCATE( champ ) +c +c +C Traitement de la glace oceanique +c + PRINT*, 'Traitement de la glace oceanique' + + ierr = NF_OPEN('amipbc_sic_1x1.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) THEN + ierr = NF_OPEN('amipbc_sic_1x1_clim.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) THEN + print *, NF_STRERROR(ierr) + STOP + endif + ENDIF + +cIM22/02/2002 +cIM07/03/2002 AMIP.nc & amip79to95.nc +cIM ierr = NF_INQ_VARID(ncid,'SEA_ICE',varid) +cIM07/03/2002 amipbc_sic_1x1_clim.nc & amipbc_sic_1x1.nc + ierr = NF_INQ_VARID(ncid,'sicbcs',varid) +cIM22/02/2002 + if (ierr.ne.0) then + print *, NF_STRERROR(ierr),'sicbcs' + STOP + ENDIF + ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', imdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE ( dlon_ini(imdep) ) + ALLOCATE ( dlon(imdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, jmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE ( dlat_ini(jmdep) ) + ALLOCATE ( dlat(jmdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, lmdep +cIM28/02/2002 +cPM28/02/2002 : nouvelle coord temporelle fichiers AMIP pas en jours +c Ici on suppose qu'on a 12 mois (de 30 jours). + IF (lmdep.NE.12) THEN + print *, 'Unknown AMIP file: not 12 months ?' + STOP + ENDIF +cIM28/02/2002 + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +c + ALLOCATE ( champ(imdep*jmdep) ) + + DO l = 1, lmdep + dimfirst(1) = 1 + dimfirst(2) = 1 + dimfirst(3) = l +c + dimlast(1) = imdep + dimlast(2) = jmdep + dimlast(3) = 1 +c + PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l) +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ) +#else + ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + title = 'Sea-ice Amip ' +c + CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini, + . dlon, dlat, champ, interbar ) +c + IF( oldice ) THEN + CALL sea_ice(imdep, jmdep, dlon, dlat, champ, + . iim, jjp1, rlonv, rlatu, champint ) + ELSEIF ( interbar ) THEN + IF( l.EQ.1 ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour Sea-ice Amip $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + ENDIF +cIM07/03/2002 +cIM22/02/2002 : Sea-ice Amip entre 0. et 1. +cIM PRINT*,'SUB. limit_netcdf.F IM : Sea-ice et SST Amip_new clim' +cIM DO j = 1, imdep * jmdep +cIM28/02/2002 <==PM champ(j) = champ(j)/100. +cIM14/03/2002 champ(j) = max(0.0,(min(1.0, (champ(j)/100.) ))) +cIM champ(j) = amax1(0.0,(amin1(1.0, (champ(j)/100.) ))) +cIM ENDDO +cIM22/02/2002 + CALL inter_barxy ( imdep,jmdep -1,dlon, dlat , + , champ, iim, jjm, rlonu, rlatv, jjp1, champint ) + ELSE + CALL sea_ice(imdep, jmdep, dlon, dlat, champ, + . iim, jjp1, rlonv, rlatu, champint ) + ENDIF + DO j = 1,jjp1 + DO i = 1, iim + champtime (i,j,l) = champint(i,j) + ENDDO + ENDDO + ENDDO +c + DO l = 1, lmdep +cIM28/02/2002 <== PM timeyear(l) = timecoord(l) +cIM timeyear(l) = timecoord(l) +cIM07/03/2002 + timeyear(l) = tmidmonth(l) + ENDDO + PRINT 222, timeyear(:lmdep) +c + PRINT*, 'Interpolation temporelle' + DO j = 1, jjp1 + DO i = 1, iim + DO l = 1, lmdep + ax(l) = timeyear(l) + ay(l) = champtime (i,j,l) + ENDDO + CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder) + DO k = 1, 360 + time = FLOAT(k-1) + CALL SPLINT(ax,ay,yder,lmdep,time,by) + champan(i,j,k) = by + ENDDO + ENDDO + ENDDO + DO k = 1, 360 + DO j = 1, jjp1 + champan(iip1, j, k) = champan(1, j, k) + ENDDO + IF ( k.EQ.10 ) THEN + DO j = 1, jjp1 + CALL minmax( iip1,champan(1,j,10),chmin,chmax ) + PRINT *,' Sea ice au temps 10 ', chmin,chmax,j + ENDDO + ENDIF + ENDDO +c +cIM14/03/2002 : Sea-ice Amip entre 0. et 1. + PRINT*,'SUB. limit_netcdf.F IM : Sea-ice Amipbc ' + DO k = 1, 360 + DO j = 1, jjp1 + DO i = 1, iim + champan(i, j, k) = + $ amax1(0.0,(amin1(1.0,(champan(i, j, k)/100.)))) + ENDDO + champan(iip1, j, k) = champan(1, j, k) + ENDDO + ENDDO +cIM14/03/2002 + + DO k = 1, 360 + CALL gr_dyn_fi(1, iip1, jjp1, klon, + . champan(1,1,k), phy_ice) + IF ( newlmt) THEN + +CPB en attendant de mettre fraction de terre +c + WHERE(phy_ice(1:klon) .GE. 1.) phy_ice(1 : klon) = 1. + WHERE(phy_ice(1:klon) .LT. EPSFRA) phy_ice(1 : klon) = 0. +c + IF (fracterre ) THEN +c WRITE(*,*) 'passe dans cas fracterre' + pctsrf_t(:,is_ter,k) = pctsrf(:,is_ter) + pctsrf_t(:,is_lic,k) = pctsrf(:,is_lic) + pctsrf_t(1:klon,is_sic,k) = phy_ice(1:klon) + $ - pctsrf_t(1:klon,is_lic,k) +c Il y a des cas ou il y a de la glace dans landiceref et pas dans AMIP + WHERE (pctsrf_t(1:klon,is_sic,k) .LE. 0) + pctsrf_t(1:klon,is_sic,k) = 0. + END WHERE + WHERE( 1. - zmasq(1:klon) .LT. EPSFRA) + pctsrf_t(1:klon,is_sic,k) = 0. + pctsrf_t(1:klon,is_oce,k) = 0. + END WHERE + DO i = 1, klon + IF ( 1. - zmasq(i) .GT. EPSFRA) THEN + IF ( pctsrf_t(i,is_sic,k) .GE. 1 - zmasq(i)) THEN + pctsrf_t(i,is_sic,k) = 1 - zmasq(i) + pctsrf_t(i,is_oce,k) = 0. + ELSE + pctsrf_t(i,is_oce,k) = 1 - zmasq(i) + $ - pctsrf_t(i,is_sic,k) + IF (pctsrf_t(i,is_oce,k) .LT. EPSFRA) THEN + pctsrf_t(i,is_oce,k) = 0. + pctsrf_t(i,is_sic,k) = 1 - zmasq(i) + ENDIF + ENDIF + ENDIF + if (pctsrf_t(i,is_oce,k) .lt. 0.) then + WRITE(*,*) 'pb sous maille au point : i,k ' + $ , i,k,pctsrf_t(:,is_oce,k) + ENDIF + IF ( abs( pctsrf_t(i, is_ter,k) + pctsrf_t(i, is_lic,k) + + $ pctsrf_t(i, is_oce,k) + pctsrf_t(i, is_sic,k) - 1.) + $ .GT. EPSFRA) THEN + WRITE(*,*) 'physiq : pb sous surface au point ', i, + $ pctsrf_t(i, 1 : nbsrf,k), phy_ice(i) + ENDIF + END DO + ELSE + DO i = 1, klon + pctsrf_t(i,is_ter,k) = pctsrf(i,is_ter) + IF (NINT(pctsrf(i,is_ter)).EQ.1 ) THEN + pctsrf_t(i,is_sic,k) = 0. + pctsrf_t(i,is_oce,k) = 0. + IF(phy_ice(i) .GE. 1.e-5) THEN + pctsrf_t(i,is_lic,k) = phy_ice(i) + pctsrf_t(i,is_ter,k) = pctsrf_t(i,is_ter,k) + . - pctsrf_t(i,is_lic,k) + ELSE + pctsrf_t(i,is_lic,k) = 0. + ENDIF + ELSE + pctsrf_t(i,is_lic,k) = 0. + IF(phy_ice(i) .GE. 1.e-5) THEN + pctsrf_t(i,is_ter,k) = 0. + pctsrf_t(i,is_sic,k) = phy_ice(i) + pctsrf_t(i,is_oce,k) = 1. - pctsrf_t(i,is_sic,k) + ELSE + pctsrf_t(i,is_sic,k) = 0. + pctsrf_t(i,is_oce,k) = 1. + ENDIF + ENDIF + verif = pctsrf_t(i,is_ter,k) + + . pctsrf_t(i,is_oce,k) + + . pctsrf_t(i,is_sic,k) + + . pctsrf_t(i,is_lic,k) + IF ( verif .LT. 1. - 1.e-5 .OR. + $ verif .GT. 1 + 1.e-5) THEN + WRITE(*,*) 'pb sous maille au point : i,k,verif ' + $ , i,k,verif + ENDIF + END DO + ENDIF + ELSE + DO i = 1, klon + phy_nat(i,k) = phy_nat0(i) + IF ( (phy_ice(i) - 0.5).GE.1.e-5 ) THEN + IF (NINT(phy_nat0(i)).EQ.0) THEN + phy_nat(i,k) = 3.0 + ELSE + phy_nat(i,k) = 2.0 + ENDIF + ENDIF + IF( NINT(phy_nat(i,k)).EQ.0 ) THEN + IF ( phy_rug(i,k).NE.0.001 ) phy_rug(i,k) = 0.001 + ENDIF + END DO + ENDIF + ENDDO +c + + ierr = NF_CLOSE(ncid) +c + DEALLOCATE( dlon ) + DEALLOCATE( dlon_ini ) + DEALLOCATE( dlat ) + DEALLOCATE( dlat_ini ) + DEALLOCATE( champ ) + +477 continue +c +C Traitement de la sst +c + PRINT*, 'Traitement de la sst' +c ierr = NF_OPEN('AMIP_SST.nc', NF_NOWRITE, ncid) + ierr = NF_OPEN('amipbc_sst_1x1.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) THEN + ierr = NF_OPEN('amipbc_sst_1x1_clim.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) THEN + print *, NF_STRERROR(ierr) + STOP + endif + ENDIF + +cIM22/02/2002 +cIM ierr = NF_INQ_VARID(ncid,'SST',varid) + ierr = NF_INQ_VARID(ncid,'tosbcs',varid) +cIM22/02/2002 + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable SST ', namedim,'dimension ', imdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( dlon_ini(imdep) ) + ALLOCATE( dlon(imdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini) +#endif + + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable SST ', namedim, 'dimension ', jmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( dlat_ini(jmdep) ) + ALLOCATE( dlat(jmdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', lmdep +cIM28/02/2002 +cPM28/02/2002 : nouvelle coord temporelle fichiers AMIP pas en jours +c Ici on suppose qu'on a 12 mois (de 30 jours). + IF (lmdep.NE.12) THEN + print *, 'Unknown AMIP file: not 12 months ?' + STOP + ENDIF +cIM28/02/2002 + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( champ(imdep*jmdep) ) + IF( extrap ) THEN + ALLOCATE ( work(imdep,jmdep) ) + ENDIF +c + DO l = 1, lmdep + dimfirst(1) = 1 + dimfirst(2) = 1 + dimfirst(3) = l +c + dimlast(1) = imdep + dimlast(2) = jmdep + dimlast(3) = 1 +c + PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l) +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ) +#else + ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + title='Sst Amip' +c + CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini, + . dlon, dlat, champ, interbar ) + IF ( extrap ) THEN + CALL extrapol(champ, imdep, jmdep, 999999.,.TRUE.,.TRUE.,2,work) + ENDIF +c + + IF ( interbar ) THEN + IF( l.EQ.1 ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour la Sst Amip $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + ENDIF + CALL inter_barxy ( imdep,jmdep -1,dlon, dlat , + , champ, iim, jjm, rlonu, rlatv, jjp1, champint ) + ELSE + CALL grille_m(imdep, jmdep, dlon, dlat, champ, + . iim, jjp1, rlonv, rlatu, champint ) + ENDIF + + DO j = 1,jjp1 + DO i = 1, iim + champtime (i,j,l) = champint(i,j) + ENDDO + ENDDO + ENDDO +c + DO l = 1, lmdep +cIM28/02/2002 <==PM timeyear(l) = timecoord(l) + timeyear(l) = tmidmonth(l) + ENDDO + print 222, timeyear(:lmdep) +c +C interpolation temporelle + DO j = 1, jjp1 + DO i = 1, iim + DO l = 1, lmdep + ax(l) = timeyear(l) + ay(l) = champtime (i,j,l) + ENDDO + CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder) + DO k = 1, 360 + time = FLOAT(k-1) + CALL SPLINT(ax,ay,yder,lmdep,time,by) + champan(i,j,k) = by + ENDDO + ENDDO + ENDDO + DO k = 1, 360 + DO j = 1, jjp1 + champan(iip1,j,k) = champan(1,j,k) + ENDDO + IF ( k.EQ.10 ) THEN + DO j = 1, jjp1 + CALL minmax( iip1,champan(1,j,10),chmin,chmax ) + PRINT *,' SST au temps 10 ', chmin,chmax,j + ENDDO + ENDIF + ENDDO +c +cIM14/03/2002 : SST amipbc greater then 271.38 + PRINT*,'SUB. limit_netcdf.F IM : SST Amipbc >= 271.38 ' + DO k = 1, 360 + DO j = 1, jjp1 + DO i = 1, iim + champan(i, j, k) = amax1(champan(i, j, k), 271.38) + ENDDO + champan(iip1, j, k) = champan(1, j, k) + ENDDO + ENDDO +cIM14/03/2002 + DO k = 1, 360 + CALL gr_dyn_fi(1, iip1, jjp1, klon, + . champan(1,1,k), phy_sst(1,k)) + ENDDO +c + ierr = NF_CLOSE(ncid) +c + DEALLOCATE( dlon ) + DEALLOCATE( dlon_ini ) + DEALLOCATE( dlat ) + DEALLOCATE( dlat_ini ) + DEALLOCATE( champ ) +c +C Traitement de l'albedo +c + PRINT*, 'Traitement de l albedo' + ierr = NF_OPEN('Albedo.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_VARID(ncid,'ALBEDO',varid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', imdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE ( dlon_ini(imdep) ) + ALLOCATE ( dlon(imdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', jmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE ( dlat_ini(jmdep) ) + ALLOCATE ( dlat(jmdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', lmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +c + ALLOCATE ( champ(imdep*jmdep) ) + + DO l = 1, lmdep + dimfirst(1) = 1 + dimfirst(2) = 1 + dimfirst(3) = l +c + dimlast(1) = imdep + dimlast(2) = jmdep + dimlast(3) = 1 +c + PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l) +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ) +#else + ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + title='Albedo Amip' +c + CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini, + . dlon, dlat, champ, interbar ) +c +c + IF ( interbar ) THEN + IF( l.EQ.1 ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour l Albedo Amip $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + ENDIF + + CALL inter_barxy ( imdep,jmdep -1,dlon, dlat , + , champ, iim, jjm, rlonu, rlatv, jjp1, champint ) + ELSE + CALL grille_m(imdep, jmdep, dlon, dlat, champ, + . iim, jjp1, rlonv, rlatu, champint ) + ENDIF +c + DO j = 1,jjp1 + DO i = 1, iim + champtime (i, j, l) = champint(i, j) + ENDDO + ENDDO + ENDDO +c + DO l = 1, lmdep + timeyear(l) = timecoord(l) + ENDDO + print 222, timeyear(:lmdep) +c +C interpolation temporelle + DO j = 1, jjp1 + DO i = 1, iim + DO l = 1, lmdep + ax(l) = timeyear(l) + ay(l) = champtime (i, j, l) + ENDDO + CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder) + DO k = 1, 360 + time = FLOAT(k-1) + CALL SPLINT(ax,ay,yder,lmdep,time,by) + champan(i,j,k) = by + ENDDO + ENDDO + ENDDO + DO k = 1, 360 + DO j = 1, jjp1 + champan(iip1, j, k) = champan(1, j, k) + ENDDO + IF ( k.EQ.10 ) THEN + DO j = 1, jjp1 + CALL minmax( iip1,champan(1,j,10),chmin,chmax ) + PRINT *,' Albedo au temps 10 ', chmin,chmax,j + ENDDO + ENDIF + ENDDO +c + DO k = 1, 360 + CALL gr_dyn_fi(1, iip1, jjp1, klon, + . champan(1,1,k), phy_alb(1,k)) + ENDDO +c + ierr = NF_CLOSE(ncid) +c +c + DO k = 1, 360 + DO i = 1, klon + phy_bil(i,k) = 0.0 + ENDDO + ENDDO +c + PRINT*, 'Ecriture du fichier limit' +c + ierr = NF_CREATE ("limit.nc", NF_CLOBBER, nid) +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 30, + . "Fichier conditions aux limites") + ierr = NF_DEF_DIM (nid, "points_physiques", klon, ndim) + ierr = NF_DEF_DIM (nid, "time", NF_UNLIMITED, ntim) +c + dims(1) = ndim + dims(2) = ntim +c +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "TEMPS", NF_DOUBLE, 1,ntim, id_tim) +#else + ierr = NF_DEF_VAR (nid, "TEMPS", NF_FLOAT, 1,ntim, id_tim) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_tim, "title", 17, + . "Jour dans l annee") + IF (newlmt) THEN +c +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "FOCE", NF_DOUBLE, 2,dims, id_FOCE) +#else + ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 2,dims, id_FOCE) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_FOCE, "title", 14, + . "Fraction ocean") +c +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "FSIC", NF_DOUBLE, 2,dims, id_FSIC) +#else + ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 2,dims, id_FSIC) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_FSIC, "title", 21, + . "Fraction glace de mer") +c +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "FTER", NF_DOUBLE, 2,dims, id_FTER) +#else + ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 2,dims, id_FTER) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_FTER, "title", 14, + . "Fraction terre") +c +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "FLIC", NF_DOUBLE, 2,dims, id_FLIC) +#else + ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 2,dims, id_FLIC) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_FLIC, "title", 17, + . "Fraction land ice") +c + ELSE +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "NAT", NF_DOUBLE, 2,dims, id_NAT) +#else + ierr = NF_DEF_VAR (nid, "NAT", NF_FLOAT, 2,dims, id_NAT) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_NAT, "title", 23, + . "Nature du sol (0,1,2,3)") + ENDIF +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "SST", NF_DOUBLE, 2,dims, id_SST) +#else + ierr = NF_DEF_VAR (nid, "SST", NF_FLOAT, 2,dims, id_SST) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_SST, "title", 35, + . "Temperature superficielle de la mer") +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "BILS", NF_DOUBLE, 2,dims, id_BILS) +#else + ierr = NF_DEF_VAR (nid, "BILS", NF_FLOAT, 2,dims, id_BILS) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_BILS, "title", 32, + . "Reference flux de chaleur au sol") +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "ALB", NF_DOUBLE, 2,dims, id_ALB) +#else + ierr = NF_DEF_VAR (nid, "ALB", NF_FLOAT, 2,dims, id_ALB) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_ALB, "title", 19, + . "Albedo a la surface") +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "RUG", NF_DOUBLE, 2,dims, id_RUG) +#else + ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_RUG, "title", 8, + . "Rugosite") +c + ierr = NF_ENDDEF(nid) +c + DO k = 1, 360 +c + debut(1) = 1 + debut(2) = k + epais(1) = klon + epais(2) = 1 +c +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR1_DOUBLE (nid,id_tim,k,DBLE(k)) +c + IF (newlmt ) THEN + ierr = NF_PUT_VARA_DOUBLE (nid,id_FOCE,debut,epais + $ ,pctsrf_t(1,is_oce,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_FSIC,debut,epais + $ ,pctsrf_t(1,is_sic,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_FTER,debut,epais + $ ,pctsrf_t(1,is_ter,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_FLIC,debut,epais + $ ,pctsrf_t(1,is_lic,k)) + ELSE + ierr = NF_PUT_VARA_DOUBLE (nid,id_NAT,debut,epais + $ ,phy_nat(1,k)) + ENDIF +c + ierr = NF_PUT_VARA_DOUBLE (nid,id_SST,debut,epais,phy_sst(1,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_BILS,debut,epais,phy_bil(1,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_ALB,debut,epais,phy_alb(1,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_RUG,debut,epais,phy_rug(1,k)) +#else + ierr = NF_PUT_VAR1_REAL (nid,id_tim,k,FLOAT(k)) + IF (newlmt ) THEN + ierr = NF_PUT_VARA_REAL (nid,id_FOCE,debut,epais + $ ,pctsrf_t(1,is_oce,k)) + ierr = NF_PUT_VARA_REAL (nid,id_FSIC,debut,epais + $ ,pctsrf_t(1,is_sic,k)) + ierr = NF_PUT_VARA_REAL (nid,id_FTER,debut,epais + $ ,pctsrf_t(1,is_ter,k)) + ierr = NF_PUT_VARA_REAL (nid,id_FLIC,debut,epais + $ ,pctsrf_t(1,is_lic,k)) + ELSE + ierr = NF_PUT_VARA_REAL (nid,id_NAT,debut,epais + $ ,phy_nat(1,k)) + ENDIF + ierr = NF_PUT_VARA_REAL (nid,id_SST,debut,epais,phy_sst(1,k)) + ierr = NF_PUT_VARA_REAL (nid,id_BILS,debut,epais,phy_bil(1,k)) + ierr = NF_PUT_VARA_REAL (nid,id_ALB,debut,epais,phy_alb(1,k)) + ierr = NF_PUT_VARA_REAL (nid,id_RUG,debut,epais,phy_rug(1,k)) +#endif +c + ENDDO +c + ierr = NF_CLOSE(nid) +c +#else + WRITE(lunout,*) + & 'limit_netcdf: Earth-specific routine, needs Earth physics' +#endif +! of #ifdef CPP_EARTH + STOP + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/limx.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/limx.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/limx.F (revision 1280) @@ -0,0 +1,109 @@ +! +! $Header$ +! + SUBROUTINE limx(s0,sx,sm,pente_max) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + real pente_max + REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm) + real sx(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + integer n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL q(ip1jmp1,llm) + real dxq(ip1jmp1,llm) + + + REAL new_m,zm + real dxqu(ip1jmp1) + real adxqu(ip1jmp1),dxqmax(ip1jmp1) + + Logical extremum,first + save first + + REAL SSUM,CVMGP,CVMGT + integer ismax,ismin + EXTERNAL SSUM, ismin,ismax + + data first/.true./ + + + DO l = 1,llm + DO ij=1,ip1jmp1 + q(ij,l) = s0(ij,l) / sm ( ij,l ) + dxq(ij,l) = sx(ij,l) /sm(ij,l) + ENDDO + ENDDO + +c calcul de la pente a droite et a gauche de la maille + + do l = 1, llm + do ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + enddo + do ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) + enddo + + do ij=iip2,ip1jm + adxqu(ij)=abs(dxqu(ij)) + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do ij=iip2+1,ip1jm + dxqmax(ij)=pente_max*min(adxqu(ij-1),adxqu(ij)) + enddo + + do ij=iip1+iip1,ip1jm,iip1 + dxqmax(ij-iim)=dxqmax(ij) + enddo + +c calcul de la pente avec limitation + + do ij=iip2+1,ip1jm + if( dxqu(ij-1)*dxqu(ij).gt.0. + & .and. dxq(ij,l)*dxqu(ij).gt.0.) then + dxq(ij,l)= + & sign(min(abs(dxq(ij,l)),dxqmax(ij)),dxq(ij,l)) + else +c extremum local + dxq(ij,l)=0. + endif + enddo + do ij=iip1+iip1,ip1jm,iip1 + dxq(ij-iim,l)=dxq(ij,l) + enddo + + DO ij=1,ip1jmp1 + sx(ij,l) = dxq(ij,l)*sm(ij,l) + ENDDO + + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/limy.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/limy.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/limy.F (revision 1280) @@ -0,0 +1,193 @@ +! +! $Header$ +! + SUBROUTINE limy(s0,sy,sm,pente_max) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,w sont des arguments d'entree pour le s-pg .... +c dq sont des arguments de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + real pente_max + real s0(ip1jmp1,llm),sy(ip1jmp1,llm),sm(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,ij,l +c + REAL q(ip1jmp1,llm) + REAL airej2,airejjm,airescb(iim),airesch(iim) + real sigv,dyq(ip1jmp1),dyqv(ip1jm) + real adyqv(ip1jm),dyqmax(ip1jmp1) + REAL qbyv(ip1jm,llm) + + REAL qpns,qpsn,apn,aps,dyn1,dys1,dyn2,dys2 + Logical extremum,first + save first + + real convpn,convps,convmpn,convmps + real sinlon(iip1),sinlondlon(iip1) + real coslon(iip1),coslondlon(iip1) + save sinlon,coslon,sinlondlon,coslondlon +c +c + REAL SSUM + integer ismax,ismin + EXTERNAL SSUM, ismin,ismax + + data first/.true./ + + if(first) then + print*,'SCHEMA AMONT NOUVEAU' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + enddo + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + endif + +c + + do l = 1, llm +c + DO ij=1,ip1jmp1 + q(ij,l) = s0(ij,l) / sm ( ij,l ) + dyq(ij) = sy(ij,l) / sm ( ij,l ) + ENDDO +c +c -------------------------------- +c CALCUL EN LATITUDE +c -------------------------------- + +c On commence par calculer la valeur du traceur moyenne sur le premier cercle +c de latitude autour du pole (qpns pour le pole nord et qpsn pour +c le pole nord) qui sera utilisee pour evaluer les pentes au pole. + + airej2 = SSUM( iim, aire(iip2), 1 ) + airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) + DO i = 1, iim + airescb(i) = aire(i+ iip1) * q(i+ iip1,l) + airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l) + ENDDO + qpns = SSUM( iim, airescb ,1 ) / airej2 + qpsn = SSUM( iim, airesch ,1 ) / airejjm + +c calcul des pentes aux points v + + do ij=1,ip1jm + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + adyqv(ij)=abs(dyqv(ij)) + ENDDO + +c calcul des pentes aux points scalaires + + do ij=iip2,ip1jm + dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) + dyqmax(ij)=pente_max*dyqmax(ij) + enddo + +c calcul des pentes aux poles + +c calcul des pentes limites aux poles + +c print*,dyqv(iip1+1) +c apn=abs(dyq(1)/dyqv(iip1+1)) +c print*,dyq(ip1jm+1) +c print*,dyqv(ip1jm-iip1+1) +c aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) +c do ij=2,iim +c apn=amax1(abs(dyq(ij)/dyqv(ij)),apn) +c aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps) +c enddo +c apn=min(pente_max/apn,1.) +c aps=min(pente_max/aps,1.) + + +c cas ou on a un extremum au pole + +c if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +c & apn=0. +c if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +c & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +c & aps=0. + +c limitation des pentes aux poles +c do ij=1,iip1 +c dyq(ij)=apn*dyq(ij) +c dyq(ip1jm+ij)=aps*dyq(ip1jm+ij) +c enddo + +c test +c do ij=1,iip1 +c dyq(iip1+ij)=0. +c dyq(ip1jm+ij-iip1)=0. +c enddo +c do ij=1,ip1jmp1 +c dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) +c enddo + + if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) + & then + do ij=1,iip1 + dyqmax(ij)=0. + enddo + else + do ij=1,iip1 + dyqmax(ij)=pente_max*abs(dyqv(ij)) + enddo + endif + + if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* + & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) + &then + do ij=ip1jm+1,ip1jmp1 + dyqmax(ij)=0. + enddo + else + do ij=ip1jm+1,ip1jmp1 + dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) + enddo + endif + +c calcul des pentes limitees + + do ij=1,ip1jmp1 + if(dyqv(ij)*dyqv(ij-iip1).gt.0.) then + dyq(ij)=sign(min(abs(dyq(ij)),dyqmax(ij)),dyq(ij)) + else + dyq(ij)=0. + endif + enddo + + DO ij=1,ip1jmp1 + sy(ij,l) = dyq(ij) * sm ( ij,l ) + ENDDO + + enddo ! fin de la boucle sur les couches verticales + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/limz.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/limz.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/limz.F (revision 1280) @@ -0,0 +1,99 @@ +! +! $Header$ +! + SUBROUTINE limz(s0,sz,sm,pente_max) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + real pente_max + REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm) + real sz(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + integer n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL q(ip1jmp1,llm) + real dzq(ip1jmp1,llm) + + + REAL new_m,zm + real dzqw(ip1jmp1) + real adzqw(ip1jmp1),dzqmax(ip1jmp1) + + Logical extremum,first + save first + + REAL SSUM,CVMGP,CVMGT + integer ismax,ismin + EXTERNAL SSUM, ismin,ismax + + data first/.true./ + + + DO l = 1,llm + DO ij=1,ip1jmp1 + q(ij,l) = s0(ij,l) / sm ( ij,l ) + dzq(ij,l) = sz(ij,l) /sm(ij,l) + ENDDO + ENDDO + +c calcul de la pente en haut et en bas de la maille + do ij=1,ip1jmp1 + do l = 1, llm-1 + dzqw(l)=q(ij,l+1)-q(ij,l) + enddo + dzqw(llm)=0. + + do l=1,llm + adzqw(l)=abs(dzqw(l)) + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do l=2,llm-1 + dzqmax(l)=pente_max*min(adzqw(l-1),adzqw(l)) + enddo + +c calcul de la pente avec limitation + + do l=2,llm-1 + if( dzqw(l-1)*dzqw(l).gt.0. + & .and. dzq(ij,l)*dzqw(l).gt.0.) then + dzq(ij,l)= + & sign(min(abs(dzq(ij,l)),dzqmax(l)),dzq(ij,l)) + else +c extremum local + dzq(ij,l)=0. + endif + enddo + + DO l=1,llm + sz(ij,l) = dzq(ij,l)*sm(ij,l) + ENDDO + + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/logic.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/logic.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/logic.h (revision 1280) @@ -0,0 +1,19 @@ +! +! $Header$ +! +! +! +!----------------------------------------------------------------------- +! INCLUDE 'logic.h' + + COMMON/logic/ purmats,iflag_phys,forward,leapf,apphys, & + & statcl,conser,apdiss,apdelq,saison,ecripar,fxyhypb,ysinus & + & ,read_start,ok_guide,ok_strato,ok_gradsfile + + LOGICAL purmats,forward,leapf,apphys,statcl,conser, & + & apdiss,apdelq,saison,ecripar,fxyhypb,ysinus & + & ,read_start,ok_guide,ok_strato,ok_gradsfile + + INTEGER iflag_phys +!$OMP THREADPRIVATE(/logic/) +!----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massbar.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massbar.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massbar.F (revision 1280) @@ -0,0 +1,100 @@ +! +! $Header$ +! + SUBROUTINE massbar( masse, massebx, masseby ) +c +c ********************************************************************** +c +c Calcule les moyennes en x et y de la masse d'air dans chaque maille. +c ********************************************************************** +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. masse est un argum. d'entree pour le s-pg ... +c .. massebx,masseby sont des argum. de sortie pour le s-pg ... +c +c +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c + REAL masse( ip1jmp1,llm ), massebx( ip1jmp1,llm ) , + * masseby( ip1jm,llm ) +c +c +c Methode pour calculer massebx et masseby . +c ---------------------------------------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c On a : +c +c massebx(i,j) = masse(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c masseby(i,j) = masse(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c +c======================================================================= + + DO 100 l = 1 , llm +c + DO ij = 1, ip1jmp1 - 1 + massebx(ij,l) = masse( ij, l) * alpha1p2( ij ) + + * masse(ij+1, l) * alpha3p4(ij+1 ) + ENDDO + +c .... correction pour massebx( iip1,j) ..... +c ... massebx(iip1,j)= massebx(1,j) ... +c +CDIR$ IVDEP + DO ij = iip1, ip1jmp1, iip1 + massebx( ij,l ) = massebx( ij - iim,l ) + ENDDO + + + DO ij = 1,ip1jm + masseby( ij,l ) = masse( ij , l ) * alpha2p3( ij ) + + * masse(ij+iip1, l ) * alpha1p4( ij+iip1 ) + ENDDO + +100 CONTINUE +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massbar_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massbar_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massbar_p.F (revision 1280) @@ -0,0 +1,117 @@ + SUBROUTINE massbar_p( masse, massebx, masseby ) + +c +c ********************************************************************** +c +c Calcule les moyennes en x et y de la masse d'air dans chaque maille. +c ********************************************************************** +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. masse est un argum. d'entree pour le s-pg ... +c .. massebx,masseby sont des argum. de sortie pour le s-pg ... +c +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c + REAL masse( ip1jmp1,llm ), massebx( ip1jmp1,llm ) , + * masseby( ip1jm,llm ) + INTEGER ij,l,ijb,ije +c +c +c Methode pour calculer massebx et masseby . +c ---------------------------------------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c On a : +c +c massebx(i,j) = masse(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c masseby(i,j) = masse(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c +c======================================================================= + + + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 100 l = 1 , llm +c + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ije-iip1 + + DO ij = ijb, ije - 1 + massebx(ij,l) = masse( ij, l) * alpha1p2( ij ) + + * masse(ij+1, l) * alpha3p4(ij+1 ) + ENDDO + +c .... correction pour massebx( iip1,j) ..... +c ... massebx(iip1,j)= massebx(1,j) ... +c +CDIR$ IVDEP + + + + DO ij = ijb+iim, ije+iim, iip1 + massebx( ij,l ) = massebx( ij - iim,l ) + ENDDO + + + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO ij = ijb,ije + masseby( ij,l ) = masse( ij , l ) * alpha2p3( ij ) + + * masse(ij+iip1, l ) * alpha1p4( ij+iip1 ) + ENDDO + +100 CONTINUE +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massbarxy.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massbarxy.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massbarxy.F (revision 1280) @@ -0,0 +1,47 @@ +! +! $Header$ +! + SUBROUTINE massbarxy( masse, massebxy ) +c +c ********************************************************************** +c +c Calcule les moyennes en x et y de la masse d'air dans chaque maille. +c ********************************************************************** +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. masse est un argum. d'entree pour le s-pg ... +c .. massebxy est un argum. de sortie pour le s-pg ... +c +c +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c + REAL masse( ip1jmp1,llm ), massebxy( ip1jm,llm ) +c + + DO 100 l = 1 , llm +c + DO 5 ij = 1, ip1jm - 1 + massebxy( ij,l ) = masse( ij ,l ) * alpha2( ij ) + + + masse( ij+1 ,l ) * alpha3( ij+1 ) + + + masse( ij+iip1,l ) * alpha1( ij+iip1 ) + + + masse( ij+iip2,l ) * alpha4( ij+iip2 ) + 5 CONTINUE + +c .... correction pour massebxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = iip1, ip1jm, iip1 + massebxy( ij,l ) = massebxy( ij - iim,l ) + 7 CONTINUE + +100 CONTINUE +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massbarxy_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massbarxy_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massbarxy_p.F (revision 1280) @@ -0,0 +1,55 @@ + SUBROUTINE massbarxy_p( masse, massebxy ) + USE parallel + implicit none +c ********************************************************************** +c +c Calcule les moyennes en x et y de la masse d'air dans chaque maille. +c ********************************************************************** +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. masse est un argum. d'entree pour le s-pg ... +c .. massebxy est un argum. de sortie pour le s-pg ... +c +c +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c + REAL masse( ip1jmp1,llm ), massebxy( ip1jm,llm ) +c + INTEGER ij,l,ijb,ije + + + ijb=ij_begin-iip1 + ije=ij_end + + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 100 l = 1 , llm +c + DO 5 ij = ijb, ije - 1 + massebxy( ij,l ) = masse( ij ,l ) * alpha2( ij ) + + + masse( ij+1 ,l ) * alpha3( ij+1 ) + + + masse( ij+iip1,l ) * alpha1( ij+iip1 ) + + + masse( ij+iip2,l ) * alpha4( ij+iip2 ) + 5 CONTINUE + +c .... correction pour massebxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = ijb+iip1-1, ije+iip1-1, iip1 + massebxy( ij,l ) = massebxy( ij - iim,l ) + 7 CONTINUE + +100 CONTINUE +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massdair.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massdair.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massdair.F (revision 1280) @@ -0,0 +1,109 @@ +! +! $Header$ +! + SUBROUTINE massdair( p, masse ) +c +c ********************************************************************* +c .... Calcule la masse d'air dans chaque maille .... +c ********************************************************************* +c +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. p est un argum. d'entree pour le s-pg ... +c .. masse est un argum.de sortie pour le s-pg ... +c +c .... p est defini aux interfaces des llm couches ..... +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c +c ..... arguments .... +c + REAL p(ip1jmp1,llmp1), masse(ip1jmp1,llm) + +c .... Variables locales ..... + + INTEGER l,ij + REAL massemoyn, massemoys + + REAL SSUM +c +c +c Methode pour calculer massebx et masseby . +c ---------------------------------------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c On a : +c +c massebx(i,j) = masse(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c masseby(i,j) = masse(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c +c======================================================================= + + DO 100 l = 1 , llm +c + DO ij = 1, ip1jmp1 + masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) ) + ENDDO +c + DO ij = 1, ip1jmp1,iip1 + masse(ij+ iim,l) = masse(ij,l) + ENDDO +c +c DO ij = 1, iim +c masse( ij ,l) = masse( ij ,l) * aire( ij ) +c masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm) +c ENDDO +c massemoyn = SSUM(iim,masse( 1 ,l),1)/ apoln +c massemoys = SSUM(iim,masse(ip1jm+1,l),1)/ apols +c DO ij = 1, iip1 +c masse( ij ,l ) = massemoyn +c masse(ij+ip1jm,l ) = massemoys +c ENDDO + +100 CONTINUE +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massdair_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massdair_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/massdair_p.F (revision 1280) @@ -0,0 +1,120 @@ + SUBROUTINE massdair_p( p, masse ) + USE parallel +c +c ********************************************************************* +c .... Calcule la masse d'air dans chaque maille .... +c ********************************************************************* +c +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. p est un argum. d'entree pour le s-pg ... +c .. masse est un argum.de sortie pour le s-pg ... +c +c .... p est defini aux interfaces des llm couches ..... +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c +c ..... arguments .... +c + REAL p(ip1jmp1,llmp1), masse(ip1jmp1,llm) + +c .... Variables locales ..... + + INTEGER l,ij + INTEGER ijb,ije + REAL massemoyn, massemoys + + REAL SSUM + EXTERNAL SSUM +c +c +c Methode pour calculer massebx et masseby . +c ---------------------------------------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c On a : +c +c massebx(i,j) = masse(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c masseby(i,j) = masse(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c +c======================================================================= + + + + + ijb=ij_begin-iip1 + ije=ij_end+2*iip1 + + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 100 l = 1 , llm +c + DO ij = ijb, ije + masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) ) + ENDDO +c + DO ij = ijb, ije,iip1 + masse(ij+ iim,l) = masse(ij,l) + ENDDO +c +c DO ij = 1, iim +c masse( ij ,l) = masse( ij ,l) * aire( ij ) +c masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm) +c ENDDO +c massemoyn = SSUM(iim,masse( 1 ,l),1)/ apoln +c massemoys = SSUM(iim,masse(ip1jm+1,l),1)/ apols +c DO ij = 1, iip1 +c masse( ij ,l ) = massemoyn +c masse(ij+ip1jm,l ) = massemoys +c ENDDO + +100 CONTINUE +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/minmax.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/minmax.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/minmax.F (revision 1280) @@ -0,0 +1,23 @@ +! +! $Header$ +! + SUBROUTINE minmax(imax, xi, zmin, zmax ) +c +c P. Le Van + + INTEGER imax + REAL xi(imax) + REAL zmin,zmax + INTEGER i + + zmin = xi(1) + zmax = xi(1) + + DO i = 2, imax + zmin = MIN( zmin,xi(i) ) + zmax = MAX( zmax,xi(i) ) + ENDDO + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/minmax2.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/minmax2.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/minmax2.F (revision 1280) @@ -0,0 +1,20 @@ +! +! $Header$ +! + SUBROUTINE minmax2(imax, jmax, lmax, xi, zmin, zmax ) +c + INTEGER lmax,jmax,imax + REAL xi(imax*jmax*lmax) + REAL zmin,zmax + INTEGER i + + zmin = xi(1) + zmax = xi(1) + + DO i = 2, imax*jmax*lmax + zmin = MIN( zmin,xi(i) ) + zmax = MAX( zmax,xi(i) ) + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/mod_const_para.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/mod_const_para.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/mod_const_para.F90 (revision 1280) @@ -0,0 +1,77 @@ +! +! $Id$ +! +MODULE mod_const_mpi + + INTEGER,SAVE :: COMM_LMDZ + INTEGER,SAVE :: MPI_REAL_LMDZ + + +CONTAINS + + SUBROUTINE Init_const_mpi +#ifdef CPP_IOIPSL + USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + USE ioipsl_getincom +#endif + + IMPLICIT NONE +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: ierr + INTEGER :: comp_id + INTEGER :: thread_required + INTEGER :: thread_provided + CHARACTER(len = 6) :: type_ocean + +!$OMP MASTER + type_ocean = 'force ' + CALL getin('type_ocean', type_ocean) +!$OMP END MASTER +!$OMP BARRIER + + IF (type_ocean=='couple') THEN +#ifdef CPP_COUPLE +!$OMP MASTER + CALL prism_init_comp_proto (comp_id, 'lmdz.x', ierr) + CALL prism_get_localcomm_proto(COMM_LMDZ,ierr) +!$OMP END MASTER +#endif +#ifdef CPP_MPI + MPI_REAL_LMDZ=MPI_REAL8 +#endif + ELSE + CALL init_mpi + ENDIF + + END SUBROUTINE Init_const_mpi + + SUBROUTINE Init_mpi + IMPLICIT NONE +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: ierr + INTEGER :: thread_required + INTEGER :: thread_provided + +#ifdef CPP_MPI +!$OMP MASTER + thread_required=MPI_THREAD_SERIALIZED + + CALL MPI_INIT_THREAD(thread_required,thread_provided,ierr) + IF (thread_provided < thread_required) THEN + PRINT *,'Warning : The multithreaded level of MPI librairy do not provide the requiered level', & + ' in mod_const_mpi::Init_const_mpi' + ENDIF + COMM_LMDZ=MPI_COMM_WORLD + MPI_REAL_LMDZ=MPI_REAL8 +!$OMP END MASTER +#endif + + END SUBROUTINE Init_mpi + +END MODULE mod_const_mpi Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/mod_hallo.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/mod_hallo.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/mod_hallo.F90 (revision 1280) @@ -0,0 +1,814 @@ +module mod_Hallo +USE parallel +implicit none + logical,save :: use_mpi_alloc + integer, parameter :: MaxRequest=200 + integer, parameter :: MaxProc=80 + integer, parameter :: MaxBufferSize=1024*1024*16 + integer, parameter :: ListSize=1000 + + integer,save :: MaxBufferSize_Used +!$OMP THREADPRIVATE( MaxBufferSize_Used) + + real,save,pointer,dimension(:) :: Buffer +!$OMP THREADPRIVATE(Buffer) + + integer,save,dimension(Listsize) :: Buffer_Pos + integer,save :: Index_Pos +!$OMP THREADPRIVATE(Buffer_Pos,Index_pos) + + type Hallo + real, dimension(:,:),pointer :: Field + integer :: offset + integer :: size + integer :: NbLevel + integer :: Stride + end type Hallo + + type request_SR + integer :: NbRequest=0 + integer :: Pos + integer :: Index + type(Hallo),dimension(MaxRequest) :: Hallo + integer :: MSG_Request + end type request_SR + + type request + type(request_SR),dimension(0:MaxProc-1) :: RequestSend + type(request_SR),dimension(0:MaxProc-1) :: RequestRecv + integer :: tag=1 + end type request + + + contains + + subroutine Init_mod_hallo + implicit none + + Index_Pos=1 + Buffer_Pos(Index_Pos)=1 + MaxBufferSize_Used=0 + + IF (use_mpi_alloc .AND. using_mpi) THEN + CALL create_global_mpi_buffer + ELSE + CALL create_standard_mpi_buffer + ENDIF + + end subroutine init_mod_hallo + + SUBROUTINE create_standard_mpi_buffer + IMPLICIT NONE + + ALLOCATE(Buffer(MaxBufferSize)) + + END SUBROUTINE create_standard_mpi_buffer + + SUBROUTINE create_global_mpi_buffer + IMPLICIT NONE +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + POINTER (Pbuffer,MPI_Buffer(MaxBufferSize)) + REAL :: MPI_Buffer +#ifdef CPP_MPI + INTEGER(KIND=MPI_ADDRESS_KIND) :: BS +#else + INTEGER(KIND=8) :: BS +#endif + INTEGER :: i,ierr + +! Allocation du buffer MPI + Bs=8*MaxBufferSize +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + CALL MPI_ALLOC_MEM(BS,MPI_INFO_NULL,Pbuffer,ierr) +#endif +!$OMP END CRITICAL (MPI) + DO i=1,MaxBufferSize + MPI_Buffer(i)=i + ENDDO + + CALL Associate_buffer(MPI_Buffer) + + CONTAINS + + SUBROUTINE Associate_buffer(MPI_Buffer) + IMPLICIT NONE + REAL,DIMENSION(:),target :: MPI_Buffer + + Buffer=>MPI_Buffer + + END SUBROUTINE Associate_buffer + + END SUBROUTINE create_global_mpi_buffer + + + subroutine allocate_buffer(Size,Index,Pos) + implicit none + integer :: Size + integer :: Index + integer :: Pos + + if (Buffer_pos(Index_pos)+Size>MaxBufferSize_Used) MaxBufferSize_Used=Buffer_pos(Index_pos)+Size + if (Buffer_pos(Index_pos)+Size>MaxBufferSize) then + print *,'STOP :: La taille de MaxBufferSize dans mod_hallo.F90 est trop petite !!!!' + stop + endif + + if (Index_pos>=ListSize) then + print *,'STOP :: La taille de ListSize dans mod_hallo.F90 est trop petite !!!!' + stop + endif + + Pos=Buffer_Pos(Index_Pos) + Buffer_Pos(Index_pos+1)=Buffer_Pos(Index_Pos)+Size + Index_Pos=Index_Pos+1 + Index=Index_Pos + + end subroutine allocate_buffer + + subroutine deallocate_buffer(Index) + implicit none + integer :: Index + + Buffer_Pos(Index)=-1 + + do while (Buffer_Pos(Index_Pos)==-1 .and. Index_Pos>1) + Index_Pos=Index_Pos-1 + end do + + end subroutine deallocate_buffer + + subroutine SetTag(a_request,tag) + implicit none + type(request):: a_request + integer :: tag + + a_request%tag=tag + end subroutine SetTag + + + subroutine Init_Hallo(Field,Stride,NbLevel,offset,size,NewHallo) + integer :: Stride + integer :: NbLevel + integer :: size + integer :: offset + real, dimension(Stride,NbLevel),target :: Field + type(Hallo) :: NewHallo + + NewHallo%Field=>Field + NewHallo%Stride=Stride + NewHallo%NbLevel=NbLevel + NewHallo%size=size + NewHallo%offset=offset + + + end subroutine Init_Hallo + + subroutine Register_SendField(Field,ij,ll,offset,size,target,a_request) + implicit none + +#include "dimensions.h" +#include "paramet.h" + + INTEGER :: ij,ll,offset,size,target + REAL, dimension(ij,ll) :: Field + type(request),target :: a_request + type(request_SR),pointer :: Ptr_request + + Ptr_Request=>a_request%RequestSend(target) + Ptr_Request%NbRequest=Ptr_Request%NbRequest+1 + if (Ptr_Request%NbRequest>=MaxRequest) then + print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!' + stop + endif + call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest)) + + end subroutine Register_SendField + + subroutine Register_RecvField(Field,ij,ll,offset,size,target,a_request) + implicit none + +#include "dimensions.h" +#include "paramet.h" + + INTEGER :: ij,ll,offset,size,target + REAL, dimension(ij,ll) :: Field + type(request),target :: a_request + type(request_SR),pointer :: Ptr_request + + Ptr_Request=>a_request%RequestRecv(target) + Ptr_Request%NbRequest=Ptr_Request%NbRequest+1 + + if (Ptr_Request%NbRequest>=MaxRequest) then + print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!' + stop + endif + + call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest)) + + + end subroutine Register_RecvField + + subroutine Register_SwapField(FieldS,FieldR,ij,ll,jj_Nb_New,a_request) + + implicit none +#include "dimensions.h" +#include "paramet.h" + + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: FieldS + REAL, dimension(ij,ll) :: FieldR + type(request) :: a_request + integer,dimension(0:MPI_Size-1) :: jj_Nb_New + integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New + + integer ::i,jje,jjb + + jj_begin_New(0)=1 + jj_End_New(0)=jj_Nb_New(0) + do i=1,MPI_Size-1 + jj_begin_New(i)=jj_end_New(i-1)+1 + jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1 + enddo + + do i=0,MPI_Size-1 + if (i /= MPI_Rank) then + jjb=max(jj_begin_new(i),jj_begin) + jje=min(jj_end_new(i),jj_end) + + if (ij==ip1jm .and. jje==jjp1) jje=jjm + + if (jje >= jjb) then + call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) + endif + + jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i)) + jje=min(jj_end_new(MPI_Rank),jj_end_Para(i)) + + if (ij==ip1jm .and. jje==jjp1) jje=jjm + + if (jje >= jjb) then + call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) + endif + + endif + enddo + + end subroutine Register_SwapField + + + subroutine Register_SwapFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down,a_request) + + implicit none +#include "dimensions.h" +#include "paramet.h" + + INTEGER :: ij,ll,Up,Down + REAL, dimension(ij,ll) :: FieldS + REAL, dimension(ij,ll) :: FieldR + type(request) :: a_request + integer,dimension(0:MPI_Size-1) :: jj_Nb_New + integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New + + integer ::i,jje,jjb + + jj_begin_New(0)=1 + jj_End_New(0)=jj_Nb_New(0) + do i=1,MPI_Size-1 + jj_begin_New(i)=jj_end_New(i-1)+1 + jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1 + enddo + + do i=0,MPI_Size-1 + jj_begin_New(i)=max(1,jj_begin_New(i)-Up) + jj_end_New(i)=min(jjp1,jj_end_new(i)+Down) + enddo + + do i=0,MPI_Size-1 + if (i /= MPI_Rank) then + jjb=max(jj_begin_new(i),jj_begin) + jje=min(jj_end_new(i),jj_end) + + if (ij==ip1jm .and. jje==jjp1) jje=jjm + + if (jje >= jjb) then + call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) + endif + + jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i)) + jje=min(jj_end_new(MPI_Rank),jj_end_Para(i)) + + if (ij==ip1jm .and. jje==jjp1) jje=jjm + + if (jje >= jjb) then + call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) + endif + + endif + enddo + + end subroutine Register_SwapFieldHallo + + subroutine Register_Hallo(Field,ij,ll,RUp,Rdown,SUp,SDown,a_request) + + implicit none +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: Sup,Sdown,rup,rdown + type(request) :: a_request + type(Hallo),pointer :: PtrHallo + LOGICAL :: SendUp,SendDown + LOGICAL :: RecvUp,RecvDown + + + SendUp=.TRUE. + SendDown=.TRUE. + RecvUp=.TRUE. + RecvDown=.TRUE. + + IF (pole_nord) THEN + SendUp=.FALSE. + RecvUp=.FALSE. + ENDIF + + IF (pole_sud) THEN + SendDown=.FALSE. + RecvDown=.FALSE. + ENDIF + + if (Sup.eq.0) then + SendUp=.FALSE. + endif + + if (Sdown.eq.0) then + SendDown=.FALSE. + endif + + if (Rup.eq.0) then + RecvUp=.FALSE. + endif + + if (Rdown.eq.0) then + RecvDown=.FALSE. + endif + + IF (SendUp) THEN + call Register_SendField(Field,ij,ll,jj_begin,SUp,MPI_Rank-1,a_request) + ENDIF + + IF (SendDown) THEN + call Register_SendField(Field,ij,ll,jj_end-SDown+1,SDown,MPI_Rank+1,a_request) + ENDIF + + + IF (RecvUp) THEN + call Register_RecvField(Field,ij,ll,jj_begin-Rup,RUp,MPI_Rank-1,a_request) + ENDIF + + IF (RecvDown) THEN + call Register_RecvField(Field,ij,ll,jj_end+1,RDown,MPI_Rank+1,a_request) + ENDIF + + end subroutine Register_Hallo + + subroutine SendRequest(a_Request) + implicit none + +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + + type(request),target :: a_request + type(request_SR),pointer :: Req + type(Hallo),pointer :: PtrHallo + integer :: SizeBuffer + integer :: i,rank,l,ij,Pos,ierr + integer :: offset + real,dimension(:,:),pointer :: Field + integer :: Nb + + do rank=0,MPI_SIZE-1 + + Req=>a_Request%RequestSend(rank) + + SizeBuffer=0 + do i=1,Req%NbRequest + PtrHallo=>Req%Hallo(i) +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,PtrHallo%NbLevel + SizeBuffer=SizeBuffer+PtrHallo%size*iip1 + ENDDO +!$OMP ENDDO NOWAIT + enddo + + if (SizeBuffer>0) then + + call allocate_buffer(SizeBuffer,Req%Index,Req%pos) + + Pos=Req%Pos + do i=1,Req%NbRequest + PtrHallo=>Req%Hallo(i) + offset=(PtrHallo%offset-1)*iip1+1 + Nb=iip1*PtrHallo%size-1 + Field=>PtrHallo%Field + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,PtrHallo%NbLevel +!cdir NODEP + do ij=0,Nb + Buffer(Pos+ij)=Field(Offset+ij,l) + enddo + + Pos=Pos+Nb+1 + enddo +!$OMP END DO NOWAIT + enddo + +!$OMP CRITICAL (MPI) + +#ifdef CPP_MPI + call MPI_ISSEND(Buffer(req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank, & + COMM_LMDZ,Req%MSG_Request,ierr) +#endif + IF (.NOT.using_mpi) THEN + PRINT *,'Erreur, echange MPI en mode sequentiel !!!' + STOP + ENDIF +! PRINT *,"-------------------------------------------------------------------" +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->" +! PRINT *,"Requete envoye au proc :",rank,"tag :",a_request%tag+1000*omp_rank +! PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request +! PRINT *,"-------------------------------------------------------------------" +!$OMP END CRITICAL (MPI) + endif + + enddo + + + do rank=0,MPI_SIZE-1 + + Req=>a_Request%RequestRecv(rank) + SizeBuffer=0 + + do i=1,Req%NbRequest + PtrHallo=>Req%Hallo(i) + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,PtrHallo%NbLevel + SizeBuffer=SizeBuffer+PtrHallo%size*iip1 + ENDDO +!$OMP ENDDO NOWAIT + enddo + + if (SizeBuffer>0) then + + call allocate_buffer(SizeBuffer,Req%Index,Req%Pos) +!$OMP CRITICAL (MPI) + +#ifdef CPP_MPI + call MPI_IRECV(Buffer(Req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank, & + COMM_LMDZ,Req%MSG_Request,ierr) +#endif + IF (.NOT.using_mpi) THEN + PRINT *,'Erreur, echange MPI en mode sequentiel !!!' + STOP + ENDIF + +! PRINT *,"-------------------------------------------------------------------" +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->" +! PRINT *,"Requete en attente du proc :",rank,"tag :",a_request%tag+1000*omp_rank +! PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request +! PRINT *,"-------------------------------------------------------------------" + +!$OMP END CRITICAL (MPI) + endif + + enddo + + end subroutine SendRequest + + subroutine WaitRequest(a_Request) + implicit none + +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + + type(request),target :: a_request + type(request_SR),pointer :: Req + type(Hallo),pointer :: PtrHallo + integer, dimension(2*mpi_size) :: TabRequest +#ifdef CPP_MPI + integer, dimension(MPI_STATUS_SIZE,2*mpi_size) :: TabStatus +#else + integer, dimension(1,2*mpi_size) :: TabStatus +#endif + integer :: NbRequest + integer :: i,rank,pos,ij,l,ierr + integer :: offset + integer :: Nb + + + NbRequest=0 + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestSend(rank) + if (Req%NbRequest>0) then + NbRequest=NbRequest+1 + TabRequest(NbRequest)=Req%MSG_Request + endif + enddo + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0) then + NbRequest=NbRequest+1 + TabRequest(NbRequest)=Req%MSG_Request + endif + enddo + + if (NbRequest>0) then +!$OMP CRITICAL (MPI) +! PRINT *,"-------------------------------------------------------------------" +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente" +! PRINT *,"No des requetes :",TabRequest(1:NbRequest) +#ifdef CPP_MPI + call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr) +#endif +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete" +! PRINT *,"-------------------------------------------------------------------" +!$OMP END CRITICAL (MPI) + endif + do rank=0,MPI_Size-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0) then + Pos=Req%Pos + do i=1,Req%NbRequest + PtrHallo=>Req%Hallo(i) + offset=(PtrHallo%offset-1)*iip1+1 + Nb=iip1*PtrHallo%size-1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,PtrHallo%NbLevel +!cdir NODEP + do ij=0,Nb + PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij) + enddo + + Pos=Pos+Nb+1 + enddo +!$OMP ENDDO NOWAIT + enddo + endif + enddo + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestSend(rank) + if (Req%NbRequest>0) then + call deallocate_buffer(Req%Index) + Req%NbRequest=0 + endif + enddo + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0) then + call deallocate_buffer(Req%Index) + Req%NbRequest=0 + endif + enddo + + a_request%tag=1 + end subroutine WaitRequest + + subroutine WaitSendRequest(a_Request) + implicit none + +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + type(request),target :: a_request + type(request_SR),pointer :: Req + type(Hallo),pointer :: PtrHallo + integer, dimension(mpi_size) :: TabRequest +#ifdef CPP_MPI + integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus +#else + integer, dimension(1,mpi_size) :: TabStatus +#endif + integer :: NbRequest + integer :: i,rank,pos,ij,l,ierr + integer :: offset + + + NbRequest=0 + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestSend(rank) + if (Req%NbRequest>0) then + NbRequest=NbRequest+1 + TabRequest(NbRequest)=Req%MSG_Request + endif + enddo + + + if (NbRequest>0) THEN +!$OMP CRITICAL (MPI) +! PRINT *,"-------------------------------------------------------------------" +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente" +! PRINT *,"No des requetes :",TabRequest(1:NbRequest) +#ifdef CPP_MPI + call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr) +#endif +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete" +! PRINT *,"-------------------------------------------------------------------" + +!$OMP END CRITICAL (MPI) + endif + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestSend(rank) + if (Req%NbRequest>0) then + call deallocate_buffer(Req%Index) + Req%NbRequest=0 + endif + enddo + + a_request%tag=1 + end subroutine WaitSendRequest + + subroutine WaitRecvRequest(a_Request) + implicit none + +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + + type(request),target :: a_request + type(request_SR),pointer :: Req + type(Hallo),pointer :: PtrHallo + integer, dimension(mpi_size) :: TabRequest +#ifdef CPP_MPI + integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus +#else + integer, dimension(1,mpi_size) :: TabStatus +#endif + integer :: NbRequest + integer :: i,rank,pos,ij,l,ierr + integer :: offset,Nb + + + NbRequest=0 + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0) then + NbRequest=NbRequest+1 + TabRequest(NbRequest)=Req%MSG_Request + endif + enddo + + + if (NbRequest>0) then +!$OMP CRITICAL (MPI) +! PRINT *,"-------------------------------------------------------------------" +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente" +! PRINT *,"No des requetes :",TabRequest(1:NbRequest) +#ifdef CPP_MPI + call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr) +#endif +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete" +! PRINT *,"-------------------------------------------------------------------" +!$OMP END CRITICAL (MPI) + endif + + do rank=0,MPI_Size-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0) then + Pos=Req%Pos + do i=1,Req%NbRequest + PtrHallo=>Req%Hallo(i) + offset=(PtrHallo%offset-1)*iip1+1 + Nb=iip1*PtrHallo%size-1 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,PtrHallo%NbLevel +!cdir NODEP + do ij=0,Nb + PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij) + enddo + Pos=Pos+Nb+1 + enddo +!$OMP END DO NOWAIT + enddo + endif + enddo + + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0) then + call deallocate_buffer(Req%Index) + Req%NbRequest=0 + endif + enddo + + a_request%tag=1 + end subroutine WaitRecvRequest + + + + subroutine CopyField(FieldS,FieldR,ij,ll,jj_Nb_New) + + implicit none +#include "dimensions.h" +#include "paramet.h" + + INTEGER :: ij,ll,l + REAL, dimension(ij,ll) :: FieldS + REAL, dimension(ij,ll) :: FieldR + integer,dimension(0:MPI_Size-1) :: jj_Nb_New + integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New + + integer ::i,jje,jjb,ijb,ije + + jj_begin_New(0)=1 + jj_End_New(0)=jj_Nb_New(0) + do i=1,MPI_Size-1 + jj_begin_New(i)=jj_end_New(i-1)+1 + jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1 + enddo + + jjb=max(jj_begin,jj_begin_new(MPI_Rank)) + jje=min(jj_end,jj_end_new(MPI_Rank)) + if (ij==ip1jm) jje=min(jje,jjm) + + if (jje >= jjb) then + ijb=(jjb-1)*iip1+1 + ije=jje*iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,ll + FieldR(ijb:ije,l)=FieldS(ijb:ije,l) + enddo +!$OMP ENDDO NOWAIT + endif + + + end subroutine CopyField + + subroutine CopyFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down) + + implicit none +#include "dimensions.h" +#include "paramet.h" + + INTEGER :: ij,ll,Up,Down + REAL, dimension(ij,ll) :: FieldS + REAL, dimension(ij,ll) :: FieldR + integer,dimension(0:MPI_Size-1) :: jj_Nb_New + integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New + + integer ::i,jje,jjb,ijb,ije,l + + + jj_begin_New(0)=1 + jj_End_New(0)=jj_Nb_New(0) + do i=1,MPI_Size-1 + jj_begin_New(i)=jj_end_New(i-1)+1 + jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1 + enddo + + + jjb=max(jj_begin,jj_begin_new(MPI_Rank)-Up) + jje=min(jj_end,jj_end_new(MPI_Rank)+Down) + if (ij==ip1jm) jje=min(jje,jjm) + + + if (jje >= jjb) then + ijb=(jjb-1)*iip1+1 + ije=jje*iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,ll + FieldR(ijb:ije,l)=FieldS(ijb:ije,l) + enddo +!$OMP ENDDO NOWAIT + + endif + end subroutine CopyFieldHallo + +end module mod_Hallo + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/mod_interface_dyn_phys.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/mod_interface_dyn_phys.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/mod_interface_dyn_phys.F90 (revision 1280) @@ -0,0 +1,59 @@ +! +! $Id$ +! +MODULE mod_interface_dyn_phys + INTEGER,SAVE,dimension(:),allocatable :: index_i + INTEGER,SAVE,dimension(:),allocatable :: index_j + + +#ifdef CPP_EARTH +! Interface with parallel physics, +! for now this routine only works with Earth physics +CONTAINS + + SUBROUTINE Init_interface_dyn_phys + USE mod_phys_lmdz_mpi_data + IMPLICIT NONE + include 'dimensions.h' + + INTEGER :: i,j,k + + ALLOCATE(index_i(klon_mpi)) + ALLOCATE(index_j(klon_mpi)) + + k=1 + IF (is_north_pole) THEN + index_i(k)=1 + index_j(k)=1 + k=2 + ELSE + DO i=ii_begin,iim + index_i(k)=i + index_j(k)=jj_begin + k=k+1 + ENDDO + ENDIF + + DO j=jj_begin+1,jj_end-1 + DO i=1,iim + index_i(k)=i + index_j(k)=j + k=k+1 + ENDDO + ENDDO + + IF (is_south_pole) THEN + index_i(k)=1 + index_j(k)=jj_end + ELSE + DO i=1,ii_end + index_i(k)=i + index_j(k)=jj_end + k=k+1 + ENDDO + ENDIF + + END SUBROUTINE Init_interface_dyn_phys +#endif +! of #ifdef CPP_EARTH +END MODULE mod_interface_dyn_phys Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrad.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrad.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrad.F (revision 1280) @@ -0,0 +1,48 @@ +! +! $Header$ +! + SUBROUTINE nxgrad (klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij +c +c + DO 10 l = 1,klevel +c + DO 1 ij = 2, ip1jm + y( ij,l ) = ( rot( ij,l ) - rot( ij-1,l ) ) * cvsurcuv( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = 1, ip1jm, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + DO 4 ij = iip2,ip1jm + x( ij,l ) = ( rot( ij,l ) - rot( ij -iip1,l ) ) * cusurcvu( ij ) + 4 CONTINUE + DO 6 ij = 1,iip1 + x( ij ,l ) = 0. + x( ij +ip1jm,l ) = 0. + 6 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrad_gam.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrad_gam.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrad_gam.F (revision 1280) @@ -0,0 +1,47 @@ +! +! $Header$ +! + SUBROUTINE nxgrad_gam( klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij +c + DO 10 l = 1,klevel +c + DO 1 ij = 2, ip1jm + y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = 1, ip1jm, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + DO 4 ij = iip2,ip1jm + x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij ) + 4 CONTINUE + DO 6 ij = 1,iip1 + x( ij ,l ) = 0. + x( ij +ip1jm,l ) = 0. + 6 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrad_gam_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrad_gam_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrad_gam_p.F (revision 1280) @@ -0,0 +1,67 @@ + SUBROUTINE nxgrad_gam_p( klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij + integer ismin,ismax + external ismin,ismax + INTEGER :: ijb,ije +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + + DO 1 ij = ijb+1, ije + y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = ijb, ije, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + ijb=ij_begin + ije=ij_end+iip1 + if(pole_nord) ijb=ij_begin+iip1 + if(pole_sud) ije=ij_end-iip1 + + DO 4 ij = ijb,ije + x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij ) + 4 CONTINUE + + if (pole_nord) then + DO ij = 1,iip1 + x( ij ,l ) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1,iip1 + x( ij +ip1jm,l ) = 0. + ENDDO + endif +c + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrad_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrad_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrad_p.F (revision 1280) @@ -0,0 +1,67 @@ + SUBROUTINE nxgrad_p (klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij + INTEGER :: ijb,ije +c +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO 1 ij = ijb+1, ije + y( ij,l ) = ( rot( ij,l ) - rot( ij-1,l ) ) * cvsurcuv( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = ijb, ije, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + ijb=ij_begin + ije=ij_end+iip1 + + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO 4 ij = ijb,ije + x( ij,l ) = ( rot( ij,l ) - rot( ij -iip1,l ) ) * cusurcvu( ij ) + 4 CONTINUE + + if (pole_nord) then + DO ij = 1,iip1 + x( ij ,l ) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1,iip1 + x( ij +ip1jm,l ) = 0. + ENDDO + endif +c + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgradst.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgradst.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgradst.F (revision 1280) @@ -0,0 +1,47 @@ +! +! $Header$ +! + SUBROUTINE nxgradst (klevel,rot, x, y ) +c + IMPLICIT NONE +c Auteur : P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij +c + DO 10 l = 1,klevel +c + DO 1 ij = 2, ip1jm + y(ij,l)=( rot(ij,l) - rot(ij-1,l)) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... + + DO 2 ij = 1, ip1jm, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + DO 4 ij = iip2,ip1jm + x(ij,l)= rot(ij,l)-rot(ij-iip1,l) + 4 CONTINUE + DO 6 ij = 1,iip1 + x( ij ,l ) = 0. + x( ij +ip1jm,l ) = 0. + 6 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgraro2.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgraro2.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgraro2.F (revision 1280) @@ -0,0 +1,68 @@ +! +! $Header$ +! + SUBROUTINE nxgraro2 (klevel,xcov, ycov, lr, grx, gry ) +c +c P.Le Van . +c *********************************************************** +c lr +c calcul de ( nxgrad (rot) ) du vect. v .... +c +c xcov et ycov etant les compos. covariantes de v +c *********************************************************** +c xcov , ycov et lr sont des arguments d'entree pour le s-prog +c grx et gry sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +c +c ...... variables en arguments ....... +c + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL grx( ip1jmp1,klevel ), gry( ip1jm,klevel ) +c +c ...... variables locales ........ +c + REAL rot(ip1jm,llm) , signe, nugradrs + INTEGER l,ij,iter,lr +c ........................................................ +c +c +c + signe = (-1.)**lr + nugradrs = signe * crot +c + CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 ) + CALL SCOPY ( ip1jm * klevel, ycov, 1, gry, 1 ) +c + CALL rotatf ( klevel, grx, gry, rot ) +c + CALL laplacien_rot ( klevel, rot, rot,grx,gry ) + +c +c ..... Iteration de l'operateur laplacien_rotgam ..... +c + DO iter = 1, lr -2 + CALL laplacien_rotgam ( klevel, rot, rot ) + ENDDO +c +c + CALL filtreg( rot, jjm, klevel, 2,1, .FALSE.,1) + CALL nxgrad ( klevel, rot, grx, gry ) +c + DO l = 1, klevel + DO ij = 1, ip1jm + gry( ij,l ) = gry( ij,l ) * nugradrs + ENDDO + DO ij = 1, ip1jmp1 + grx( ij,l ) = grx( ij,l ) * nugradrs + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgraro2_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgraro2_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgraro2_p.F (revision 1280) @@ -0,0 +1,141 @@ + SUBROUTINE nxgraro2_p (klevel,xcov, ycov, lr, grx_out, gry_out ) +c +c P.Le Van . +c *********************************************************** +c lr +c calcul de ( nxgrad (rot) ) du vect. v .... +c +c xcov et ycov etant les compos. covariantes de v +c *********************************************************** +c xcov , ycov et lr sont des arguments d'entree pour le s-prog +c grx et gry sont des arguments de sortie pour le s-prog +c +c + USE write_Field_p + USE parallel + USE times + USE mod_hallo + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +c +c ...... variables en arguments ....... +c + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL,SAVE :: grx( ip1jmp1,llm ), gry( ip1jm,llm ) + REAL grx_out( ip1jmp1,klevel ), gry_out( ip1jm,klevel ) +c +c ...... variables locales ........ +c + REAL,SAVE :: rot(ip1jm,llm) + REAL signe, nugradrs + INTEGER l,ij,iter,lr + Type(Request) :: Request_dissip +c ........................................................ +c + INTEGER :: ijb,ije,jjb,jje + +c +c + signe = (-1.)**lr + nugradrs = signe * crot +c +c CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 ) +c CALL SCOPY ( ip1jm * klevel, ycov, 1, gry, 1 ) + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + grx(ijb:ije,l)=xcov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c$OMP BARRIER + call Register_Hallo(grx,ip1jmp1,llm,0,1,1,0,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + gry(ijb:ije,l)=ycov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c + CALL rotatf_p ( klevel, grx, gry, rot ) +c call write_field3d_p('rot1',reshape(rot,(/iip1,jjm,llm/))) + +c$OMP BARRIER + call Register_Hallo(rot,ip1jm,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL laplacien_rot_p ( klevel, rot, rot,grx,gry ) +c call write_field3d_p('rot2',reshape(rot,(/iip1,jjm,llm/))) +c +c ..... Iteration de l'operateur laplacien_rotgam ..... +c + DO iter = 1, lr -2 +c$OMP BARRIER + call Register_Hallo(rot,ip1jm,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL laplacien_rotgam_p ( klevel, rot, rot ) + ENDDO + +c call write_field3d_p('rot3',reshape(rot,(/iip1,jjm,llm/))) + +c +c + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + CALL filtreg_p( rot, jjb,jje,jjm, klevel, 2,1, .FALSE.,1) +c$OMP BARRIER + call Register_Hallo(rot,ip1jm,llm,1,0,0,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL nxgrad_p ( klevel, rot, grx, gry ) + +c + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + + if(pole_sud) ije=ij_end-iip1 + DO ij = ijb, ije + gry_out( ij,l ) = gry( ij,l ) * nugradrs + ENDDO + + if(pole_sud) ije=ij_end + DO ij = ijb, ije + grx_out( ij,l ) = grx( ij,l ) * nugradrs + ENDDO + + ENDDO +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrarot.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrarot.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrarot.F (revision 1280) @@ -0,0 +1,55 @@ +! +! $Header$ +! + SUBROUTINE nxgrarot (klevel,xcov, ycov, lr, grx, gry ) +c *********************************************************** +c +c Auteur : P.Le Van +c +c lr +c calcul de ( nXgrad (rot) ) du vect. v .... +c +c xcov et ycov etant les compos. covariantes de v +c *********************************************************** +c xcov , ycov et lr sont des arguments d'entree pour le s-prog +c grx et gry sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "logic.h" +c + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL grx( ip1jmp1,klevel ), gry( ip1jm,klevel ) +c + REAL rot(ip1jm,llm) + + INTEGER l,ij,iter,lr +c +c +c + CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 ) + CALL SCOPY ( ip1jm*klevel, ycov, 1, gry, 1 ) +c + DO 10 iter = 1,lr + CALL rotat (klevel,grx, gry, rot ) + CALL filtreg( rot, jjm, klevel, 2,1, .false.,2) + CALL nxgrad (klevel,rot, grx, gry ) +c + DO 5 l = 1, klevel + DO 2 ij = 1, ip1jm + gry( ij,l ) = - gry( ij,l ) * crot + 2 CONTINUE + DO 3 ij = 1, ip1jmp1 + grx( ij,l ) = - grx( ij,l ) * crot + 3 CONTINUE + 5 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrarot_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrarot_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/nxgrarot_p.F (revision 1280) @@ -0,0 +1,101 @@ + SUBROUTINE nxgrarot_p (klevel,xcov, ycov, lr, grx_out, gry_out ) +c *********************************************************** +c +c Auteur : P.Le Van +c +c lr +c calcul de ( nXgrad (rot) ) du vect. v .... +c +c xcov et ycov etant les compos. covariantes de v +c *********************************************************** +c xcov , ycov et lr sont des arguments d'entree pour le s-prog +c grx et gry sont des arguments de sortie pour le s-prog +c +c + USE parallel + USE times + USE write_field_p + IMPLICIT NONE +c +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "logic.h" +c + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL grx_out( ip1jmp1,klevel ), gry_out( ip1jm,klevel ) + REAL,SAVE :: grx( ip1jmp1,llm ), gry( ip1jm,llm ) + +c + REAL,SAVE :: rot(ip1jm,llm) + + INTEGER l,ij,iter,lr +c + INTEGER ijb,ije,jjb,jje +c +c +c CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 ) +c CALL SCOPY ( ip1jm*klevel, ycov, 1, gry, 1 ) +c + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + grx(ijb:ije,l)=xcov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + if(pole_sud) ije=ij_end-iip1 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + gry(ijb:ije,l)=ycov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + DO 10 iter = 1,lr +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(grx,ip1jmp1,llm,0,1) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + + CALL rotat_p (klevel,grx, gry, rot ) +c call write_field3d_p('rot',reshape(rot,(/iip1,jjm,llm/))) + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + CALL filtreg_p( rot,jjb,jje, jjm, klevel, 2,1, .false.,2) + +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(rot,ip1jm,llm,1,0) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + + CALL nxgrad_p (klevel,rot, grx, gry ) +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1, klevel + if(pole_sud) ije=ij_end-iip1 + DO 2 ij = ijb, ije + gry_out( ij,l ) = - gry( ij,l ) * crot + 2 CONTINUE + if(pole_sud) ije=ij_end + DO 3 ij = ijb, ije + grx_out( ij,l ) = - grx( ij,l ) * crot + 3 CONTINUE + 5 CONTINUE +c$OMP END DO NOWAIT +c call write_field3d_p('grx',reshape(grx,(/iip1,jjp1,llm/))) +c call write_field3d_p('gry',reshape(gry,(/iip1,jjm,llm/))) +c stop + 10 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/omp_chunk.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/omp_chunk.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/omp_chunk.h (revision 1280) @@ -0,0 +1,1 @@ +#define OMP_CHUNK 5 Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ord_coord.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ord_coord.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ord_coord.F (revision 1280) @@ -0,0 +1,95 @@ +! +! $Header$ +! + SUBROUTINE ord_coord ( nmax, xi, xo, decrois ) + +c .... Auteur : P. Le Van .... +c +c ... Reordonne eventuellement les coordonnees de la grille donnees ... +c + IMPLICIT NONE + +c ..... Arguments en entree ..... + + INTEGER nmax + REAL xi(nmax) + +c ..... Arguments en sortie ..... +c + REAL xo(nmax+1) + LOGICAL decrois + +c .... Variables locales .... + + REAL xscr(nmax) + INTEGER i,ii + REAL pi, degres, chmin, chmax, mult +c + + pi = 2.*ASIN(1.) + degres = 180./pi + decrois = .FALSE. + + DO i = 1, nmax + xo(i) = xi(i) + ENDDO + + mult = 1. + IF( xo(1).GT.xo(nmax) ) mult = -1. + + CALL minmax(nmax,xo(1),chmin,chmax) + + IF(chmax.LT.6.5 ) THEN + DO i = 1,nmax + xo(i) = xo(i) * degres + ENDDO + ENDIF + + IF( ABS( xo( 1 ) + mult* 90. ). LT .0.001. OR . + , ABS( xo(nmax) - mult* 90. ). LT .0.001 ) THEN + PRINT *,' Reverifier les valeurs de xidat pour les donnees .' + PRINT *,' Elles doivent correspondre aux interfaces et non aux', + , 'ordonnees des donnees,egales a -90. et 90.deg aux 2 extremites ' + CALL ABORT + ENDIF + + IF( xo(1).GT.xo(nmax) ) THEN + DO i = 1, nmax + xscr(i) = xo(i) + ENDDO + DO i = 1, nmax + xo(i+1) = xscr(i) + ENDDO + xo ( 1 ) = 90. + ELSE + xo ( nmax +1) = 90. + ENDIF + + IF ( xo(2).LT.xo(1) ) decrois =.TRUE. + + DO i = 3, nmax + + IF(decrois.AND.xo(i).GT.xo(i-1) ) THEN + PRINT 1 + PRINT 2,(xo(ii),ii=1,nmax) + CALL ABORT + ENDIF + IF(.NOT.decrois.AND.xo(i).LT.xo(i-1) ) THEN + PRINT 1 + PRINT 2,(xo(ii),ii=1,nmax) + CALL ABORT + ENDIF + + ENDDO + + IF( decrois ) THEN +c CALL sort(nmax+1,xo(1)) + CALL sort(nmax+1,xo) + ENDIF + +1 FORMAT(5x,' Incoherence dans les valeurs des latitudes de la ', + , 'grille du modele ') +2 FORMAT(1x,8f8.2) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ord_coordm.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ord_coordm.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ord_coordm.F (revision 1280) @@ -0,0 +1,110 @@ +! +! $Header$ +! + SUBROUTINE ord_coordm ( nmax, xi, xo, jjm, jmods, decrois ) + +c .... Auteur : P. Le Van .... + +c ... Reordonne eventuellement les coordonnees de la grille modele ... +c + IMPLICIT NONE + +c ..... Arguments en entree ..... + + INTEGER nmax,jjm + REAL xi(nmax) + +c ..... Arguments en sortie ..... +c + REAL xo(nmax+1) + LOGICAL decrois + INTEGER jmods + +c .... Variables locales .... + + REAL xscr(nmax) + INTEGER i + REAL pi, degres, chmin, chmax,mult +c + DO i = 1, nmax + xo(i) = xi(i) + ENDDO + + mult = 1. + IF( xo(1).GT.xo(nmax) ) mult = - 1. + IF( nmax.EQ.jjm ) jmods = nmax +1 + IF( nmax.EQ.jjm +1 ) jmods = nmax -1 + + pi = 2.*ASIN(1.) + degres = 180./pi + decrois = .FALSE. + + CALL minmax(nmax,xo(1),chmin,chmax) + + IF(chmax.LT.6.5 ) THEN + DO i = 1,nmax + xo(i) = xo(i) * degres + ENDDO + ENDIF + + IF( nmax.EQ.jjm ) THEN + IF( xo(1).GT.xo(nmax) ) THEN + DO i = 1, nmax + xscr(i) = xo(i) + ENDDO + DO i = 1, nmax + xo(i+1) = xscr(i) + ENDDO + xo ( 1 ) = 90. + ELSE + xo ( nmax+1 ) = 90. + ENDIF + ELSE + IF( nmax.NE.jjm +1 ) THEN + PRINT *,' Dans la routine ord_coordm , l argument nmax ' + PRINT *,' n est pas egal a jjm ni a jjm +1 . Corriger !' + CALL ABORT + ELSE + IF( ABS( xo(1)+ mult * 90.).GT.0.01 ) THEN + PRINT *,' Avec nmax =',nmax,'on devrait avoir des', + , ' ordonnees = 90. deg pour j=1 ou jjm+1 ! ' + CALL ABORT + ELSE + IF( xo(1).LT.xo(nmax) ) THEN + DO i = 1, nmax + xscr(i) = xo(i) + ENDDO + DO i = 1, nmax -1 + xo(i) = xscr(i+1) + ENDDO + ENDIF + ENDIF + ENDIF + ENDIF + + IF ( xo(2).LT.xo(1) ) decrois =.TRUE. + + DO i = 3, nmax + + IF(decrois.AND.xo(i).GT.xo(i-1) ) THEN + PRINT 1 + CALL ABORT + ENDIF + IF(.NOT.decrois.AND.xo(i).LT.xo(i-1) ) THEN + PRINT 1 + CALL ABORT + ENDIF + + ENDDO + + IF( decrois ) THEN + CALL sort(jmods,xo(1)) + ENDIF + + +1 FORMAT(5x,' Incoherence dans les valeurs des latitudes de la ', + , 'grille du modele ') +2 FORMAT(1x,8f8.2) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/parallel.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/parallel.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/parallel.F90 (revision 1280) @@ -0,0 +1,571 @@ +! +! $Id$ +! + module parallel + USE mod_const_mpi + + LOGICAL,SAVE :: using_mpi + LOGICAL,SAVE :: using_omp + + integer, save :: mpi_size + integer, save :: mpi_rank + integer, save :: jj_begin + integer, save :: jj_end + integer, save :: jj_nb + integer, save :: ij_begin + integer, save :: ij_end + logical, save :: pole_nord + logical, save :: pole_sud + + integer, allocatable, save, dimension(:) :: jj_begin_para + integer, allocatable, save, dimension(:) :: jj_end_para + integer, allocatable, save, dimension(:) :: jj_nb_para + integer, save :: OMP_CHUNK + integer, save :: omp_rank + integer, save :: omp_size +!$OMP THREADPRIVATE(omp_rank) + + contains + + subroutine init_parallel + USE vampir + implicit none +#ifdef CPP_MPI + include 'mpif.h' +#endif +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" + + integer :: ierr + integer :: i,j + integer :: type_size + integer, dimension(3) :: blocklen,type + integer :: comp_id + +#ifdef CPP_OMP + INTEGER :: OMP_GET_NUM_THREADS + EXTERNAL OMP_GET_NUM_THREADS + INTEGER :: OMP_GET_THREAD_NUM + EXTERNAL OMP_GET_THREAD_NUM +#endif + +#ifdef CPP_MPI + using_mpi=.TRUE. +#else + using_mpi=.FALSE. +#endif + + +#ifdef CPP_OMP + using_OMP=.TRUE. +#else + using_OMP=.FALSE. +#endif + + call InitVampir + + IF (using_mpi) THEN +#ifdef CPP_MPI + call MPI_COMM_SIZE(COMM_LMDZ,mpi_size,ierr) + call MPI_COMM_RANK(COMM_LMDZ,mpi_rank,ierr) +#endif + ELSE + mpi_size=1 + mpi_rank=0 + ENDIF + + + allocate(jj_begin_para(0:mpi_size-1)) + allocate(jj_end_para(0:mpi_size-1)) + allocate(jj_nb_para(0:mpi_size-1)) + + do i=0,mpi_size-1 + jj_nb_para(i)=(jjm+1)/mpi_size + if ( i < MOD((jjm+1),mpi_size) ) jj_nb_para(i)=jj_nb_para(i)+1 + + if (jj_nb_para(i) <= 2 ) then + + write(lunout,*)"Arret : le nombre de bande de lattitude par process est trop faible (<2)." + write(lunout,*)" ---> diminuez le nombre de CPU ou augmentez la taille en lattitude" + +#ifdef CPP_MPI + IF (using_mpi) call MPI_ABORT(COMM_LMDZ,-1, ierr) +#endif + endif + + enddo + +! jj_nb_para(0)=11 +! jj_nb_para(1)=25 +! jj_nb_para(2)=25 +! jj_nb_para(3)=12 + + j=1 + + do i=0,mpi_size-1 + + jj_begin_para(i)=j + jj_end_para(i)=j+jj_Nb_para(i)-1 + j=j+jj_Nb_para(i) + + enddo + + jj_begin = jj_begin_para(mpi_rank) + jj_end = jj_end_para(mpi_rank) + jj_nb = jj_nb_para(mpi_rank) + + ij_begin=(jj_begin-1)*iip1+1 + ij_end=jj_end*iip1 + + if (mpi_rank.eq.0) then + pole_nord=.TRUE. + else + pole_nord=.FALSE. + endif + + if (mpi_rank.eq.mpi_size-1) then + pole_sud=.TRUE. + else + pole_sud=.FALSE. + endif + + write(lunout,*)"init_parallel: jj_begin",jj_begin + write(lunout,*)"init_parallel: jj_end",jj_end + write(lunout,*)"init_parallel: ij_begin",ij_begin + write(lunout,*)"init_parallel: ij_end",ij_end + +!$OMP PARALLEL + +#ifdef CPP_OMP +!$OMP MASTER + omp_size=OMP_GET_NUM_THREADS() +!$OMP END MASTER + omp_rank=OMP_GET_THREAD_NUM() +#else + omp_size=1 + omp_rank=0 +#endif +!$OMP END PARALLEL + + end subroutine init_parallel + + + subroutine SetDistrib(jj_Nb_New) + implicit none + +#include "dimensions.h" +#include "paramet.h" + + INTEGER,dimension(0:MPI_Size-1) :: jj_Nb_New + INTEGER :: i + + jj_Nb_Para=jj_Nb_New + + jj_begin_para(0)=1 + jj_end_para(0)=jj_Nb_Para(0) + + do i=1,mpi_size-1 + + jj_begin_para(i)=jj_end_para(i-1)+1 + jj_end_para(i)=jj_begin_para(i)+jj_Nb_para(i)-1 + + enddo + + jj_begin = jj_begin_para(mpi_rank) + jj_end = jj_end_para(mpi_rank) + jj_nb = jj_nb_para(mpi_rank) + + ij_begin=(jj_begin-1)*iip1+1 + ij_end=jj_end*iip1 + + end subroutine SetDistrib + + + + + subroutine Finalize_parallel +#ifdef CPP_COUPLE + use mod_prism_proto +#endif +#ifdef CPP_EARTH +! Ehouarn: surface_data module is in 'phylmd' ... + use surface_data, only : type_ocean + implicit none +#else + implicit none +! without the surface_data module, we declare (and set) a dummy 'type_ocean' + character(len=6),parameter :: type_ocean="dummy" +#endif +! #endif of #ifdef CPP_EARTH + + include "dimensions.h" + include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + + integer :: ierr + integer :: i + deallocate(jj_begin_para) + deallocate(jj_end_para) + deallocate(jj_nb_para) + + if (type_ocean == 'couple') then +#ifdef CPP_COUPLE + call prism_terminate_proto(ierr) + IF (ierr .ne. PRISM_Ok) THEN + call abort_gcm('Finalize_parallel',' Probleme dans prism_terminate_proto ',1) + endif +#endif + else +#ifdef CPP_MPI + IF (using_mpi) call MPI_FINALIZE(ierr) +#endif + end if + + end subroutine Finalize_parallel + + subroutine Pack_Data(Field,ij,ll,row,Buffer) + implicit none + +#include "dimensions.h" +#include "paramet.h" + + integer, intent(in) :: ij,ll,row + real,dimension(ij,ll),intent(in) ::Field + real,dimension(ll*iip1*row), intent(out) :: Buffer + + integer :: Pos + integer :: i,l + + Pos=0 + do l=1,ll + do i=1,row*iip1 + Pos=Pos+1 + Buffer(Pos)=Field(i,l) + enddo + enddo + + end subroutine Pack_data + + subroutine Unpack_Data(Field,ij,ll,row,Buffer) + implicit none + +#include "dimensions.h" +#include "paramet.h" + + integer, intent(in) :: ij,ll,row + real,dimension(ij,ll),intent(out) ::Field + real,dimension(ll*iip1*row), intent(in) :: Buffer + + integer :: Pos + integer :: i,l + + Pos=0 + + do l=1,ll + do i=1,row*iip1 + Pos=Pos+1 + Field(i,l)=Buffer(Pos) + enddo + enddo + + end subroutine UnPack_data + + + SUBROUTINE barrier + IMPLICIT NONE +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: ierr + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + IF (using_mpi) CALL MPI_Barrier(COMM_LMDZ,ierr) +#endif +!$OMP END CRITICAL (MPI) + + END SUBROUTINE barrier + + + subroutine exchange_hallo(Field,ij,ll,up,down) + USE Vampir + implicit none +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: up,down + + INTEGER :: ierr + LOGICAL :: SendUp,SendDown + LOGICAL :: RecvUp,RecvDown + INTEGER, DIMENSION(4) :: Request +#ifdef CPP_MPI + INTEGER, DIMENSION(MPI_STATUS_SIZE,4) :: Status +#else + INTEGER, DIMENSION(1,4) :: Status +#endif + INTEGER :: NbRequest + REAL, dimension(:),allocatable :: Buffer_Send_up,Buffer_Send_down + REAL, dimension(:),allocatable :: Buffer_Recv_up,Buffer_Recv_down + INTEGER :: Buffer_size + + IF (using_mpi) THEN + + CALL barrier + + call VTb(VThallo) + + SendUp=.TRUE. + SendDown=.TRUE. + RecvUp=.TRUE. + RecvDown=.TRUE. + + IF (pole_nord) THEN + SendUp=.FALSE. + RecvUp=.FALSE. + ENDIF + + IF (pole_sud) THEN + SendDown=.FALSE. + RecvDown=.FALSE. + ENDIF + + if (up.eq.0) then + SendDown=.FALSE. + RecvUp=.FALSE. + endif + + if (down.eq.0) then + SendUp=.FALSE. + RecvDown=.FALSE. + endif + + NbRequest=0 + + IF (SendUp) THEN + NbRequest=NbRequest+1 + buffer_size=down*iip1*ll + allocate(Buffer_Send_up(Buffer_size)) + call PACK_Data(Field(ij_begin,1),ij,ll,down,Buffer_Send_up) +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_ISSEND(Buffer_send_up,Buffer_Size,MPI_REAL8,MPI_Rank-1,1, & + COMM_LMDZ,Request(NbRequest),ierr) +#endif +!$OMP END CRITICAL (MPI) + ENDIF + + IF (SendDown) THEN + NbRequest=NbRequest+1 + + buffer_size=up*iip1*ll + allocate(Buffer_Send_down(Buffer_size)) + call PACK_Data(Field(ij_end+1-up*iip1,1),ij,ll,up,Buffer_send_down) + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_ISSEND(Buffer_send_down,Buffer_Size,MPI_REAL8,MPI_Rank+1,1, & + COMM_LMDZ,Request(NbRequest),ierr) +#endif +!$OMP END CRITICAL (MPI) + ENDIF + + + IF (RecvUp) THEN + NbRequest=NbRequest+1 + buffer_size=up*iip1*ll + allocate(Buffer_recv_up(Buffer_size)) + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_IRECV(Buffer_recv_up,Buffer_size,MPI_REAL8,MPI_Rank-1,1, & + COMM_LMDZ,Request(NbRequest),ierr) +#endif +!$OMP END CRITICAL (MPI) + + + ENDIF + + IF (RecvDown) THEN + NbRequest=NbRequest+1 + buffer_size=down*iip1*ll + allocate(Buffer_recv_down(Buffer_size)) + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_IRECV(Buffer_recv_down,Buffer_size,MPI_REAL8,MPI_Rank+1,1, & + COMM_LMDZ,Request(NbRequest),ierr) +#endif +!$OMP END CRITICAL (MPI) + + ENDIF + +#ifdef CPP_MPI + if (NbRequest > 0) call MPI_WAITALL(NbRequest,Request,Status,ierr) +#endif + IF (RecvUp) call Unpack_Data(Field(ij_begin-up*iip1,1),ij,ll,up,Buffer_Recv_up) + IF (RecvDown) call Unpack_Data(Field(ij_end+1,1),ij,ll,down,Buffer_Recv_down) + + call VTe(VThallo) + call barrier + + ENDIF ! using_mpi + + RETURN + + end subroutine exchange_Hallo + + + subroutine Gather_Field(Field,ij,ll,rank) + implicit none +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + INTEGER :: ij,ll,rank + REAL, dimension(ij,ll) :: Field + REAL, dimension(:),allocatable :: Buffer_send + REAL, dimension(:),allocatable :: Buffer_Recv + INTEGER, dimension(0:MPI_Size-1) :: Recv_count, displ + INTEGER :: ierr + INTEGER ::i + + IF (using_mpi) THEN + + if (ij==ip1jmp1) then + allocate(Buffer_send(iip1*ll*(jj_end-jj_begin+1))) + call Pack_Data(Field(ij_begin,1),ij,ll,jj_end-jj_begin+1,Buffer_send) + else if (ij==ip1jm) then + allocate(Buffer_send(iip1*ll*(min(jj_end,jjm)-jj_begin+1))) + call Pack_Data(Field(ij_begin,1),ij,ll,min(jj_end,jjm)-jj_begin+1,Buffer_send) + else + write(lunout,*)ij + stop 'erreur dans Gather_Field' + endif + + if (MPI_Rank==rank) then + allocate(Buffer_Recv(ij*ll)) + +!CDIR NOVECTOR + do i=0,MPI_Size-1 + + if (ij==ip1jmp1) then + Recv_count(i)=(jj_end_para(i)-jj_begin_para(i)+1)*ll*iip1 + else if (ij==ip1jm) then + Recv_count(i)=(min(jj_end_para(i),jjm)-jj_begin_para(i)+1)*ll*iip1 + else + stop 'erreur dans Gather_Field' + endif + + if (i==0) then + displ(i)=0 + else + displ(i)=displ(i-1)+Recv_count(i-1) + endif + + enddo + + endif + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_GATHERV(Buffer_send,(min(ij_end,ij)-ij_begin+1)*ll,MPI_REAL8, & + Buffer_Recv,Recv_count,displ,MPI_REAL8,rank,COMM_LMDZ,ierr) +#endif +!$OMP END CRITICAL (MPI) + + if (MPI_Rank==rank) then + + if (ij==ip1jmp1) then + do i=0,MPI_Size-1 + call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll, & + jj_end_para(i)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1)) + enddo + else if (ij==ip1jm) then + do i=0,MPI_Size-1 + call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll, & + min(jj_end_para(i),jjm)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1)) + enddo + endif + endif + ENDIF ! using_mpi + + end subroutine Gather_Field + + + subroutine AllGather_Field(Field,ij,ll) + implicit none +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: ierr + + IF (using_mpi) THEN + call Gather_Field(Field,ij,ll,0) +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_BCAST(Field,ij*ll,MPI_REAL8,0,COMM_LMDZ,ierr) +#endif +!$OMP END CRITICAL (MPI) + ENDIF + + end subroutine AllGather_Field + + subroutine Broadcast_Field(Field,ij,ll,rank) + implicit none +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: rank + INTEGER :: ierr + + IF (using_mpi) THEN + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_BCAST(Field,ij*ll,MPI_REAL8,rank,COMM_LMDZ,ierr) +#endif +!$OMP END CRITICAL (MPI) + + ENDIF + end subroutine Broadcast_Field + + + /* + Subroutine verif_hallo(Field,ij,ll,up,down) + implicit none +#include "dimensions.h" +#include "paramet.h" + include 'mpif.h' + + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: up,down + + REAL,dimension(ij,ll): NewField + + NewField=0 + + ijb=ij_begin + ije=ij_end + if (pole_nord) + NewField(ij_be +*/ + end module parallel Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/paramet.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/paramet.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/paramet.h (revision 1280) @@ -0,0 +1,29 @@ +! +! $Header$ +! +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! +!----------------------------------------------------------------------- +! INCLUDE 'paramet.h' + + INTEGER iip1,iip2,iip3,jjp1,llmp1,llmp2,llmm1 + INTEGER kftd,ip1jm,ip1jmp1,ip1jmi1,ijp1llm + INTEGER ijmllm,mvar + INTEGER jcfil,jcfllm + + PARAMETER( iip1= iim+1-1/iim,iip2=iim+2,iip3=iim+3 & + & ,jjp1=jjm+1-1/jjm) + PARAMETER( llmp1 = llm+1, llmp2 = llm+2, llmm1 = llm-1 ) + PARAMETER( kftd = iim/2 -ndm ) + PARAMETER( ip1jm = iip1*jjm, ip1jmp1= iip1*jjp1 ) + PARAMETER( ip1jmi1= ip1jm - iip1 ) + PARAMETER( ijp1llm= ip1jmp1 * llm, ijmllm= ip1jm * llm ) + PARAMETER( mvar= ip1jmp1*( 2*llm+1) + ijmllm ) + PARAMETER( jcfil=jjm/2+5, jcfllm=jcfil*llm ) + +!----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/pbar.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/pbar.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/pbar.F (revision 1280) @@ -0,0 +1,124 @@ +! +! $Header$ +! + SUBROUTINE pbar ( pext, pbarx, pbary, pbarxy ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************** +c calcul des moyennes en x et en y de (pression au sol*aire variable) .. +c ********************************************************************* +c +c pext est un argum. d'entree pour le s-pg .. +c pbarx,pbary et pbarxy sont des argum. de sortie pour le s-pg .. +c +c Methode: +c -------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c +c On a : +c +c pbarx(i,j) = Pext(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c pbary(i,j) = Pext(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) + +c Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1) +c localise au point ... Z (i,j) ... +c +c +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" + +#include "comgeom.h" + + REAL pext( ip1jmp1 ), pbarx ( ip1jmp1 ) + REAL pbary( ip1jm ), pbarxy( ip1jm ) + + INTEGER ij + + + + DO 1 ij = 1, ip1jmp1 - 1 + pbarx( ij ) = pext(ij) * alpha1p2(ij) + pext(ij+1)*alpha3p4(ij+1) + 1 CONTINUE + +c .... correction pour pbarx( iip1,j) ..... + +c ... pbarx(iip1,j)= pbarx(1,j) ... +CDIR$ IVDEP + DO 2 ij = iip1, ip1jmp1, iip1 + pbarx( ij ) = pbarx( ij - iim ) + 2 CONTINUE + + + DO 3 ij = 1,ip1jm + pbary( ij ) = pext( ij ) * alpha2p3( ij ) + + * pext( ij+iip1 ) * alpha1p4( ij+iip1 ) + 3 CONTINUE + + + DO 5 ij = 1, ip1jm - 1 + pbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) + + * pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2) + 5 CONTINUE + + +c .... correction pour pbarxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = iip1, ip1jm, iip1 + pbarxy( ij ) = pbarxy( ij - iim ) + 7 CONTINUE + + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/pentes_ini.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/pentes_ini.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/pentes_ini.F (revision 1280) @@ -0,0 +1,474 @@ +! +! $Header$ +! + SUBROUTINE pentes_ini (q,w,masse,pbaru,pbarv,mode) + IMPLICIT NONE + +c======================================================================= +c Adaptation LMDZ: A.Armengaud (LGGE) +c ---------------- +c +c ******************************************************************** +c Transport des traceurs par la methode des pentes +c ******************************************************************** +c Reference possible : Russel. G.L., Lerner J.A.: +c A new Finite-Differencing Scheme for Traceur Transport +c Equation , Journal of Applied Meteorology, pp 1483-1498,dec. 81 +c ******************************************************************** +c q,w,masse,pbaru et pbarv +c sont des arguments d'entree pour le s-pg .... +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +c Arguments: +c ---------- + integer mode + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ) + REAL q( iip1,jjp1,llm,0:3) + REAL w( ip1jmp1,llm ) + REAL masse( iip1,jjp1,llm) +c Local: +c ------ + LOGICAL limit + REAL sm ( iip1,jjp1, llm ) + REAL s0( iip1,jjp1,llm ), sx( iip1,jjp1,llm ) + REAL sy( iip1,jjp1,llm ), sz( iip1,jjp1,llm ) + real masn,mass,zz + INTEGER i,j,l,iq + +c modif Fred 24 03 96 + + real sinlon(iip1),sinlondlon(iip1) + real coslon(iip1),coslondlon(iip1) + save sinlon,coslon,sinlondlon,coslondlon + real dyn1,dyn2,dys1,dys2 + real qpn,qps,dqzpn,dqzps + real smn,sms,s0n,s0s,sxn(iip1),sxs(iip1) + real qmin,zq,pente_max +c + REAL SSUM + integer ismax,ismin,lati,latf + EXTERNAL SSUM, ismin,ismax + logical first + save first +c fin modif + + +c modif Fred 24 03 96 + data first/.true./ + + limit = .TRUE. + pente_max=2 +c if (mode.eq.1.or.mode.eq.3) then +c if (mode.eq.1) then + if (mode.ge.1) then + lati=2 + latf=jjm + else + lati=1 + latf=jjp1 + endif + + qmin=0.4995 + qmin=0. + if(first) then + print*,'SCHEMA AMONT NOUVEAU' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + print*,coslondlon(i),sinlondlon(i) + enddo + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + print*,'sum sinlondlon ',ssum(iim,sinlondlon,1)/sinlondlon(1) + print*,'sum coslondlon ',ssum(iim,coslondlon,1)/coslondlon(1) + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + q ( i,j,l,1 )=0. + q ( i,j,l,2 )=0. + q ( i,j,l,3 )=0. + ENDDO + ENDDO + ENDDO + + endif +c Fin modif Fred + +c *** q contient les qqtes de traceur avant l'advection + +c *** Affectation des tableaux S a partir de Q +c *** Rem : utilisation de SCOPY ulterieurement + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + s0( i,j,llm+1-l ) = q ( i,j,l,0 ) + sx( i,j,llm+1-l ) = q ( i,j,l,1 ) + sy( i,j,llm+1-l ) = q ( i,j,l,2 ) + sz( i,j,llm+1-l ) = q ( i,j,l,3 ) + ENDDO + ENDDO + ENDDO + +c PRINT*,'----- S0 just before conversion -------' +c PRINT*,'S0(16,12,1)=',s0(16,12,1) +c PRINT*,'Q(16,12,1,4)=',q(16,12,1,4) + +c *** On calcule la masse d'air en kg + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + sm ( i,j,llm+1-l)=masse( i,j,l ) + ENDDO + ENDDO + ENDDO + +c *** On converti les champs S en atome (resp. kg) +c *** Les routines d'advection traitent les champs +c *** a advecter si ces derniers sont en atome (resp. kg) +c *** A optimiser !!! + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + s0(i,j,l) = s0(i,j,l) * sm ( i,j,l ) + sx(i,j,l) = sx(i,j,l) * sm ( i,j,l ) + sy(i,j,l) = sy(i,j,l) * sm ( i,j,l ) + sz(i,j,l) = sz(i,j,l) * sm ( i,j,l ) + ENDDO + ENDDO + ENDDO + +c ss0 = 0. +c DO l = 1,llm +c DO j = 1,jjp1 +c DO i = 1,iim +c ss0 = ss0 + s0 ( i,j,l ) +c ENDDO +c ENDDO +c ENDDO +c PRINT*, 'valeur tot s0 avant advection=',ss0 + +c *** Appel des subroutines d'advection en X, en Y et en Z +c *** Advection avec "time-splitting" + +c----------------------------------------------------------- +c PRINT*,'----- S0 just before ADVX -------' +c PRINT*,'S0(16,12,1)=',s0(16,12,1) + +c----------------------------------------------------------- +c do l=1,llm +c do j=1,jjp1 +c do i=1,iip1 +c zq=s0(i,j,l)/sm(i,j,l) +c if(zq.lt.qmin) +c , print*,'avant advx1, s0(',i,',',j,',',l,')=',zq +c enddo +c enddo +c enddo +CCC + if(mode.eq.2) then + do l=1,llm + s0s=0. + s0n=0. + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + smn=0. + sms=0. + do i=1,iim + smn=smn+sm(i,1,l) + sms=sms+sm(i,jjp1,l) + s0n=s0n+s0(i,1,l) + s0s=s0s+s0(i,jjp1,l) + zz=sy(i,1,l)/sm(i,1,l) + dyn1=dyn1+sinlondlon(i)*zz + dyn2=dyn2+coslondlon(i)*zz + zz=sy(i,jjp1,l)/sm(i,jjp1,l) + dys1=dys1+sinlondlon(i)*zz + dys2=dys2+coslondlon(i)*zz + enddo + do i=1,iim + sy(i,1,l)=dyn1*sinlon(i)+dyn2*coslon(i) + sy(i,jjp1,l)=dys1*sinlon(i)+dys2*coslon(i) + enddo + do i=1,iim + s0(i,1,l)=s0n/smn+sy(i,1,l) + s0(i,jjp1,l)=s0s/sms-sy(i,jjp1,l) + enddo + + s0(iip1,1,l)=s0(1,1,l) + s0(iip1,jjp1,l)=s0(1,jjp1,l) + + do i=1,iim + sxn(i)=s0(i+1,1,l)-s0(i,1,l) + sxs(i)=s0(i+1,jjp1,l)-s0(i,jjp1,l) +c on rerentre les masses + enddo + do i=1,iim + sy(i,1,l)=sy(i,1,l)*sm(i,1,l) + sy(i,jjp1,l)=sy(i,jjp1,l)*sm(i,jjp1,l) + s0(i,1,l)=s0(i,1,l)*sm(i,1,l) + s0(i,jjp1,l)=s0(i,jjp1,l)*sm(i,jjp1,l) + enddo + sxn(iip1)=sxn(1) + sxs(iip1)=sxs(1) + do i=1,iim + sx(i+1,1,l)=0.25*(sxn(i)+sxn(i+1))*sm(i+1,1,l) + sx(i+1,jjp1,l)=0.25*(sxs(i)+sxs(i+1))*sm(i+1,jjp1,l) + enddo + s0(iip1,1,l)=s0(1,1,l) + s0(iip1,jjp1,l)=s0(1,jjp1,l) + sy(iip1,1,l)=sy(1,1,l) + sy(iip1,jjp1,l)=sy(1,jjp1,l) + sx(1,1,l)=sx(iip1,1,l) + sx(1,jjp1,l)=sx(iip1,jjp1,l) + enddo + endif + + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limx(s0,sx,sm,pente_max) +c call minmaxq(zq,1.e33,-1.e33,'avant advx ') + call advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf) +c call minmaxq(zq,1.e33,-1.e33,'avant advy ') + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limy(s0,sy,sm,pente_max) + call advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz ) +c call minmaxq(zq,1.e33,-1.e33,'avant advz ') + do j=1,jjp1 + do i=1,iip1 + sz(i,j,1)=0. + sz(i,j,llm)=0. + enddo + enddo + call limz(s0,sz,sm,pente_max) + call advz( limit,dtvr,w,sm,s0,sx,sy,sz ) + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limy(s0,sy,sm,pente_max) + call advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz ) + do l=1,llm + do j=1,jjp1 + sm(iip1,j,l)=sm(1,j,l) + s0(iip1,j,l)=s0(1,j,l) + sx(iip1,j,l)=sx(1,j,l) + sy(iip1,j,l)=sy(1,j,l) + sz(iip1,j,l)=sz(1,j,l) + enddo + enddo + + +c call minmaxq(zq,1.e33,-1.e33,'avant advx ') + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limx(s0,sx,sm,pente_max) + call advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf) +c call minmaxq(zq,1.e33,-1.e33,'apres advx ') +c do l=1,llm +c do j=1,jjp1 +c do i=1,iip1 +c zq=s0(i,j,l)/sm(i,j,l) +c if(zq.lt.qmin) +c , print*,'apres advx2, s0(',i,',',j,',',l,')=',zq +c enddo +c enddo +c enddo +c *** On repasse les S dans la variable q directement 14/10/94 +c On revient a des rapports de melange en divisant par la masse + +c En dehors des poles: + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + q(i,j,llm+1-l,0)=s0(i,j,l)/sm(i,j,l) + q(i,j,llm+1-l,1)=sx(i,j,l)/sm(i,j,l) + q(i,j,llm+1-l,2)=sy(i,j,l)/sm(i,j,l) + q(i,j,llm+1-l,3)=sz(i,j,l)/sm(i,j,l) + ENDDO + ENDDO + ENDDO + +c Traitements specifiques au pole + + if(mode.ge.1) then + DO l=1,llm +c filtrages aux poles + masn=ssum(iim,sm(1,1,l),1) + mass=ssum(iim,sm(1,jjp1,l),1) + qpn=ssum(iim,s0(1,1,l),1)/masn + qps=ssum(iim,s0(1,jjp1,l),1)/mass + dqzpn=ssum(iim,sz(1,1,l),1)/masn + dqzps=ssum(iim,sz(1,jjp1,l),1)/mass + do i=1,iip1 + q( i,1,llm+1-l,3)=dqzpn + q( i,jjp1,llm+1-l,3)=dqzps + q( i,1,llm+1-l,0)=qpn + q( i,jjp1,llm+1-l,0)=qps + enddo + if(mode.eq.3) then + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + do i=1,iim + dyn1=dyn1+sinlondlon(i)*sy(i,1,l)/sm(i,1,l) + dyn2=dyn2+coslondlon(i)*sy(i,1,l)/sm(i,1,l) + dys1=dys1+sinlondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l) + dys2=dys2+coslondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l) + enddo + do i=1,iim + q(i,1,llm+1-l,2)= + s (sinlon(i)*dyn1+coslon(i)*dyn2) + q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2) + q(i,jjp1,llm+1-l,2)= + s (sinlon(i)*dys1+coslon(i)*dys2) + q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) + s -q(i,jjp1,llm+1-l,2) + enddo + endif + if(mode.eq.1) then +c on filtre les valeurs au bord de la "grande maille pole" + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + do i=1,iim + zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0) + dyn1=dyn1+sinlondlon(i)*zz + dyn2=dyn2+coslondlon(i)*zz + zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l) + dys1=dys1+sinlondlon(i)*zz + dys2=dys2+coslondlon(i)*zz + enddo + do i=1,iim + q(i,1,llm+1-l,2)= + s (sinlon(i)*dyn1+coslon(i)*dyn2)/2. + q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2) + q(i,jjp1,llm+1-l,2)= + s (sinlon(i)*dys1+coslon(i)*dys2)/2. + q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) + s -q(i,jjp1,llm+1-l,2) + enddo + q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0) + q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0) + + do i=1,iim + sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0) + sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0) + enddo + sxn(iip1)=sxn(1) + sxs(iip1)=sxs(1) + do i=1,iim + q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1)) + q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1)) + enddo + q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1) + q(1,jjp1,llm+1-l,1)=q(iip1,jjp1,llm+1-l,1) + + endif + + ENDDO + endif + +c bouclage en longitude + do iq=0,3 + do l=1,llm + do j=1,jjp1 + q(iip1,j,l,iq)=q(1,j,l,iq) + enddo + enddo + enddo + +c PRINT*, ' SORTIE DE PENTES --- ca peut glisser ....' + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + IF (q(i,j,l,0).lt.0.) THEN +c PRINT*,'------------ BIP-----------' +c PRINT*,'Q0(',i,j,l,')=',q(i,j,l,0) +c PRINT*,'QX(',i,j,l,')=',q(i,j,l,1) +c PRINT*,'QY(',i,j,l,')=',q(i,j,l,2) +c PRINT*,'QZ(',i,j,l,')=',q(i,j,l,3) +c PRINT*,' PBL EN SORTIE DE PENTES' + q(i,j,l,0)=0. +c STOP + ENDIF + ENDDO + ENDDO + ENDDO + +c PRINT*, '-------------------------------------------' + + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + if(q(i,j,l,0).lt.qmin) + , print*,'apres pentes, s0(',i,',',j,',',l,')=',q(i,j,l,0) + enddo + enddo + enddo + RETURN + END + + + + + + + + + + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ppm3d.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ppm3d.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ppm3d.F (revision 1280) @@ -0,0 +1,2001 @@ +! +! $Header$ +! + +cFrom lin@explorer.gsfc.nasa.gov Wed Apr 15 17:44:44 1998 +cDate: Wed, 15 Apr 1998 11:37:03 -0400 +cFrom: lin@explorer.gsfc.nasa.gov +cTo: Frederic.Hourdin@lmd.jussieu.fr +cSubject: 3D transport module of the GSFC CTM and GEOS GCM + + +cThis code is sent to you by S-J Lin, DAO, NASA-GSFC + +cNote: this version is intended for machines like CRAY +C-90. No multitasking directives implemented. + + +C ******************************************************************** +C +C TransPort Core for Goddard Chemistry Transport Model (G-CTM), Goddard +C Earth Observing System General Circulation Model (GEOS-GCM), and Data +C Assimilation System (GEOS-DAS). +C +C ******************************************************************** +C +C Purpose: given horizontal winds on a hybrid sigma-p surfaces, +C one call to tpcore updates the 3-D mixing ratio +C fields one time step (NDT). [vertical mass flux is computed +C internally consistent with the discretized hydrostatic mass +C continuity equation of the C-Grid GEOS-GCM (for IGD=1)]. +C +C Schemes: Multi-dimensional Flux Form Semi-Lagrangian (FFSL) scheme based +C on the van Leer or PPM. +C (see Lin and Rood 1996). +C Version 4.5 +C Last modified: Dec. 5, 1996 +C Major changes from version 4.0: a more general vertical hybrid sigma- +C pressure coordinate. +C Subroutines modified: xtp, ytp, fzppm, qckxyz +C Subroutines deleted: vanz +C +C Author: Shian-Jiann Lin +C mail address: +C Shian-Jiann Lin* +C Code 910.3, NASA/GSFC, Greenbelt, MD 20771 +C Phone: 301-286-9540 +C E-mail: lin@dao.gsfc.nasa.gov +C +C *affiliation: +C Joint Center for Earth Systems Technology +C The University of Maryland Baltimore County +C NASA - Goddard Space Flight Center +C References: +C +C 1. Lin, S.-J., and R. B. Rood, 1996: Multidimensional flux form semi- +C Lagrangian transport schemes. Mon. Wea. Rev., 124, 2046-2070. +C +C 2. Lin, S.-J., W. C. Chao, Y. C. Sud, and G. K. Walker, 1994: A class of +C the van Leer-type transport schemes and its applications to the moist- +C ure transport in a General Circulation Model. Mon. Wea. Rev., 122, +C 1575-1593. +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C + subroutine ppm3d(IGD,Q,PS1,PS2,U,V,W,NDT,IORD,JORD,KORD,NC,IMR, + & JNP,j1,NLAY,AP,BP,PT,AE,fill,dum,Umax) + +c implicit none + +c rajout de déclarations +c integer Jmax,kmax,ndt0,nstep,k,j,i,ic,l,js,jn,imh,iad,jad,krd +c integer iu,iiu,j2,jmr,js0,jt +c real dtdy,dtdy5,rcap,iml,jn0,imjm,pi,dl,dp +c real dt,cr1,maxdt,ztc,d5,sum1,sum2,ru +C +C ******************************************************************** +C +C ============= +C INPUT: +C ============= +C +C Q(IMR,JNP,NLAY,NC): mixing ratios at current time (t) +C NC: total # of constituents +C IMR: first dimension (E-W); # of Grid intervals in E-W is IMR +C JNP: 2nd dimension (N-S); # of Grid intervals in N-S is JNP-1 +C NLAY: 3rd dimension (# of layers); vertical index increases from 1 at +C the model top to NLAY near the surface (see fig. below). +C It is assumed that 6 <= NLAY <= JNP (for dynamic memory allocation) +C +C PS1(IMR,JNP): surface pressure at current time (t) +C PS2(IMR,JNP): surface pressure at mid-time-level (t+NDT/2) +C PS2 is replaced by the predicted PS (at t+NDT) on output. +C Note: surface pressure can have any unit or can be multiplied by any +C const. +C +C The pressure at layer edges are defined as follows: +C +C p(i,j,k) = AP(k)*PT + BP(k)*PS(i,j) (1) +C +C Where PT is a constant having the same unit as PS. +C AP and BP are unitless constants given at layer edges +C defining the vertical coordinate. +C BP(1) = 0., BP(NLAY+1) = 1. +C The pressure at the model top is PTOP = AP(1)*PT +C +C For pure sigma system set AP(k) = 1 for all k, PT = PTOP, +C BP(k) = sige(k) (sigma at edges), PS = Psfc - PTOP. +C +C Note: the sigma-P coordinate is a subset of Eq. 1, which in turn +C is a subset of the following even more general sigma-P-thelta coord. +C currently under development. +C p(i,j,k) = (AP(k)*PT + BP(k)*PS(i,j))/(D(k)-C(k)*TE**(-1/kapa)) +C +C ///////////////////////////////// +C / \ ------------- PTOP -------------- AP(1), BP(1) +C | +C delp(1) | ........... Q(i,j,1) ............ +C | +C W(1) \ / --------------------------------- AP(2), BP(2) +C +C +C +C W(k-1) / \ --------------------------------- AP(k), BP(k) +C | +C delp(K) | ........... Q(i,j,k) ............ +C | +C W(k) \ / --------------------------------- AP(k+1), BP(k+1) +C +C +C +C / \ --------------------------------- AP(NLAY), BP(NLAY) +C | +C delp(NLAY) | ........... Q(i,j,NLAY) ......... +C | +C W(NLAY)=0 \ / ------------- surface ----------- AP(NLAY+1), BP(NLAY+1) +C ////////////////////////////////// +C +C U(IMR,JNP,NLAY) & V(IMR,JNP,NLAY):winds (m/s) at mid-time-level (t+NDT/2) +C U and V may need to be polar filtered in advance in some cases. +C +C IGD: grid type on which winds are defined. +C IGD = 0: A-Grid [all variables defined at the same point from south +C pole (j=1) to north pole (j=JNP) ] +C +C IGD = 1 GEOS-GCM C-Grid +C [North] +C +C V(i,j) +C | +C | +C | +C U(i-1,j)---Q(i,j)---U(i,j) [EAST] +C | +C | +C | +C V(i,j-1) +C +C U(i, 1) is defined at South Pole. +C V(i, 1) is half grid north of the South Pole. +C V(i,JMR) is half grid south of the North Pole. +C +C V must be defined at j=1 and j=JMR if IGD=1 +C V at JNP need not be given. +C +C NDT: time step in seconds (need not be constant during the course of +C the integration). Suggested value: 30 min. for 4x5, 15 min. for 2x2.5 +C (Lat-Lon) resolution. Smaller values are recommanded if the model +C has a well-resolved stratosphere. +C +C J1 defines the size of the polar cap: +C South polar cap edge is located at -90 + (j1-1.5)*180/(JNP-1) deg. +C North polar cap edge is located at 90 - (j1-1.5)*180/(JNP-1) deg. +C There are currently only two choices (j1=2 or 3). +C IMR must be an even integer if j1 = 2. Recommended value: J1=3. +C +C IORD, JORD, and KORD are integers controlling various options in E-W, N-S, +C and vertical transport, respectively. Recommended values for positive +C definite scalars: IORD=JORD=3, KORD=5. Use KORD=3 for non- +C positive definite scalars or when linear correlation between constituents +C is to be maintained. +C +C _ORD= +C 1: 1st order upstream scheme (too diffusive, not a useful option; it +C can be used for debugging purposes; this is THE only known "linear" +C monotonic advection scheme.). +C 2: 2nd order van Leer (full monotonicity constraint; +C see Lin et al 1994, MWR) +C 3: monotonic PPM* (slightly improved PPM of Collela & Woodward 1984) +C 4: semi-monotonic PPM (same as 3, but overshoots are allowed) +C 5: positive-definite PPM (constraint on the subgrid distribution is +C only strong enough to prevent generation of negative values; +C both overshoots & undershoots are possible). +C 6: un-constrained PPM (nearly diffusion free; slightly faster but +C positivity not quaranteed. Use this option only when the fields +C and winds are very smooth). +C +C *PPM: Piece-wise Parabolic Method +C +C Note that KORD <=2 options are no longer supported. DO not use option 4 or 5. +C for non-positive definite scalars (such as Ertel Potential Vorticity). +C +C The implicit numerical diffusion decreases as _ORD increases. +C The last two options (ORDER=5, 6) should only be used when there is +C significant explicit diffusion (such as a turbulence parameterization). You +C might get dispersive results otherwise. +C No filter of any kind is applied to the constituent fields here. +C +C AE: Radius of the sphere (meters). +C Recommended value for the planet earth: 6.371E6 +C +C fill(logical): flag to do filling for negatives (see note below). +C +C Umax: Estimate (upper limit) of the maximum U-wind speed (m/s). +C (220 m/s is a good value for troposphere model; 280 m/s otherwise) +C +C ============= +C Output +C ============= +C +C Q: mixing ratios at future time (t+NDT) (original values are over-written) +C W(NLAY): large-scale vertical mass flux as diagnosed from the hydrostatic +C relationship. W will have the same unit as PS1 and PS2 (eg, mb). +C W must be divided by NDT to get the correct mass-flux unit. +C The vertical Courant number C = W/delp_UPWIND, where delp_UPWIND +C is the pressure thickness in the "upwind" direction. For example, +C C(k) = W(k)/delp(k) if W(k) > 0; +C C(k) = W(k)/delp(k+1) if W(k) < 0. +C ( W > 0 is downward, ie, toward surface) +C PS2: predicted PS at t+NDT (original values are over-written) +C +C ******************************************************************** +C NOTES: +C This forward-in-time upstream-biased transport scheme reduces to +C the 2nd order center-in-time center-in-space mass continuity eqn. +C if Q = 1 (constant fields will remain constant). This also ensures +C that the computed vertical velocity to be identical to GEOS-1 GCM +C for on-line transport. +C +C A larger polar cap is used if j1=3 (recommended for C-Grid winds or when +C winds are noisy near poles). +C +C Flux-Form Semi-Lagrangian transport in the East-West direction is used +C when and where Courant # is greater than one. +C +C The user needs to change the parameter Jmax or Kmax if the resolution +C is greater than 0.5 deg in N-S or 150 layers in the vertical direction. +C (this TransPort Core is otherwise resolution independent and can be used +C as a library routine). +C +C PPM is 4th order accurate when grid spacing is uniform (x & y); 3rd +C order accurate for non-uniform grid (vertical sigma coord.). +C +C Time step is limitted only by transport in the meridional direction. +C (the FFSL scheme is not implemented in the meridional direction). +C +C Since only 1-D limiters are applied, negative values could +C potentially be generated when large time step is used and when the +C initial fields contain discontinuities. +C This does not necessarily imply the integration is unstable. +C These negatives are typically very small. A filling algorithm is +C activated if the user set "fill" to be true. +C +C The van Leer scheme used here is nearly as accurate as the original PPM +C due to the use of a 4th order accurate reference slope. The PPM imple- +C mented here is an improvement over the original and is also based on +C the 4th order reference slope. +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C +C User modifiable parameters +C + parameter (Jmax = 361, kmax = 150) +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C +C Input-Output arrays +C + + real Q(IMR,JNP,NLAY,NC),PS1(IMR,JNP),PS2(IMR,JNP), + & U(IMR,JNP,NLAY),V(IMR,JNP,NLAY),AP(NLAY+1), + & BP(NLAY+1),W(IMR,JNP,NLAY),NDT,val(NLAY),Umax + integer IGD,IORD,JORD,KORD,NC,IMR,JNP,j1,NLAY,AE + integer IMRD2 + real PT + logical cross, fill, dum +C +C Local dynamic arrays +C + real CRX(IMR,JNP),CRY(IMR,JNP),xmass(IMR,JNP),ymass(IMR,JNP), + & fx1(IMR+1),DPI(IMR,JNP,NLAY),delp1(IMR,JNP,NLAY), + & WK1(IMR,JNP,NLAY),PU(IMR,JNP),PV(IMR,JNP),DC2(IMR,JNP), + & delp2(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY,NC),VA(IMR,JNP), + & UA(IMR,JNP),qtmp(-IMR:2*IMR) +C +C Local static arrays +C + real DTDX(Jmax), DTDX5(Jmax), acosp(Jmax), + & cosp(Jmax), cose(Jmax), DAP(kmax),DBK(Kmax) + data NDT0, NSTEP /0, 0/ + data cross /.true./ + SAVE DTDY, DTDY5, RCAP, JS0, JN0, IML, + & DTDX, DTDX5, ACOSP, COSP, COSE, DAP,DBK +C + + JMR = JNP -1 + IMJM = IMR*JNP + j2 = JNP - j1 + 1 + NSTEP = NSTEP + 1 +C +C *********** Initialization ********************** + if(NSTEP.eq.1) then +c + write(6,*) '------------------------------------ ' + write(6,*) 'NASA/GSFC Transport Core Version 4.5' + write(6,*) '------------------------------------ ' +c + WRITE(6,*) 'IMR=',IMR,' JNP=',JNP,' NLAY=',NLAY,' j1=',j1 + WRITE(6,*) 'NC=',NC,IORD,JORD,KORD,NDT +C +C controles sur les parametres + if(NLAY.LT.6) then + write(6,*) 'NLAY must be >= 6' + stop + endif + if (JNP.LT.NLAY) then + write(6,*) 'JNP must be >= NLAY' + stop + endif + IMRD2=mod(IMR,2) + if (j1.eq.2.and.IMRD2.NE.0) then + write(6,*) 'if j1=2 IMR must be an even integer' + stop + endif + +C + if(Jmax.lt.JNP .or. Kmax.lt.NLAY) then + write(6,*) 'Jmax or Kmax is too small' + stop + endif +C + DO k=1,NLAY + DAP(k) = (AP(k+1) - AP(k))*PT + DBK(k) = BP(k+1) - BP(k) + ENDDO +C + PI = 4. * ATAN(1.) + DL = 2.*PI / float(IMR) + DP = PI / float(JMR) +C + if(IGD.eq.0) then +C Compute analytic cosine at cell edges + call cosa(cosp,cose,JNP,PI,DP) + else +C Define cosine consistent with GEOS-GCM (using dycore2.0 or later) + call cosc(cosp,cose,JNP,PI,DP) + endif +C + do 15 J=2,JMR +15 acosp(j) = 1. / cosp(j) +C +C Inverse of the Scaled polar cap area. +C + RCAP = DP / (IMR*(1.-COS((j1-1.5)*DP))) + acosp(1) = RCAP + acosp(JNP) = RCAP + endif +C + if(NDT0 .ne. NDT) then + DT = NDT + NDT0 = NDT + + if(Umax .lt. 180.) then + write(6,*) 'Umax may be too small!' + endif + CR1 = abs(Umax*DT)/(DL*AE) + MaxDT = DP*AE / abs(Umax) + 0.5 + write(6,*)'Largest time step for max(V)=',Umax,' is ',MaxDT + if(MaxDT .lt. abs(NDT)) then + write(6,*) 'Warning!!! NDT maybe too large!' + endif +C + if(CR1.ge.0.95) then + JS0 = 0 + JN0 = 0 + IML = IMR-2 + ZTC = 0. + else + ZTC = acos(CR1) * (180./PI) +C + JS0 = float(JMR)*(90.-ZTC)/180. + 2 + JS0 = max(JS0, J1+1) + IML = min(6*JS0/(J1-1)+2, 4*IMR/5) + JN0 = JNP-JS0+1 + endif +C +C + do J=2,JMR + DTDX(j) = DT / ( DL*AE*COSP(J) ) + +c print*,'dtdx=',dtdx(j) + DTDX5(j) = 0.5*DTDX(j) + enddo +C + + DTDY = DT /(AE*DP) +c print*,'dtdy=',dtdy + DTDY5 = 0.5*DTDY +C +c write(6,*) 'J1=',J1,' J2=', J2 + endif +C +C *********** End Initialization ********************** +C +C delp = pressure thickness: the psudo-density in a hydrostatic system. + do k=1,NLAY + do j=1,JNP + do i=1,IMR + delp1(i,j,k)=DAP(k)+DBK(k)*PS1(i,j) + delp2(i,j,k)=DAP(k)+DBK(k)*PS2(i,j) + enddo + enddo + enddo + +C + if(j1.ne.2) then + DO 40 IC=1,NC + DO 40 L=1,NLAY + DO 40 I=1,IMR + Q(I, 2,L,IC) = Q(I, 1,L,IC) +40 Q(I,JMR,L,IC) = Q(I,JNP,L,IC) + endif +C +C Compute "tracer density" + DO 550 IC=1,NC + DO 44 k=1,NLAY + DO 44 j=1,JNP + DO 44 i=1,IMR +44 DQ(i,j,k,IC) = Q(i,j,k,IC)*delp1(i,j,k) +550 continue +C + do 1500 k=1,NLAY +C + if(IGD.eq.0) then +C Convert winds on A-Grid to Courant # on C-Grid. + call A2C(U(1,1,k),V(1,1,k),IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5) + else +C Convert winds on C-grid to Courant # + do 45 j=j1,j2 + do 45 i=2,IMR +45 CRX(i,J) = dtdx(j)*U(i-1,j,k) + +C + do 50 j=j1,j2 +50 CRX(1,J) = dtdx(j)*U(IMR,j,k) +C + do 55 i=1,IMR*JMR +55 CRY(i,2) = DTDY*V(i,1,k) + endif +C +C Determine JS and JN + JS = j1 + JN = j2 +C + do j=JS0,j1+1,-1 + do i=1,IMR + if(abs(CRX(i,j)).GT.1.) then + JS = j + go to 2222 + endif + enddo + enddo +C +2222 continue + do j=JN0,j2-1 + do i=1,IMR + if(abs(CRX(i,j)).GT.1.) then + JN = j + go to 2233 + endif + enddo + enddo +2233 continue +C + if(j1.ne.2) then ! Enlarged polar cap. + do i=1,IMR + DPI(i, 2,k) = 0. + DPI(i,JMR,k) = 0. + enddo + endif +C +C ******* Compute horizontal mass fluxes ************ +C +C N-S component + do j=j1,j2+1 + D5 = 0.5 * COSE(j) + do i=1,IMR + ymass(i,j) = CRY(i,j)*D5*(delp2(i,j,k) + delp2(i,j-1,k)) + enddo + enddo +C + do 95 j=j1,j2 + DO 95 i=1,IMR +95 DPI(i,j,k) = (ymass(i,j) - ymass(i,j+1)) * acosp(j) +C +C Poles + sum1 = ymass(IMR,j1 ) + sum2 = ymass(IMR,J2+1) + do i=1,IMR-1 + sum1 = sum1 + ymass(i,j1 ) + sum2 = sum2 + ymass(i,J2+1) + enddo +C + sum1 = - sum1 * RCAP + sum2 = sum2 * RCAP + do i=1,IMR + DPI(i, 1,k) = sum1 + DPI(i,JNP,k) = sum2 + enddo +C +C E-W component +C + do j=j1,j2 + do i=2,IMR + PU(i,j) = 0.5 * (delp2(i,j,k) + delp2(i-1,j,k)) + enddo + enddo +C + do j=j1,j2 + PU(1,j) = 0.5 * (delp2(1,j,k) + delp2(IMR,j,k)) + enddo +C + do 110 j=j1,j2 + DO 110 i=1,IMR +110 xmass(i,j) = PU(i,j)*CRX(i,j) +C + DO 120 j=j1,j2 + DO 120 i=1,IMR-1 +120 DPI(i,j,k) = DPI(i,j,k) + xmass(i,j) - xmass(i+1,j) +C + DO 130 j=j1,j2 +130 DPI(IMR,j,k) = DPI(IMR,j,k) + xmass(IMR,j) - xmass(1,j) +C + DO j=j1,j2 + do i=1,IMR-1 + UA(i,j) = 0.5 * (CRX(i,j)+CRX(i+1,j)) + enddo + enddo +C + DO j=j1,j2 + UA(imr,j) = 0.5 * (CRX(imr,j)+CRX(1,j)) + enddo +ccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c Rajouts pour LMDZ.3.3 +ccccccccccccccccccccccccccccccccccccccccccccccccccccccc + do i=1,IMR + do j=1,JNP + VA(i,j)=0. + enddo + enddo + + do i=1,imr*(JMR-1) + VA(i,2) = 0.5*(CRY(i,2)+CRY(i,3)) + enddo +C + if(j1.eq.2) then + IMH = IMR/2 + do i=1,IMH + VA(i, 1) = 0.5*(CRY(i,2)-CRY(i+IMH,2)) + VA(i+IMH, 1) = -VA(i,1) + VA(i, JNP) = 0.5*(CRY(i,JNP)-CRY(i+IMH,JMR)) + VA(i+IMH,JNP) = -VA(i,JNP) + enddo + VA(IMR,1)=VA(1,1) + VA(IMR,JNP)=VA(1,JNP) + endif +C +C ****6***0*********0*********0*********0*********0*********0**********72 + do 1000 IC=1,NC +C + do i=1,IMJM + wk1(i,1,1) = 0. + wk1(i,1,2) = 0. + enddo +C +C E-W advective cross term + do 250 j=J1,J2 + if(J.GT.JS .and. J.LT.JN) GO TO 250 +C + do i=1,IMR + qtmp(i) = q(i,j,k,IC) + enddo +C + do i=-IML,0 + qtmp(i) = q(IMR+i,j,k,IC) + qtmp(IMR+1-i) = q(1-i,j,k,IC) + enddo +C + DO 230 i=1,IMR + iu = UA(i,j) + ru = UA(i,j) - iu + iiu = i-iu + if(UA(i,j).GE.0.) then + wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu)) + else + wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1)) + endif + wk1(i,j,1) = wk1(i,j,1) - qtmp(i) +230 continue +250 continue +C + if(JN.ne.0) then + do j=JS+1,JN-1 +C + do i=1,IMR + qtmp(i) = q(i,j,k,IC) + enddo +C + qtmp(0) = q(IMR,J,k,IC) + qtmp(IMR+1) = q( 1,J,k,IC) +C + do i=1,imr + iu = i - UA(i,j) + wk1(i,j,1) = UA(i,j)*(qtmp(iu) - qtmp(iu+1)) + enddo + enddo + endif +C ****6***0*********0*********0*********0*********0*********0**********72 +C Contribution from the N-S advection + do i=1,imr*(j2-j1+1) + JT = float(J1) - VA(i,j1) + wk1(i,j1,2) = VA(i,j1) * (q(i,jt,k,IC) - q(i,jt+1,k,IC)) + enddo +C + do i=1,IMJM + wk1(i,1,1) = q(i,1,k,IC) + 0.5*wk1(i,1,1) + wk1(i,1,2) = q(i,1,k,IC) + 0.5*wk1(i,1,2) + enddo +C + if(cross) then +C Add cross terms in the vertical direction. + if(IORD .GE. 2) then + iad = 2 + else + iad = 1 + endif +C + if(JORD .GE. 2) then + jad = 2 + else + jad = 1 + endif + call xadv(IMR,JNP,j1,j2,wk1(1,1,2),UA,JS,JN,IML,DC2,iad) + call yadv(IMR,JNP,j1,j2,wk1(1,1,1),VA,PV,W,jad) + do j=1,JNP + do i=1,IMR + q(i,j,k,IC) = q(i,j,k,IC) + DC2(i,j) + PV(i,j) + enddo + enddo + endif +C + call xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ(1,1,k,IC),wk1(1,1,2) + & ,CRX,fx1,xmass,IORD) + + call ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ(1,1,k,IC),wk1(1,1,1),CRY, + & DC2,ymass,WK1(1,1,3),wk1(1,1,4),WK1(1,1,5),WK1(1,1,6),JORD) +C +1000 continue +1500 continue +C +C ******* Compute vertical mass flux (same unit as PS) *********** +C +C 1st step: compute total column mass CONVERGENCE. +C + do 320 j=1,JNP + do 320 i=1,IMR +320 CRY(i,j) = DPI(i,j,1) +C + do 330 k=2,NLAY + do 330 j=1,JNP + do 330 i=1,IMR + CRY(i,j) = CRY(i,j) + DPI(i,j,k) +330 continue +C + do 360 j=1,JNP + do 360 i=1,IMR +C +C 2nd step: compute PS2 (PS at n+1) using the hydrostatic assumption. +C Changes (increases) to surface pressure = total column mass convergence +C + PS2(i,j) = PS1(i,j) + CRY(i,j) +C +C 3rd step: compute vertical mass flux from mass conservation principle. +C + W(i,j,1) = DPI(i,j,1) - DBK(1)*CRY(i,j) + W(i,j,NLAY) = 0. +360 continue +C + do 370 k=2,NLAY-1 + do 370 j=1,JNP + do 370 i=1,IMR + W(i,j,k) = W(i,j,k-1) + DPI(i,j,k) - DBK(k)*CRY(i,j) +370 continue +C + DO 380 k=1,NLAY + DO 380 j=1,JNP + DO 380 i=1,IMR + delp2(i,j,k) = DAP(k) + DBK(k)*PS2(i,j) +380 continue +C + KRD = max(3, KORD) + do 4000 IC=1,NC +C +C****6***0*********0*********0*********0*********0*********0**********72 + + call FZPPM(IMR,JNP,NLAY,j1,DQ(1,1,1,IC),W,Q(1,1,1,IC),WK1,DPI, + & DC2,CRX,CRY,PU,PV,xmass,ymass,delp1,KRD) +C + + if(fill) call qckxyz(DQ(1,1,1,IC),DC2,IMR,JNP,NLAY,j1,j2, + & cosp,acosp,.false.,IC,NSTEP) +C +C Recover tracer mixing ratio from "density" using predicted +C "air density" (pressure thickness) at time-level n+1 +C + DO k=1,NLAY + DO j=1,JNP + DO i=1,IMR + Q(i,j,k,IC) = DQ(i,j,k,IC) / delp2(i,j,k) +c print*,'i=',i,'j=',j,'k=',k,'Q(i,j,k,IC)=',Q(i,j,k,IC) + enddo + enddo + enddo +C + if(j1.ne.2) then + DO 400 k=1,NLAY + DO 400 I=1,IMR +c j=1 c'est le pôle Sud, j=JNP c'est le pôle Nord + Q(I, 2,k,IC) = Q(I, 1,k,IC) + Q(I,JMR,k,IC) = Q(I,JNP,k,IC) +400 CONTINUE + endif +4000 continue +C + if(j1.ne.2) then + DO 5000 k=1,NLAY + DO 5000 i=1,IMR + W(i, 2,k) = W(i, 1,k) + W(i,JMR,k) = W(i,JNP,k) +5000 continue + endif +C + RETURN + END +C +C****6***0*********0*********0*********0*********0*********0**********72 + subroutine FZPPM(IMR,JNP,NLAY,j1,DQ,WZ,P,DC,DQDT,AR,AL,A6, + & flux,wk1,wk2,wz2,delp,KORD) + parameter ( kmax = 150 ) + parameter ( R23 = 2./3., R3 = 1./3.) + real WZ(IMR,JNP,NLAY),P(IMR,JNP,NLAY),DC(IMR,JNP,NLAY), + & wk1(IMR,*),delp(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY), + & DQDT(IMR,JNP,NLAY) +C Assuming JNP >= NLAY + real AR(IMR,*),AL(IMR,*),A6(IMR,*),flux(IMR,*),wk2(IMR,*), + & wz2(IMR,*) +C + JMR = JNP - 1 + IMJM = IMR*JNP + NLAYM1 = NLAY - 1 +C + LMT = KORD - 3 +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C Compute DC for PPM +C ****6***0*********0*********0*********0*********0*********0**********72 +C + do 1000 k=1,NLAYM1 + do 1000 i=1,IMJM + DQDT(i,1,k) = P(i,1,k+1) - P(i,1,k) +1000 continue +C + DO 1220 k=2,NLAYM1 + DO 1220 I=1,IMJM + c0 = delp(i,1,k) / (delp(i,1,k-1)+delp(i,1,k)+delp(i,1,k+1)) + c1 = (delp(i,1,k-1)+0.5*delp(i,1,k))/(delp(i,1,k+1)+delp(i,1,k)) + c2 = (delp(i,1,k+1)+0.5*delp(i,1,k))/(delp(i,1,k-1)+delp(i,1,k)) + tmp = c0*(c1*DQDT(i,1,k) + c2*DQDT(i,1,k-1)) + Qmax = max(P(i,1,k-1),P(i,1,k),P(i,1,k+1)) - P(i,1,k) + Qmin = P(i,1,k) - min(P(i,1,k-1),P(i,1,k),P(i,1,k+1)) + DC(i,1,k) = sign(min(abs(tmp),Qmax,Qmin), tmp) +1220 CONTINUE + +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C Loop over latitudes (to save memory) +C ****6***0*********0*********0*********0*********0*********0**********72 +C + DO 2000 j=1,JNP + if((j.eq.2 .or. j.eq.JMR) .and. j1.ne.2) goto 2000 +C + DO k=1,NLAY + DO i=1,IMR + wz2(i,k) = WZ(i,j,k) + wk1(i,k) = P(i,j,k) + wk2(i,k) = delp(i,j,k) + flux(i,k) = DC(i,j,k) !this flux is actually the monotone slope + enddo + enddo +C +C****6***0*********0*********0*********0*********0*********0**********72 +C Compute first guesses at cell interfaces +C First guesses are required to be continuous. +C ****6***0*********0*********0*********0*********0*********0**********72 +C +C three-cell parabolic subgrid distribution at model top +C two-cell parabolic with zero gradient subgrid distribution +C at the surface. +C +C First guess top edge value + DO 10 i=1,IMR +C three-cell PPM +C Compute a,b, and c of q = aP**2 + bP + c using cell averages and delp + a = 3.*( DQDT(i,j,2) - DQDT(i,j,1)*(wk2(i,2)+wk2(i,3))/ + & (wk2(i,1)+wk2(i,2)) ) / + & ( (wk2(i,2)+wk2(i,3))*(wk2(i,1)+wk2(i,2)+wk2(i,3)) ) + b = 2.*DQDT(i,j,1)/(wk2(i,1)+wk2(i,2)) - + & R23*a*(2.*wk2(i,1)+wk2(i,2)) + AL(i,1) = wk1(i,1) - wk2(i,1)*(R3*a*wk2(i,1) + 0.5*b) + AL(i,2) = wk2(i,1)*(a*wk2(i,1) + b) + AL(i,1) +C +C Check if change sign + if(wk1(i,1)*AL(i,1).le.0.) then + AL(i,1) = 0. + flux(i,1) = 0. + else + flux(i,1) = wk1(i,1) - AL(i,1) + endif +10 continue +C +C Bottom + DO 15 i=1,IMR +C 2-cell PPM with zero gradient right at the surface +C + fct = DQDT(i,j,NLAYM1)*wk2(i,NLAY)**2 / + & ( (wk2(i,NLAY)+wk2(i,NLAYM1))*(2.*wk2(i,NLAY)+wk2(i,NLAYM1))) + AR(i,NLAY) = wk1(i,NLAY) + fct + AL(i,NLAY) = wk1(i,NLAY) - (fct+fct) + if(wk1(i,NLAY)*AR(i,NLAY).le.0.) AR(i,NLAY) = 0. + flux(i,NLAY) = AR(i,NLAY) - wk1(i,NLAY) +15 continue + +C +C****6***0*********0*********0*********0*********0*********0**********72 +C 4th order interpolation in the interior. +C****6***0*********0*********0*********0*********0*********0**********72 +C + DO 14 k=3,NLAYM1 + DO 12 i=1,IMR + c1 = DQDT(i,j,k-1)*wk2(i,k-1) / (wk2(i,k-1)+wk2(i,k)) + c2 = 2. / (wk2(i,k-2)+wk2(i,k-1)+wk2(i,k)+wk2(i,k+1)) + A1 = (wk2(i,k-2)+wk2(i,k-1)) / (2.*wk2(i,k-1)+wk2(i,k)) + A2 = (wk2(i,k )+wk2(i,k+1)) / (2.*wk2(i,k)+wk2(i,k-1)) + AL(i,k) = wk1(i,k-1) + c1 + c2 * + & ( wk2(i,k )*(c1*(A1 - A2)+A2*flux(i,k-1)) - + & wk2(i,k-1)*A1*flux(i,k) ) +C print *,'AL1',i,k, AL(i,k) +12 CONTINUE +14 continue +C + do 20 i=1,IMR*NLAYM1 + AR(i,1) = AL(i,2) +C print *,'AR1',i,AR(i,1) +20 continue +C + do 30 i=1,IMR*NLAY + A6(i,1) = 3.*(wk1(i,1)+wk1(i,1) - (AL(i,1)+AR(i,1))) +C print *,'A61',i,A6(i,1) +30 continue +C +C****6***0*********0*********0*********0*********0*********0**********72 +C Top & Bot always monotonic + call lmtppm(flux(1,1),A6(1,1),AR(1,1),AL(1,1),wk1(1,1),IMR,0) + call lmtppm(flux(1,NLAY),A6(1,NLAY),AR(1,NLAY),AL(1,NLAY), + & wk1(1,NLAY),IMR,0) +C +C Interior depending on KORD + if(LMT.LE.2) + & call lmtppm(flux(1,2),A6(1,2),AR(1,2),AL(1,2),wk1(1,2), + & IMR*(NLAY-2),LMT) +C +C****6***0*********0*********0*********0*********0*********0**********72 +C + DO 140 i=1,IMR*NLAYM1 + IF(wz2(i,1).GT.0.) then + CM = wz2(i,1) / wk2(i,1) + flux(i,2) = AR(i,1)+0.5*CM*(AL(i,1)-AR(i,1)+A6(i,1)*(1.-R23*CM)) + else +C print *,'test2-0',i,j,wz2(i,1),wk2(i,2) + CP= wz2(i,1) / wk2(i,2) +C print *,'testCP',CP + flux(i,2) = AL(i,2)+0.5*CP*(AL(i,2)-AR(i,2)-A6(i,2)*(1.+R23*CP)) +C print *,'test2',i, AL(i,2),AR(i,2),A6(i,2),R23 + endif +140 continue +C + DO 250 i=1,IMR*NLAYM1 + flux(i,2) = wz2(i,1) * flux(i,2) +250 continue +C + do 350 i=1,IMR + DQ(i,j, 1) = DQ(i,j, 1) - flux(i, 2) + DQ(i,j,NLAY) = DQ(i,j,NLAY) + flux(i,NLAY) +350 continue +C + do 360 k=2,NLAYM1 + do 360 i=1,IMR +360 DQ(i,j,k) = DQ(i,j,k) + flux(i,k) - flux(i,k+1) +2000 continue + return + end +C + subroutine xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ,Q,UC, + & fx1,xmass,IORD) + dimension UC(IMR,*),DC(-IML:IMR+IML+1),xmass(IMR,JNP) + & ,fx1(IMR+1),DQ(IMR,JNP),qtmp(-IML:IMR+1+IML) + dimension PU(IMR,JNP),Q(IMR,JNP),ISAVE(IMR) +C + IMP = IMR + 1 +C +C van Leer at high latitudes + jvan = max(1,JNP/18) + j1vl = j1+jvan + j2vl = j2-jvan +C + do 1310 j=j1,j2 +C + do i=1,IMR + qtmp(i) = q(i,j) + enddo +C + if(j.ge.JN .or. j.le.JS) goto 2222 +C ************* Eulerian ********** +C + qtmp(0) = q(IMR,J) + qtmp(-1) = q(IMR-1,J) + qtmp(IMP) = q(1,J) + qtmp(IMP+1) = q(2,J) +C + IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN + DO 1406 i=1,IMR + iu = float(i) - uc(i,j) +1406 fx1(i) = qtmp(iu) + ELSE + call xmist(IMR,IML,Qtmp,DC) + DC(0) = DC(IMR) +C + if(IORD.eq.2 .or. j.le.j1vl .or. j.ge.j2vl) then + DO 1408 i=1,IMR + iu = float(i) - uc(i,j) +1408 fx1(i) = qtmp(iu) + DC(iu)*(sign(1.,uc(i,j))-uc(i,j)) + else + call fxppm(IMR,IML,UC(1,j),Qtmp,DC,fx1,IORD) + endif +C + ENDIF +C + DO 1506 i=1,IMR +1506 fx1(i) = fx1(i)*xmass(i,j) +C + goto 1309 +C +C ***** Conservative (flux-form) Semi-Lagrangian transport ***** +C +2222 continue +C + do i=-IML,0 + qtmp(i) = q(IMR+i,j) + qtmp(IMP-i) = q(1-i,j) + enddo +C + IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN + DO 1306 i=1,IMR + itmp = INT(uc(i,j)) + ISAVE(i) = i - itmp + iu = i - uc(i,j) +1306 fx1(i) = (uc(i,j) - itmp)*qtmp(iu) + ELSE + call xmist(IMR,IML,Qtmp,DC) +C + do i=-IML,0 + DC(i) = DC(IMR+i) + DC(IMP-i) = DC(1-i) + enddo +C + DO 1307 i=1,IMR + itmp = INT(uc(i,j)) + rut = uc(i,j) - itmp + ISAVE(i) = i - itmp + iu = i - uc(i,j) +1307 fx1(i) = rut*(qtmp(iu) + DC(iu)*(sign(1.,rut) - rut)) + ENDIF +C + do 1308 i=1,IMR + IF(uc(i,j).GT.1.) then +CDIR$ NOVECTOR + do ist = ISAVE(i),i-1 + fx1(i) = fx1(i) + qtmp(ist) + enddo + elseIF(uc(i,j).LT.-1.) then + do ist = i,ISAVE(i)-1 + fx1(i) = fx1(i) - qtmp(ist) + enddo +CDIR$ VECTOR + endif +1308 continue + do i=1,IMR + fx1(i) = PU(i,j)*fx1(i) + enddo +C +C *************************************** +C +1309 fx1(IMP) = fx1(1) + DO 1215 i=1,IMR +1215 DQ(i,j) = DQ(i,j) + fx1(i)-fx1(i+1) +C +C *************************************** +C +1310 continue + return + end +C + subroutine fxppm(IMR,IML,UT,P,DC,flux,IORD) + parameter ( R3 = 1./3., R23 = 2./3. ) + DIMENSION UT(*),flux(*),P(-IML:IMR+IML+1),DC(-IML:IMR+IML+1) + DIMENSION AR(0:IMR),AL(0:IMR),A6(0:IMR) + integer LMT +c logical first +c data first /.true./ +c SAVE LMT +c if(first) then +C +C correction calcul de LMT a chaque passage pour pouvoir choisir +c plusieurs schemas PPM pour differents traceurs +c IF (IORD.LE.0) then +c if(IMR.GE.144) then +c LMT = 0 +c elseif(IMR.GE.72) then +c LMT = 1 +c else +c LMT = 2 +c endif +c else +c LMT = IORD - 3 +c endif +C + LMT = IORD - 3 +c write(6,*) 'PPM option in E-W direction = ', LMT +c first = .false. +C endif +C + DO 10 i=1,IMR +10 AL(i) = 0.5*(p(i-1)+p(i)) + (DC(i-1) - DC(i))*R3 +C + do 20 i=1,IMR-1 +20 AR(i) = AL(i+1) + AR(IMR) = AL(1) +C + do 30 i=1,IMR +30 A6(i) = 3.*(p(i)+p(i) - (AL(i)+AR(i))) +C + if(LMT.LE.2) call lmtppm(DC(1),A6(1),AR(1),AL(1),P(1),IMR,LMT) +C + AL(0) = AL(IMR) + AR(0) = AR(IMR) + A6(0) = A6(IMR) +C + DO i=1,IMR + IF(UT(i).GT.0.) then + flux(i) = AR(i-1) + 0.5*UT(i)*(AL(i-1) - AR(i-1) + + & A6(i-1)*(1.-R23*UT(i)) ) + else + flux(i) = AL(i) - 0.5*UT(i)*(AR(i) - AL(i) + + & A6(i)*(1.+R23*UT(i))) + endif + enddo + return + end +C + subroutine xmist(IMR,IML,P,DC) + parameter( R24 = 1./24.) + dimension P(-IML:IMR+1+IML),DC(-IML:IMR+1+IML) +C + do 10 i=1,IMR + tmp = R24*(8.*(p(i+1) - p(i-1)) + p(i-2) - p(i+2)) + Pmax = max(P(i-1), p(i), p(i+1)) - p(i) + Pmin = p(i) - min(P(i-1), p(i), p(i+1)) +10 DC(i) = sign(min(abs(tmp),Pmax,Pmin), tmp) + return + end +C + subroutine ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ,P,VC,DC2 + & ,ymass,fx,A6,AR,AL,JORD) + dimension P(IMR,JNP),VC(IMR,JNP),ymass(IMR,JNP) + & ,DC2(IMR,JNP),DQ(IMR,JNP),acosp(JNP) +C Work array + DIMENSION fx(IMR,JNP),AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP) +C + JMR = JNP - 1 + len = IMR*(J2-J1+2) +C + if(JORD.eq.1) then + DO 1000 i=1,len + JT = float(J1) - VC(i,J1) +1000 fx(i,j1) = p(i,JT) + else + + call ymist(IMR,JNP,j1,P,DC2,4) +C + if(JORD.LE.0 .or. JORD.GE.3) then + + call fyppm(VC,P,DC2,fx,IMR,JNP,j1,j2,A6,AR,AL,JORD) + + else + DO 1200 i=1,len + JT = float(J1) - VC(i,J1) +1200 fx(i,j1) = p(i,JT) + (sign(1.,VC(i,j1))-VC(i,j1))*DC2(i,JT) + endif + endif +C + DO 1300 i=1,len +1300 fx(i,j1) = fx(i,j1)*ymass(i,j1) +C + DO 1400 j=j1,j2 + DO 1400 i=1,IMR +1400 DQ(i,j) = DQ(i,j) + (fx(i,j) - fx(i,j+1)) * acosp(j) +C +C Poles + sum1 = fx(IMR,j1 ) + sum2 = fx(IMR,J2+1) + do i=1,IMR-1 + sum1 = sum1 + fx(i,j1 ) + sum2 = sum2 + fx(i,J2+1) + enddo +C + sum1 = DQ(1, 1) - sum1 * RCAP + sum2 = DQ(1,JNP) + sum2 * RCAP + do i=1,IMR + DQ(i, 1) = sum1 + DQ(i,JNP) = sum2 + enddo +C + if(j1.ne.2) then + do i=1,IMR + DQ(i, 2) = sum1 + DQ(i,JMR) = sum2 + enddo + endif +C + return + end +C + subroutine ymist(IMR,JNP,j1,P,DC,ID) + parameter ( R24 = 1./24. ) + dimension P(IMR,JNP),DC(IMR,JNP) +C + IMH = IMR / 2 + JMR = JNP - 1 + IJM3 = IMR*(JMR-3) +C + IF(ID.EQ.2) THEN + do 10 i=1,IMR*(JMR-1) + tmp = 0.25*(p(i,3) - p(i,1)) + Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2) + Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3)) + DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp) +10 CONTINUE + ELSE + do 12 i=1,IMH +C J=2 + tmp = (8.*(p(i,3) - p(i,1)) + p(i+IMH,2) - p(i,4))*R24 + Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2) + Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3)) + DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp) +C J=JMR + tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i+IMH,JMR))*R24 + Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR) + Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP)) + DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp) +12 CONTINUE + do 14 i=IMH+1,IMR +C J=2 + tmp = (8.*(p(i,3) - p(i,1)) + p(i-IMH,2) - p(i,4))*R24 + Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2) + Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3)) + DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp) +C J=JMR + tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i-IMH,JMR))*R24 + Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR) + Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP)) + DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp) +14 CONTINUE +C + do 15 i=1,IJM3 + tmp = (8.*(p(i,4) - p(i,2)) + p(i,1) - p(i,5))*R24 + Pmax = max(p(i,2),p(i,3),p(i,4)) - p(i,3) + Pmin = p(i,3) - min(p(i,2),p(i,3),p(i,4)) + DC(i,3) = sign(min(abs(tmp),Pmin,Pmax),tmp) +15 CONTINUE + ENDIF +C + if(j1.ne.2) then + do i=1,IMR + DC(i,1) = 0. + DC(i,JNP) = 0. + enddo + else +C Determine slopes in polar caps for scalars! +C + do 13 i=1,IMH +C South + tmp = 0.25*(p(i,2) - p(i+imh,2)) + Pmax = max(p(i,2),p(i,1), p(i+imh,2)) - p(i,1) + Pmin = p(i,1) - min(p(i,2),p(i,1), p(i+imh,2)) + DC(i,1)=sign(min(abs(tmp),Pmax,Pmin),tmp) +C North. + tmp = 0.25*(p(i+imh,JMR) - p(i,JMR)) + Pmax = max(p(i+imh,JMR),p(i,jnp), p(i,JMR)) - p(i,JNP) + Pmin = p(i,JNP) - min(p(i+imh,JMR),p(i,jnp), p(i,JMR)) + DC(i,JNP) = sign(min(abs(tmp),Pmax,pmin),tmp) +13 continue +C + do 25 i=imh+1,IMR + DC(i, 1) = - DC(i-imh, 1) + DC(i,JNP) = - DC(i-imh,JNP) +25 continue + endif + return + end +C + subroutine fyppm(VC,P,DC,flux,IMR,JNP,j1,j2,A6,AR,AL,JORD) + parameter ( R3 = 1./3., R23 = 2./3. ) + real VC(IMR,*),flux(IMR,*),P(IMR,*),DC(IMR,*) +C Local work arrays. + real AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP) + integer LMT +c logical first +C data first /.true./ +C SAVE LMT +C + IMH = IMR / 2 + JMR = JNP - 1 + j11 = j1-1 + IMJM1 = IMR*(J2-J1+2) + len = IMR*(J2-J1+3) +C if(first) then +C IF(JORD.LE.0) then +C if(JMR.GE.90) then +C LMT = 0 +C elseif(JMR.GE.45) then +C LMT = 1 +C else +C LMT = 2 +C endif +C else +C LMT = JORD - 3 +C endif +C +C first = .false. +C endif +C +c modifs pour pouvoir choisir plusieurs schemas PPM + LMT = JORD - 3 +C + DO 10 i=1,IMR*JMR + AL(i,2) = 0.5*(p(i,1)+p(i,2)) + (DC(i,1) - DC(i,2))*R3 + AR(i,1) = AL(i,2) +10 CONTINUE +C +CPoles: +C + DO i=1,IMH + AL(i,1) = AL(i+IMH,2) + AL(i+IMH,1) = AL(i,2) +C + AR(i,JNP) = AR(i+IMH,JMR) + AR(i+IMH,JNP) = AR(i,JMR) + ENDDO + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c Rajout pour LMDZ.3.3 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + AR(IMR,1)=AL(1,1) + AR(IMR,JNP)=AL(1,JNP) +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + + do 30 i=1,len +30 A6(i,j11) = 3.*(p(i,j11)+p(i,j11) - (AL(i,j11)+AR(i,j11))) +C + if(LMT.le.2) call lmtppm(DC(1,j11),A6(1,j11),AR(1,j11) + & ,AL(1,j11),P(1,j11),len,LMT) +C + + DO 140 i=1,IMJM1 + IF(VC(i,j1).GT.0.) then + flux(i,j1) = AR(i,j11) + 0.5*VC(i,j1)*(AL(i,j11) - AR(i,j11) + + & A6(i,j11)*(1.-R23*VC(i,j1)) ) + else + flux(i,j1) = AL(i,j1) - 0.5*VC(i,j1)*(AR(i,j1) - AL(i,j1) + + & A6(i,j1)*(1.+R23*VC(i,j1))) + endif +140 continue + return + end +C + subroutine yadv(IMR,JNP,j1,j2,p,VA,ady,wk,IAD) + REAL p(IMR,JNP),ady(IMR,JNP),VA(IMR,JNP) + REAL WK(IMR,-1:JNP+2) +C + JMR = JNP-1 + IMH = IMR/2 + do j=1,JNP + do i=1,IMR + wk(i,j) = p(i,j) + enddo + enddo +C Poles: + do i=1,IMH + wk(i, -1) = p(i+IMH,3) + wk(i+IMH,-1) = p(i,3) + wk(i, 0) = p(i+IMH,2) + wk(i+IMH,0) = p(i,2) + wk(i,JNP+1) = p(i+IMH,JMR) + wk(i+IMH,JNP+1) = p(i,JMR) + wk(i,JNP+2) = p(i+IMH,JNP-2) + wk(i+IMH,JNP+2) = p(i,JNP-2) + enddo +c write(*,*) 'toto 1' +C -------------------------------- + IF(IAD.eq.2) then + do j=j1-1,j2+1 + do i=1,IMR +c write(*,*) 'avt NINT','i=',i,'j=',j + JP = NINT(VA(i,j)) + rv = JP - VA(i,j) +c write(*,*) 'VA=',VA(i,j), 'JP1=',JP,'rv=',rv + JP = j - JP +c write(*,*) 'JP2=',JP + a1 = 0.5*(wk(i,jp+1)+wk(i,jp-1)) - wk(i,jp) + b1 = 0.5*(wk(i,jp+1)-wk(i,jp-1)) +c write(*,*) 'a1=',a1,'b1=',b1 + ady(i,j) = wk(i,jp) + rv*(a1*rv + b1) - wk(i,j) + enddo + enddo +c write(*,*) 'toto 2' +C + ELSEIF(IAD.eq.1) then + do j=j1-1,j2+1 + do i=1,imr + JP = float(j)-VA(i,j) + ady(i,j) = VA(i,j)*(wk(i,jp)-wk(i,jp+1)) + enddo + enddo + ENDIF +C + if(j1.ne.2) then + sum1 = 0. + sum2 = 0. + do i=1,imr + sum1 = sum1 + ady(i,2) + sum2 = sum2 + ady(i,JMR) + enddo + sum1 = sum1 / IMR + sum2 = sum2 / IMR +C + do i=1,imr + ady(i, 2) = sum1 + ady(i,JMR) = sum2 + ady(i, 1) = sum1 + ady(i,JNP) = sum2 + enddo + else +C Poles: + sum1 = 0. + sum2 = 0. + do i=1,imr + sum1 = sum1 + ady(i,1) + sum2 = sum2 + ady(i,JNP) + enddo + sum1 = sum1 / IMR + sum2 = sum2 / IMR +C + do i=1,imr + ady(i, 1) = sum1 + ady(i,JNP) = sum2 + enddo + endif +C + return + end +C + subroutine xadv(IMR,JNP,j1,j2,p,UA,JS,JN,IML,adx,IAD) + REAL p(IMR,JNP),adx(IMR,JNP),qtmp(-IMR:IMR+IMR),UA(IMR,JNP) +C + JMR = JNP-1 + do 1309 j=j1,j2 + if(J.GT.JS .and. J.LT.JN) GO TO 1309 +C + do i=1,IMR + qtmp(i) = p(i,j) + enddo +C + do i=-IML,0 + qtmp(i) = p(IMR+i,j) + qtmp(IMR+1-i) = p(1-i,j) + enddo +C + IF(IAD.eq.2) THEN + DO i=1,IMR + IP = NINT(UA(i,j)) + ru = IP - UA(i,j) + IP = i - IP + a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip) + b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1)) + adx(i,j) = qtmp(ip) + ru*(a1*ru + b1) + enddo + ELSEIF(IAD.eq.1) then + DO i=1,IMR + iu = UA(i,j) + ru = UA(i,j) - iu + iiu = i-iu + if(UA(i,j).GE.0.) then + adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu)) + else + adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1)) + endif + enddo + ENDIF +C + do i=1,IMR + adx(i,j) = adx(i,j) - p(i,j) + enddo +1309 continue +C +C Eulerian upwind +C + do j=JS+1,JN-1 +C + do i=1,IMR + qtmp(i) = p(i,j) + enddo +C + qtmp(0) = p(IMR,J) + qtmp(IMR+1) = p(1,J) +C + IF(IAD.eq.2) THEN + qtmp(-1) = p(IMR-1,J) + qtmp(IMR+2) = p(2,J) + do i=1,imr + IP = NINT(UA(i,j)) + ru = IP - UA(i,j) + IP = i - IP + a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip) + b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1)) + adx(i,j) = qtmp(ip)- p(i,j) + ru*(a1*ru + b1) + enddo + ELSEIF(IAD.eq.1) then +C 1st order + DO i=1,IMR + IP = i - UA(i,j) + adx(i,j) = UA(i,j)*(qtmp(ip)-qtmp(ip+1)) + enddo + ENDIF + enddo +C + if(j1.ne.2) then + do i=1,IMR + adx(i, 2) = 0. + adx(i,JMR) = 0. + enddo + endif +C set cross term due to x-adv at the poles to zero. + do i=1,IMR + adx(i, 1) = 0. + adx(i,JNP) = 0. + enddo + return + end +C + subroutine lmtppm(DC,A6,AR,AL,P,IM,LMT) +C +C A6 = CURVATURE OF THE TEST PARABOLA +C AR = RIGHT EDGE VALUE OF THE TEST PARABOLA +C AL = LEFT EDGE VALUE OF THE TEST PARABOLA +C DC = 0.5 * MISMATCH +C P = CELL-AVERAGED VALUE +C IM = VECTOR LENGTH +C +C OPTIONS: +C +C LMT = 0: FULL MONOTONICITY +C LMT = 1: SEMI-MONOTONIC CONSTRAINT (NO UNDERSHOOTS) +C LMT = 2: POSITIVE-DEFINITE CONSTRAINT +C + parameter ( R12 = 1./12. ) + dimension A6(IM),AR(IM),AL(IM),P(IM),DC(IM) +C + if(LMT.eq.0) then +C Full constraint + do 100 i=1,IM + if(DC(i).eq.0.) then + AR(i) = p(i) + AL(i) = p(i) + A6(i) = 0. + else + da1 = AR(i) - AL(i) + da2 = da1**2 + A6DA = A6(i)*da1 + if(A6DA .lt. -da2) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + elseif(A6DA .gt. da2) then + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif + endif +100 continue + elseif(LMT.eq.1) then +C Semi-monotonic constraint + do 150 i=1,IM + if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 150 + if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then + AR(i) = p(i) + AL(i) = p(i) + A6(i) = 0. + elseif(AR(i) .gt. AL(i)) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + else + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif +150 continue + elseif(LMT.eq.2) then + do 250 i=1,IM + if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 250 + fmin = p(i) + 0.25*(AR(i)-AL(i))**2/A6(i) + A6(i)*R12 + if(fmin.ge.0.) go to 250 + if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then + AR(i) = p(i) + AL(i) = p(i) + A6(i) = 0. + elseif(AR(i) .gt. AL(i)) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + else + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif +250 continue + endif + return + end +C + subroutine A2C(U,V,IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5) + dimension U(IMR,*),V(IMR,*),CRX(IMR,*),CRY(IMR,*),DTDX5(*) +C + do 35 j=j1,j2 + do 35 i=2,IMR +35 CRX(i,J) = dtdx5(j)*(U(i,j)+U(i-1,j)) +C + do 45 j=j1,j2 +45 CRX(1,J) = dtdx5(j)*(U(1,j)+U(IMR,j)) +C + do 55 i=1,IMR*JMR +55 CRY(i,2) = DTDY5*(V(i,2)+V(i,1)) + return + end +C + subroutine cosa(cosp,cose,JNP,PI,DP) + dimension cosp(*),cose(*) + JMR = JNP-1 + do 55 j=2,JNP + ph5 = -0.5*PI + (FLOAT(J-1)-0.5)*DP +55 cose(j) = cos(ph5) +C + JEQ = (JNP+1) / 2 + if(JMR .eq. 2*(JMR/2) ) then + do j=JNP, JEQ+1, -1 + cose(j) = cose(JNP+2-j) + enddo + else +C cell edge at equator. + cose(JEQ+1) = 1. + do j=JNP, JEQ+2, -1 + cose(j) = cose(JNP+2-j) + enddo + endif +C + do 66 j=2,JMR +66 cosp(j) = 0.5*(cose(j)+cose(j+1)) + cosp(1) = 0. + cosp(JNP) = 0. + return + end +C + subroutine cosc(cosp,cose,JNP,PI,DP) + dimension cosp(*),cose(*) +C + phi = -0.5*PI + do 55 j=2,JNP-1 + phi = phi + DP +55 cosp(j) = cos(phi) + cosp( 1) = 0. + cosp(JNP) = 0. +C + do 66 j=2,JNP + cose(j) = 0.5*(cosp(j)+cosp(j-1)) +66 CONTINUE +C + do 77 j=2,JNP-1 + cosp(j) = 0.5*(cose(j)+cose(j+1)) +77 CONTINUE + return + end +C + SUBROUTINE qckxyz (Q,qtmp,IMR,JNP,NLAY,j1,j2,cosp,acosp, + & cross,IC,NSTEP) +C + parameter( tiny = 1.E-60 ) + DIMENSION Q(IMR,JNP,NLAY),qtmp(IMR,JNP),cosp(*),acosp(*) + logical cross +C + NLAYM1 = NLAY-1 + len = IMR*(j2-j1+1) + ip = 0 +C +C Top layer + L = 1 + icr = 1 + call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + if(ipy.eq.0) goto 50 + call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny) + if(ipx.eq.0) goto 50 +C + if(cross) then + call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + endif + if(icr.eq.0) goto 50 +C +C Vertical filling... + do i=1,len + IF( Q(i,j1,1).LT.0.) THEN + ip = ip + 1 + Q(i,j1,2) = Q(i,j1,2) + Q(i,j1,1) + Q(i,j1,1) = 0. + endif + enddo +C +50 continue + DO 225 L = 2,NLAYM1 + icr = 1 +C + call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + if(ipy.eq.0) goto 225 + call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny) + if(ipx.eq.0) go to 225 + if(cross) then + call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + endif + if(icr.eq.0) goto 225 +C + do i=1,len + IF( Q(I,j1,L).LT.0.) THEN +C + ip = ip + 1 +C From above + qup = Q(I,j1,L-1) + qly = -Q(I,j1,L) + dup = min(qly,qup) + Q(I,j1,L-1) = qup - dup + Q(I,j1,L ) = dup-qly +C Below + Q(I,j1,L+1) = Q(I,j1,L+1) + Q(I,j1,L) + Q(I,j1,L) = 0. + ENDIF + ENDDO +225 CONTINUE +C +C BOTTOM LAYER + sum = 0. + L = NLAY +C + call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + if(ipy.eq.0) goto 911 + call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny) + if(ipx.eq.0) goto 911 +C + call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + if(icr.eq.0) goto 911 +C + DO I=1,len + IF( Q(I,j1,L).LT.0.) THEN + ip = ip + 1 +c +C From above +C + qup = Q(I,j1,NLAYM1) + qly = -Q(I,j1,L) + dup = min(qly,qup) + Q(I,j1,NLAYM1) = qup - dup +C From "below" the surface. + sum = sum + qly-dup + Q(I,j1,L) = 0. + ENDIF + ENDDO +C +911 continue +C + if(ip.gt.IMR) then + write(6,*) 'IC=',IC,' STEP=',NSTEP, + & ' Vertical filling pts=',ip + endif +C + if(sum.gt.1.e-25) then + write(6,*) IC,NSTEP,' Mass source from the ground=',sum + endif + RETURN + END +C + subroutine filcr(q,IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + dimension q(IMR,*),cosp(*),acosp(*) + icr = 0 + do 65 j=j1+1,j2-1 + DO 50 i=1,IMR-1 + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-E + dn = q(i+1,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i+1,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-E + ds = q(i+1,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i+1,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +50 continue + if(icr.eq.0 .and. q(IMR,j).ge.0.) goto 65 + DO 55 i=2,IMR + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-W + dn = q(i-1,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i-1,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-W + ds = q(i-1,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i-1,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +55 continue +C ***************************************** +C i=1 + i=1 + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-W + dn = q(IMR,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(IMR,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-W + ds = q(IMR,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(IMR,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +C ***************************************** +C i=IMR + i=IMR + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-E + dn = q(1,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(1,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-E + ds = q(1,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(1,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +C ***************************************** +65 continue +C + do i=1,IMR + if(q(i,j1).lt.0. .or. q(i,j2).lt.0.) then + icr = 1 + goto 80 + endif + enddo +C +80 continue +C + if(q(1,1).lt.0. .or. q(1,jnp).lt.0.) then + icr = 1 + endif +C + return + end +C + subroutine filns(q,IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + dimension q(IMR,*),cosp(*),acosp(*) +c logical first +c data first /.true./ +c save cap1 +C +c if(first) then + DP = 4.*ATAN(1.)/float(JNP-1) + CAP1 = IMR*(1.-COS((j1-1.5)*DP))/DP +c first = .false. +c endif +C + ipy = 0 + do 55 j=j1+1,j2-1 + DO 55 i=1,IMR + IF(q(i,j).LT.0.) THEN + ipy = 1 + dq = - q(i,j)*cosp(j) +C North + dn = q(i,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C South + ds = q(i,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +55 continue +C + do i=1,imr + IF(q(i,j1).LT.0.) THEN + ipy = 1 + dq = - q(i,j1)*cosp(j1) +C North + dn = q(i,j1+1)*cosp(j1+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i,j1+1) = (dn - d1)*acosp(j1+1) + q(i,j1) = (d1 - dq)*acosp(j1) + tiny + endif + enddo +C + j = j2 + do i=1,imr + IF(q(i,j).LT.0.) THEN + ipy = 1 + dq = - q(i,j)*cosp(j) +C South + ds = q(i,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif + enddo +C +C Check Poles. + if(q(1,1).lt.0.) then + dq = q(1,1)*cap1/float(IMR)*acosp(j1) + do i=1,imr + q(i,1) = 0. + q(i,j1) = q(i,j1) + dq + if(q(i,j1).lt.0.) ipy = 1 + enddo + endif +C + if(q(1,JNP).lt.0.) then + dq = q(1,JNP)*cap1/float(IMR)*acosp(j2) + do i=1,imr + q(i,JNP) = 0. + q(i,j2) = q(i,j2) + dq + if(q(i,j2).lt.0.) ipy = 1 + enddo + endif +C + return + end +C + subroutine filew(q,qtmp,IMR,JNP,j1,j2,ipx,tiny) + dimension q(IMR,*),qtmp(JNP,IMR) +C + ipx = 0 +C Copy & swap direction for vectorization. + do 25 i=1,imr + do 25 j=j1,j2 +25 qtmp(j,i) = q(i,j) +C + do 55 i=2,imr-1 + do 55 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(0.,qtmp(j,i-1)) + d1 = min(-qtmp(j,i),d0) + qtmp(j,i-1) = qtmp(j,i-1) - d1 + qtmp(j,i) = qtmp(j,i) + d1 +c east + d0 = max(0.,qtmp(j,i+1)) + d2 = min(-qtmp(j,i),d0) + qtmp(j,i+1) = qtmp(j,i+1) - d2 + qtmp(j,i) = qtmp(j,i) + d2 + tiny + endif +55 continue +c + i=1 + do 65 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(0.,qtmp(j,imr)) + d1 = min(-qtmp(j,i),d0) + qtmp(j,imr) = qtmp(j,imr) - d1 + qtmp(j,i) = qtmp(j,i) + d1 +c east + d0 = max(0.,qtmp(j,i+1)) + d2 = min(-qtmp(j,i),d0) + qtmp(j,i+1) = qtmp(j,i+1) - d2 +c + qtmp(j,i) = qtmp(j,i) + d2 + tiny + endif +65 continue + i=IMR + do 75 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(0.,qtmp(j,i-1)) + d1 = min(-qtmp(j,i),d0) + qtmp(j,i-1) = qtmp(j,i-1) - d1 + qtmp(j,i) = qtmp(j,i) + d1 +c east + d0 = max(0.,qtmp(j,1)) + d2 = min(-qtmp(j,i),d0) + qtmp(j,1) = qtmp(j,1) - d2 +c + qtmp(j,i) = qtmp(j,i) + d2 + tiny + endif +75 continue +C + if(ipx.ne.0) then + do 85 j=j1,j2 + do 85 i=1,imr +85 q(i,j) = qtmp(j,i) + else +C +C Poles. + if(q(1,1).lt.0. or. q(1,JNP).lt.0.) ipx = 1 + endif + return + end +C + subroutine zflip(q,im,km,nc) +C This routine flip the array q (in the vertical). + real q(im,km,nc) +C local dynamic array + real qtmp(im,km) +C + do 4000 IC = 1, nc +C + do 1000 k=1,km + do 1000 i=1,im + qtmp(i,k) = q(i,km+1-k,IC) +1000 continue +C + do 2000 i=1,im*km +2000 q(i,1,IC) = qtmp(i,1) +4000 continue + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/prather.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/prather.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/prather.F (revision 1280) @@ -0,0 +1,359 @@ +! +! $Header$ +! + SUBROUTINE prather (q,w,masse,pbaru,pbarv,nt,dt) + IMPLICIT NONE + +c======================================================================= +c Adaptation LMDZ: A.Armengaud (LGGE) +c ---------------- +c +c ************************************************ +c Transport des traceurs par la methode de prather +c Ref : +c +c ************************************************ +c q,w,pext,pbaru et pbarv : arguments d'entree pour le s-pg +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +c Arguments: +c ---------- + INTEGER iq,nt + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ) + REAL masse(iip1,jjp1,llm) + REAL q( iip1,jjp1,llm,0:9) + REAL w( ip1jmp1,llm ) + integer ordre,ilim + +c Local: +c ------ + LOGICAL limit + real zq(iip1,jjp1,llm) + REAL sm ( iip1,jjp1, llm ) + REAL s0( iip1,jjp1,llm ), sx( iip1,jjp1,llm ) + REAL sy( iip1,jjp1,llm ), sz( iip1,jjp1,llm ) + REAL sxx( iip1,jjp1,llm) + REAL sxy( iip1,jjp1,llm) + REAL sxz( iip1,jjp1,llm) + REAL syy( iip1,jjp1,llm ) + REAL syz( iip1,jjp1,llm ) + REAL szz( iip1,jjp1,llm ),zz + INTEGER i,j,l,indice + real sxn(iip1),sxs(iip1) + + real sinlon(iip1),sinlondlon(iip1) + real coslon(iip1),coslondlon(iip1) + real qmin,qmax + save qmin,qmax + save sinlon,coslon,sinlondlon,coslondlon + real dyn1,dyn2,dys1,dys2,qpn,qps,dqzpn,dqzps + real masn,mass +c + REAL SSUM + integer ismax,ismin + EXTERNAL SSUM, ismin,ismax + logical first + save first + + data first/.true./ + data qmin,qmax/-1.e33,1.e33/ + + +c========================================================================== +c========================================================================== +c MODIFICATION POUR PAS DE TEMPS ADAPTATIF, dtvr remplace par dt +c========================================================================== +c========================================================================== + REAL dt +c========================================================================== + limit = .TRUE. + + if(first) then + print*,'SCHEMA PRATHER' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + enddo + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + q( i,j,l,1 )=0. + q( i,j,l,2)=0. + q( i,j,l,3)=0. + q( i,j,l,4)=0. + q( i,j,l,5)=0. + q( i,j,l,6)=0. + q( i,j,l,7)=0. + q( i,j,l,8)=0. + q( i,j,l,9)=0. + ENDDO + ENDDO + ENDDO + endif +c Fin modif Fred + +c *** On calcule la masse d'air en kg + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + sm( i,j,llm+1-l ) =masse(i,j,l) + ENDDO + ENDDO + ENDDO + +c *** q contient les qqtes de traceur avant l'advection + +c *** Affectation des tableaux S a partir de Q + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + s0( i,j,l) = q ( i,j,llm+1-l,0 )*sm(i,j,l) + sx( i,j,l) = q( i,j,llm+1-l,1 )*sm(i,j,l) + sy( i,j,l) = q( i,j,llm+1-l,2)*sm(i,j,l) + sz( i,j,l) = q( i,j,llm+1-l,3)*sm(i,j,l) + sxx( i,j,l) = q( i,j,llm+1-l,4)*sm(i,j,l) + sxy( i,j,l) = q( i,j,llm+1-l,5)*sm(i,j,l) + sxz( i,j,l) = q( i,j,llm+1-l,6)*sm(i,j,l) + syy( i,j,l) = q( i,j,llm+1-l,7)*sm(i,j,l) + syz( i,j,l) = q( i,j,llm+1-l,8)*sm(i,j,l) + szz( i,j,l) = q( i,j,llm+1-l,9)*sm(i,j,l) + ENDDO + ENDDO + ENDDO +c *** Appel des subroutines d'advection en X, en Y et en Z +c *** Advection avec "time-splitting" + +c----------------------------------------------------------- + do indice =1,nt + call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) + end do + do l=1,llm + do i=1,iip1 + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo +c--------------------------------------------------------- + call advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) +c--------------------------------------------------------- + +c--------------------------------------------------------- + do j=1,jjp1 + do i=1,iip1 + sz(i,j,1)=0. + sz(i,j,llm)=0. + sxz(i,j,1)=0. + sxz(i,j,llm)=0. + syz(i,j,1)=0. + syz(i,j,llm)=0. + szz(i,j,1)=0. + szz(i,j,llm)=0. + enddo + enddo + call advzp( limit,dt*nt,w,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) + do l=1,llm + do i=1,iip1 + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + +c--------------------------------------------------------- + +c--------------------------------------------------------- + call advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) +c--------------------------------------------------------- + DO l = 1,llm + DO j = 1,jjp1 + s0( iip1,j,l)=s0( 1,j,l ) + sx( iip1,j,l)=sx( 1,j,l ) + sy( iip1,j,l)=sy( 1,j,l ) + sz( iip1,j,l)=sz( 1,j,l ) + sxx( iip1,j,l)=sxx( 1,j,l ) + sxy( iip1,j,l)=sxy( 1,j,l) + sxz( iip1,j,l)=sxz( 1,j,l ) + syy( iip1,j,l)=syy( 1,j,l ) + syz( iip1,j,l)=syz( 1,j,l) + szz( iip1,j,l)=szz( 1,j,l ) + ENDDO + ENDDO + do indice=1,nt + call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) + end do +c--------------------------------------------------------- +c--------------------------------------------------------- +c *** On repasse les S dans la variable qpr +c *** On repasse les S dans la variable q directement 14/10/94 + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + q( i,j,llm+1-l,0 )=s0( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,1 ) = sx( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,2 ) = sy( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,3 ) = sz( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,4 ) = sxx( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,5 ) = sxy( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,6 ) = sxz( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,7 ) = syy( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,8 ) = syz( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,9 ) = szz( i,j,l )/sm(i,j,l) + ENDDO + ENDDO + ENDDO + +c--------------------------------------------------------- +c go to 777 +c filtrages aux poles + +c Traitements specifiques au pole + +c filtrages aux poles + DO l=1,llm +c filtrages aux poles + masn=ssum(iim,sm(1,1,l),1) + mass=ssum(iim,sm(1,jjp1,l),1) + qpn=ssum(iim,s0(1,1,l),1)/masn + qps=ssum(iim,s0(1,jjp1,l),1)/mass + dqzpn=ssum(iim,sz(1,1,l),1)/masn + dqzps=ssum(iim,sz(1,jjp1,l),1)/mass + do i=1,iip1 + q( i,1,llm+1-l,3)=dqzpn + q( i,jjp1,llm+1-l,3)=dqzps + q( i,1,llm+1-l,0)=qpn + q( i,jjp1,llm+1-l,0)=qps + enddo +c enddo +c print*,'qpn',qpn,'qps',qps +c print*,'dqzpn',dqzpn,'dqzps',dqzps +c enddo + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + do i=1,iim + zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0) + dyn1=dyn1+sinlondlon(i)*zz + dyn2=dyn2+coslondlon(i)*zz + zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l) + dys1=dys1+sinlondlon(i)*zz + dys2=dys2+coslondlon(i)*zz + enddo + do i=1,iim + q(i,1,llm+1-l,2)= + $ (sinlon(i)*dyn1+coslon(i)*dyn2)/2. + q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0) + $ +q(i,1,llm+1-l,2) + q(i,jjp1,llm+1-l,2)= + $ (sinlon(i)*dys1+coslon(i)*dys2)/2. + q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) + $ -q(i,jjp1,llm+1-l,2) + enddo + q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0) + q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0) + do i=1,iim + sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0) + sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0) + enddo + sxn(iip1)=sxn(1) + sxs(iip1)=sxs(1) + do i=1,iim + q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1)) + q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1)) + END DO + q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1) + q(1,jjp1,llm+1-l,1)= + $ q(iip1,jjp1,llm+1-l,1) + enddo + do l=1,llm + do i=1,iim + q( i,1,llm+1-l,4)=0. + q( i,jjp1,llm+1-l,4)=0. + q( i,1,llm+1-l,5)=0. + q( i,jjp1,llm+1-l,5)=0. + q( i,1,llm+1-l,6)=0. + q( i,jjp1,llm+1-l,6)=0. + q( i,1,llm+1-l,7)=0. + q( i,jjp1,llm+1-l,7)=0. + q( i,1,llm+1-l,8)=0. + q( i,jjp1,llm+1-l,8)=0. + q( i,1,llm+1-l,9)=0. + q( i,jjp1,llm+1-l,9)=0. + enddo + ENDDO + +777 continue +c +c bouclage en longitude + do l=1,llm + do j=1,jjp1 + q(iip1,j,l,0)=q(1,j,l,0) + q(iip1,j,llm+1-l,0)=q(1,j,llm+1-l,0) + q(iip1,j,llm+1-l,1)=q(1,j,llm+1-l,1) + q(iip1,j,llm+1-l,2)=q(1,j,llm+1-l,2) + q(iip1,j,llm+1-l,3)=q(1,j,llm+1-l,3) + q(iip1,j,llm+1-l,4)=q(1,j,llm+1-l,4) + q(iip1,j,llm+1-l,5)=q(1,j,llm+1-l,5) + q(iip1,j,llm+1-l,6)=q(1,j,llm+1-l,6) + q(iip1,j,llm+1-l,7)=q(1,j,llm+1-l,7) + q(iip1,j,llm+1-l,8)=q(1,j,llm+1-l,8) + q(iip1,j,llm+1-l,9)=q(1,j,llm+1-l,9) + enddo + enddo + DO l = 1,llm + DO j = 2,jjm + DO i = 1,iip1 + IF (q(i,j,l,0).lt.0.) THEN + PRINT*,'------------ BIP-----------' + PRINT*,'S0(',i,j,l,')=',q(i,j,l,0), + $ q(i,j-1,l,0) + PRINT*,'SX(',i,j,l,')=',q(i,j,l,1) + PRINT*,'SY(',i,j,l,')=',q(i,j,l,2), + $ q(i,j-1,l,2) + PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3) +c PRINT*,' PBL EN SORTIE D'' ADVZP' + q(i,j,l,0)=0. +c STOP + ENDIF + ENDDO + ENDDO + do j=1,jjp1,jjm + do i=1,iip1 + IF (q(i,j,l,0).lt.0.) THEN + PRINT*,'------------ BIP 2-----------' + PRINT*,'S0(',i,j,l,')=',q(i,j,l,0) + PRINT*,'SX(',i,j,l,')=',q(i,j,l,1) + PRINT*,'SY(',i,j,l,')=',q(i,j,l,2) + PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3) + + q(i,j,l,0)=0. +c STOP + ENDIF + enddo + enddo + ENDDO + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/pres2lev.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/pres2lev.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/pres2lev.F90 (revision 1280) @@ -0,0 +1,74 @@ +! $Id: pres2lev.F 1179 2009-06-11 14:18:47Z jghattas $ +! +!****************************************************** +SUBROUTINE pres2lev(varo,varn,lmo,lmn,po,pn,ni,nj,ok_invertp) +! +! interpolation lineaire pour passer +! a une nouvelle discretisation verticale pour +! les variables de GCM +! Francois Forget (01/1995) +! MOdif remy roca 12/97 pour passer de pres2sig +! Modif F.Codron 07/08 po en 3D +!********************************************************** + + IMPLICIT NONE + +! Declarations: +! ============== +! +! ARGUMENTS +! """"""""" + LOGICAL, INTENT(IN) :: ok_invertp + INTEGER, INTENT(IN) :: lmo ! dimensions ancienne couches + INTEGER, INTENT(IN) :: lmn ! dimensions nouvelle couches + + REAL, INTENT(IN) :: po(ni*nj,lmo) ! niveau de pression ancienne grille + REAL, INTENT(IN) :: pn(ni*nj,lmn) ! niveau de pression nouvelle grille + + INTEGER, INTENT(IN) :: ni,nj ! nombre de point horizontal + + REAL, INTENT(IN) :: varo(ni*nj,lmo) ! var dans l'ancienne grille + REAL, INTENT(OUT) :: varn(ni*nj,lmn) ! var dans la nouvelle grille + + REAL :: zvaro(ni*nj,lmo),zpo(ni*nj,lmn) + +! Autres variables +! """""""""""""""" + INTEGER :: ln ,lo, k + REAL :: coef + + +! Inversion de l'ordre des niveaux verticaux + IF (ok_invertp) THEN + DO lo=1,lmo + DO k=1,ni*nj + zpo(k,lo)=po(k,lmo+1-lo) + zvaro(k,lo)=varo(k,lmo+1-lo) + ENDDO + ENDDO + ELSE + DO lo=1,lmo + DO k=1,ni*nj + zpo(k,lo)=po(k,lo) + zvaro(k,lo)=varo(k,lo) + ENDDO + ENDDO + ENDIF + + DO ln=1,lmn + DO lo=1,lmo-1 + DO k=1,ni*nj + IF (pn(k,ln) >= zpo(k,1) ) THEN + varn(k,ln) = varo(k,1) + ELSE IF (pn(k,ln) <= zpo(k,lmo)) THEN + varn(k,ln) = zvaro(k,lmo) + ELSE IF ( pn(k,ln) <= zpo(k,lo) .AND. pn(k,ln) > zpo(k,lo+1) ) THEN + coef = (pn(k,ln)-zpo(k,lo)) / (zpo(k,lo+1)-zpo(k,lo)) + varn(k,ln) = zvaro(k,lo) + coef*(zvaro(k,lo+1)-zvaro(k,lo)) + ENDIF + + ENDDO + ENDDO + ENDDO + +END SUBROUTINE pres2lev Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/pression.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/pression.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/pression.F (revision 1280) @@ -0,0 +1,32 @@ +! +! $Header$ +! + SUBROUTINE pression( ngrid, ap, bp, ps, p ) +c + +c Auteurs : P. Le Van , Fr.Hourdin . + +c ************************************************************************ +c Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du +c sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) +c couches , avec p(ij,llm +1) = 0. et p(ij,1) = ps(ij) . +c ************************************************************************ +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +c + INTEGER ngrid + INTEGER l,ij + + REAL ap( llmp1 ), bp( llmp1 ), ps( ngrid ), p( ngrid,llmp1 ) + + DO l = 1, llmp1 + DO ij = 1, ngrid + p(ij,l) = ap(l) + bp(l) * ps(ij) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/pression_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/pression_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/pression_p.F (revision 1280) @@ -0,0 +1,40 @@ + SUBROUTINE pression_p( ngrid, ap, bp, ps, p ) + USE parallel +c + +c Auteurs : P. Le Van , Fr.Hourdin . + +c ************************************************************************ +c Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du +c sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) +c couches , avec p(ij,llm +1) = 0. et p(ij,1) = ps(ij) . +c ************************************************************************ +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +c + INTEGER ngrid + INTEGER l,ij + + REAL ap( llmp1 ), bp( llmp1 ), ps( ngrid ), p( ngrid,llmp1 ) + + INTEGER ijb,ije + + + ijb=ij_begin-iip1 + ije=ij_end+2*iip1 + + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llmp1 + DO ij = ijb, ije + p(ij,l) = ap(l) + bp(l) * ps(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/profvert.def =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/profvert.def (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/profvert.def (revision 1280) @@ -0,0 +1,23 @@ +! +! $Header$ +! +nom_courbes=F +titre=/home/hourdin/LMDZ4/libf/dyn3d +xinf=0. +xsup=669. +yinf=6.5 +ysup=10.5 +axtxtx=sols +axtxty=pressure (mb) +pathcham=. +lstyles=1 9999 +linewidth=.2 +lcolors=1 9999 +frwidth=.5 +repery0=T +txtheight=2.5 +freecoord=/d2/hourdin/Ames/saison.def + +determination du champ physique +xlength=195. +ylength=105. Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/psextbar.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/psextbar.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/psextbar.F (revision 1280) @@ -0,0 +1,107 @@ +! +! $Header$ +! + SUBROUTINE psextbar ( ps, psexbarxy ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************** +c calcul des moyennes en x et en y de (pression au sol*aire variable) .. +c ********************************************************************** +c +c ps est un argum. d'entree pour le s-pg .. +c psexbarxy est un argum. de sortie pour le s-pg .. +c +c Methode: +c -------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c +c On a : +c +c pbarx(i,j) = Pext(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c pbary(i,j) = Pext(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) + +c Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1) +c localise au point ... Z (i,j) ... +c +c +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL ps( ip1jmp1 ), psexbarxy ( ip1jm ), pext( ip1jmp1 ) + + INTEGER l, ij +c + + DO ij = 1, ip1jmp1 + pext(ij) = ps(ij) * aire(ij) + ENDDO + + + DO 5 ij = 1, ip1jm - 1 + psexbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) + + * pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2) + 5 CONTINUE + + +c .... correction pour psexbarxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = iip1, ip1jm, iip1 + psexbarxy( ij ) = psexbarxy( ij - iim ) + 7 CONTINUE + + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/q_sat.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/q_sat.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/q_sat.F (revision 1280) @@ -0,0 +1,72 @@ +! +! $Header$ +! +c +c + + subroutine q_sat(np,temp,pres,qsat) +c + IMPLICIT none +c====================================================================== +c Autheur(s): Z.X. Li (LMD/CNRS) +c reecriture vectorisee par F. Hourdin. +c Objet: calculer la vapeur d'eau saturante (formule Centre Euro.) +c====================================================================== +c Arguments: +c kelvin---input-R: temperature en Kelvin +c millibar--input-R: pression en mb +c +c q_sat----output-R: vapeur d'eau saturante en kg/kg +c====================================================================== +c + integer np + REAL temp(np),pres(np),qsat(np) +c + REAL r2es + PARAMETER (r2es=611.14 *18.0153/28.9644) +c + REAL r3les, r3ies, r3es + PARAMETER (R3LES=17.269) + PARAMETER (R3IES=21.875) +c + REAL r4les, r4ies, r4es + PARAMETER (R4LES=35.86) + PARAMETER (R4IES=7.66) +c + REAL rtt + PARAMETER (rtt=273.16) +c + REAL retv + PARAMETER (retv=28.9644/18.0153 - 1.0) + + real zqsat + integer ip +c +C ------------------------------------------------------------------ +c +c + + do ip=1,np + +c write(*,*)'kelvin,millibar=',kelvin,millibar +c write(*,*)'temp,pres=',temp(ip),pres(ip) +c + IF (temp(ip) .LE. rtt) THEN + r3es = r3ies + r4es = r4ies + ELSE + r3es = r3les + r4es = r4les + ENDIF +c + zqsat=r2es/pres(ip)*EXP(r3es*(temp(ip)-rtt)/(temp(ip)-r4es)) + zqsat=MIN(0.5,ZQSAT) + zqsat=zqsat/(1.-retv *zqsat) +c + qsat(ip)= zqsat +c write(*,*)'qsat=',qsat(ip) + + enddo +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/qminimum_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/qminimum_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/qminimum_p.F (revision 1280) @@ -0,0 +1,107 @@ + SUBROUTINE qminimum_p( q,nq,deltap ) + USE parallel + IMPLICIT none +c +c -- Objet : Traiter les valeurs trop petites (meme negatives) +c pour l'eau vapeur et l'eau liquide +c +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +c + INTEGER nq + REAL q(ip1jmp1,llm,nq), deltap(ip1jmp1,llm) +c + INTEGER iq_vap, iq_liq + PARAMETER ( iq_vap = 1 ) ! indice pour l'eau vapeur + PARAMETER ( iq_liq = 2 ) ! indice pour l'eau liquide + REAL seuil_vap, seuil_liq + PARAMETER ( seuil_vap = 1.0e-10 ) ! seuil pour l'eau vapeur + PARAMETER ( seuil_liq = 1.0e-11 ) ! seuil pour l'eau liquide +c +c NB. ....( Il est souhaitable mais non obligatoire que les valeurs des +c parametres seuil_vap, seuil_liq soient pareilles a celles +c qui sont utilisees dans la routine ADDFI ) +c ................................................................. +c + INTEGER i, k, iq + REAL zx_defau, zx_abc, zx_pump(ip1jmp1), pompe +c + REAL SSUM + EXTERNAL SSUM +c + INTEGER imprim + SAVE imprim + DATA imprim /0/ +c$OMP THREADPRIVATE(imprim) + INTEGER ijb,ije + INTEGER Index_pump(ip1jmp1) + INTEGER nb_pump +c +c Quand l'eau liquide est trop petite (ou negative), on prend +c l'eau vapeur de la meme couche et la convertit en eau liquide +c (sans changer la temperature !) +c + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 1000 k = 1, llm + DO 1040 i = ijb, ije + if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then + q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq + q(i,k,iq_liq) = seuil_liq + endif + 1040 CONTINUE + 1000 CONTINUE +c$OMP END DO NOWAIT +c$OMP BARRIER +c ---> SYNCHRO OPENMP ICI + +c +c Quand l'eau vapeur est trop faible (ou negative), on complete +c le defaut en prennant de l'eau vapeur de la couche au-dessous. +c + iq = iq_vap +c + DO k = llm, 2, -1 +ccc zx_abc = dpres(k) / dpres(k-1) +c$OMP DO SCHEDULE(STATIC) + DO i = ijb, ije + if ( seuil_vap - q(i,k,iq) .gt. 0.d0 ) then + q(i,k-1,iq) = q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) * + & deltap(i,k) / deltap(i,k-1) + q(i,k,iq) = seuil_vap + endif + ENDDO +c$OMP END DO NOWAIT + ENDDO +c$OMP BARRIER +c +c Quand il s'agit de la premiere couche au-dessus du sol, on +c doit imprimer un message d'avertissement (saturation possible). +c + nb_pump=0 +c$OMP DO SCHEDULE(STATIC) + DO i = ijb, ije + zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq) ) + q(i,1,iq) = AMAX1( q(i,1,iq), seuil_vap ) + IF (zx_pump(i) > 0.0) THEN + nb_pump = nb_pump+1 + Index_pump(nb_pump)=i + ENDIF + ENDDO +c$OMP END DO +! pompe = SSUM(ije-ijb+1,zx_pump(ijb),1) + + IF (imprim.LE.100 .AND. nb_pump .GT. 0 ) THEN + PRINT *, 'ATT!:on pompe de l eau au sol' + DO i = 1, nb_pump + imprim = imprim + 1 + PRINT*,' en ',index_pump(i),zx_pump(index_pump(i)) + ENDDO + ENDIF +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ran1.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ran1.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ran1.F (revision 1280) @@ -0,0 +1,34 @@ +! +! $Header$ +! + FUNCTION RAN1(IDUM) + DIMENSION R(97) + save r + save iff,ix1,ix2,ix3 + PARAMETER (M1=259200,IA1=7141,IC1=54773,RM1=3.8580247E-6) + PARAMETER (M2=134456,IA2=8121,IC2=28411,RM2=7.4373773E-6) + PARAMETER (M3=243000,IA3=4561,IC3=51349) + DATA IFF /0/ + IF (IDUM.LT.0.OR.IFF.EQ.0) THEN + IFF=1 + IX1=MOD(IC1-IDUM,M1) + IX1=MOD(IA1*IX1+IC1,M1) + IX2=MOD(IX1,M2) + IX1=MOD(IA1*IX1+IC1,M1) + IX3=MOD(IX1,M3) + DO 11 J=1,97 + IX1=MOD(IA1*IX1+IC1,M1) + IX2=MOD(IA2*IX2+IC2,M2) + R(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1 +11 CONTINUE + IDUM=1 + ENDIF + IX1=MOD(IA1*IX1+IC1,M1) + IX2=MOD(IA2*IX2+IC2,M2) + IX3=MOD(IA3*IX3+IC3,M3) + J=1+(97*IX3)/M3 + IF(J.GT.97.OR.J.LT.1)PAUSE + RAN1=R(J) + R(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1 + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotat.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotat.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotat.F (revision 1280) @@ -0,0 +1,58 @@ +! +! $Header$ +! + SUBROUTINE rotat (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. calcule le rotationnel +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij +c +c + DO 10 l = 1,klevel +c + DO ij = 1, ip1jm - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE + +ccc CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) + + DO l = 1, klevel + DO ij = 1, ip1jm + rot(ij,l) = rot(ij,l) * unsairez(ij) + ENDDO + ENDDO +c +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotat_nfil.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotat_nfil.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotat_nfil.F (revision 1280) @@ -0,0 +1,49 @@ +! +! $Header$ +! + SUBROUTINE rotat_nfil (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. Calcule le rotationnel non filtre , +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij +c +c + DO 10 l = 1,klevel +c + DO ij = 1, ip1jm - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotat_nfil_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotat_nfil_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotat_nfil_p.F (revision 1280) @@ -0,0 +1,52 @@ + SUBROUTINE rotat_nfil_p (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. Calcule le rotationnel non filtre , +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij + INTEGER :: ijb,ije +c +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = ijb+iip1-1, ije, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotat_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotat_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotat_p.F (revision 1280) @@ -0,0 +1,63 @@ + SUBROUTINE rotat_p (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. calcule le rotationnel +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij + INTEGER :: ijb,ije +c +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = ijb+iip1-1, ije, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE +c$OMP END DO NOWAIT +ccc CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + rot(ij,l) = rot(ij,l) * unsairez(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotatf.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotatf.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotatf.F (revision 1280) @@ -0,0 +1,58 @@ +! +! $Header$ +! + SUBROUTINE rotatf (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. calcule le rotationnel +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij +c +c + DO 10 l = 1,klevel +c + DO ij = 1, ip1jm - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE + + CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) + + DO l = 1, klevel + DO ij = 1, ip1jm + rot(ij,l) = rot(ij,l) * unsairez(ij) + ENDDO + ENDDO +c +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotatf_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotatf_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotatf_p.F (revision 1280) @@ -0,0 +1,67 @@ + SUBROUTINE rotatf_p (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. calcule le rotationnel +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij + INTEGER :: ijb,ije,jjb,jje +c +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = ijb+iip1-1, ije, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE +c$OMP END DO NOWAIT + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + CALL filtreg_p( rot, jjb,jje,jjm, klevel, 2, 2, .FALSE., 1 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + rot(ij,l) = rot(ij,l) * unsairez(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotatst.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotatst.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/rotatst.F (revision 1280) @@ -0,0 +1,43 @@ +! +! $Header$ +! + SUBROUTINE rotatst (klevel,x, y, rot ) +c +c P. Le Van +c +c ***************************************************************** +c .. calcule le rotationnel a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ..... +c ***************************************************************** +c x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c + INTEGER klevel +#include "dimensions.h" +#include "paramet.h" + + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) + INTEGER l, ij +c +c + DO 5 l = 1,klevel +c + DO 1 ij = 1, ip1jm - 1 + rot( ij,l ) = ( y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) ) + 1 CONTINUE +c +c .... correction pour rot( iip1,j,l) .... +c +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO 2 ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + 2 CONTINUE +c + 5 CONTINUE + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/serre.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/serre.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/serre.h (revision 1280) @@ -0,0 +1,11 @@ +! +! $Header$ +! +!c +!c +!c..include serre.h +!c + REAL clon,clat,transx,transy,alphax,alphay,pxo,pyo, & + & grossismx, grossismy, dzoomx, dzoomy,taux,tauy + COMMON/serre/clon,clat,transx,transy,alphax,alphay,pxo,pyo , & + & grossismx, grossismy, dzoomx, dzoomy,taux,tauy Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/sort.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/sort.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/sort.F (revision 1280) @@ -0,0 +1,37 @@ +! +! $Header$ +! +C +C + SUBROUTINE sort(n,d) +c +c P.Le Van +c +c... cette routine met le tableau d dans l'ordre croissant .... +cc ( pour avoir l'ordre decroissant,il suffit de remplacer l'instruc +c tion situee + bas IF(d(j).LE.p) THEN par +c IF(d(j).GE.p) THEN +c + + INTEGER n + REAL d(n) , p + INTEGER i,j,k + + DO i=1,n-1 + k=i + p=d(i) + DO j=i+1,n + IF(d(j).LE.p) THEN + k=j + p=d(j) + ENDIF + ENDDO + + IF(k.ne.i) THEN + d(k)=d(i) + d(i)=p + ENDIF + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/sortvarc.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/sortvarc.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/sortvarc.F (revision 1280) @@ -0,0 +1,166 @@ +! +! $Header$ +! + SUBROUTINE sortvarc + $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time , + $ vcov ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c sortie des variables de controle +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "ener.h" +#include "logic.h" +#include "temps.h" + +c Arguments: +c ---------- + + INTEGER itau + REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL vcov(ip1jm,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL vorpot(ip1jm,llm) + REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm) + REAL dp(ip1jmp1) + REAL time + REAL pk(ip1jmp1,llm) + +c Local: +c ------ + + REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm) + REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1) + REAL cosphi(ip1jm),omegcosp(ip1jm) + REAL dtvrs1j,rjour,heure,radsg,radomeg + REAL rday, massebxy(ip1jm,llm) + INTEGER l, ij, imjmp1 + + REAL SSUM + +c----------------------------------------------------------------------- + + dtvrs1j = dtvr/daysec + rjour = FLOAT( INT( itau * dtvrs1j )) + heure = ( itau*dtvrs1j-rjour ) * 24. + imjmp1 = iim * jjp1 + IF(ABS(heure - 24.).LE.0.0001 ) heure = 0. +c + CALL massbarxy ( masse, massebxy ) + +c ..... Calcul de rmsdpdt ..... + + ge(:)=dp(:)*dp(:) + + rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) +c + rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) + + CALL SCOPY( ijp1llm,bern,1,bernf,1 ) + CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1) + +c ..... Calcul du moment angulaire ..... + + radsg = rad /g + radomeg = rad * omeg +c + DO ij=iip2,ip1jm + cosphi( ij ) = COS(rlatu((ij-1)/iip1+1)) + omegcosp(ij) = radomeg * cosphi(ij) + ENDDO + +c ... Calcul de l'energie,de l'enstrophie,de l'entropie et de rmsv . + + DO l=1,llm + DO ij = 1,ip1jm + vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l) + ENDDO + ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1)) + + DO ij = 1,ip1jmp1 + ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l) + + s bernf(ij,l)-phi(ij,l)) + ENDDO + etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij = 1, ip1jmp1 + ge(ij) = masse(ij,l)*teta(ij,l) + ENDDO + stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij=1,ip1jmp1 + ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.) + ENDDO + rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)) + + DO ij =iip2,ip1jm + ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) * + * cosphi(ij) + ENDDO + angl(l) = radsg * + s (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1)) + ENDDO + + DO ij=1,ip1jmp1 + ge(ij)= ps(ij)*aire(ij) + ENDDO + ptot = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1) + etot = SSUM( llm, etotl, 1 ) + ztot = SSUM( llm, ztotl, 1 ) + stot = SSUM( llm, stotl, 1 ) + rmsv = SSUM( llm, rmsvl, 1 ) + ang = SSUM( llm, angl, 1 ) + +c rday = FLOAT(INT ( day_ini + time )) +c + rday = FLOAT(INT(time-jD_ref-jH_ref)) + IF(ptot0.eq.0.) THEN + PRINT 3500, itau, rday, heure,time + PRINT*,'WARNING!!! On recalcule les valeurs initiales de :' + PRINT*,'ptot,rmsdpdt,etot,ztot,stot,rmsv,ang' + PRINT *, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang + etot0 = etot + ptot0 = ptot + ztot0 = ztot + stot0 = stot + ang0 = ang + END IF + + etot= etot/etot0 + rmsv= SQRT(rmsv/ptot) + ptot= ptot/ptot0 + ztot= ztot/ztot0 + stot= stot/stot0 + ang = ang /ang0 + + + PRINT 3500, itau, rday, heure, time + PRINT 4000, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang + + RETURN + +3500 FORMAT(10("*"),4x,'pas',i7,5x,'jour',f9.0,'heure',f5.1,4x + * ,'date',f14.4,4x,10("*")) +4000 FORMAT(10x,'masse',4x,'rmsdpdt',7x,'energie',2x,'enstrophie' + * ,2x,'entropie',3x,'rmsv',4x,'mt.ang',/,'GLOB ' + . ,f10.6,e13.6,5f10.3/ + * ) + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/sortvarc0.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/sortvarc0.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/sortvarc0.F (revision 1280) @@ -0,0 +1,141 @@ +! +! $Header$ +! + SUBROUTINE sortvarc0 + $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time , + $ vcov) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c sortie des variables de controle +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "ener.h" +#include "logic.h" +#include "temps.h" + +c Arguments: +c ---------- + + INTEGER itau + REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL vcov(ip1jm,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL vorpot(ip1jm,llm) + REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm) + REAL dp(ip1jmp1) + REAL time + REAL pk(ip1jmp1,llm) + +c Local: +c ------ + + REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm) + REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1) + REAL cosphi(ip1jm),omegcosp(ip1jm) + REAL dtvrs1j,rjour,heure,radsg,radomeg + REAL rday, massebxy(ip1jm,llm) + INTEGER l, ij, imjmp1 + + REAL SSUM + integer ismin,ismax + +c----------------------------------------------------------------------- + + dtvrs1j = dtvr/daysec + rjour = FLOAT( INT( itau * dtvrs1j )) + heure = ( itau*dtvrs1j-rjour ) * 24. + imjmp1 = iim * jjp1 + IF(ABS(heure - 24.).LE.0.0001 ) heure = 0. +c + CALL massbarxy ( masse, massebxy ) + +c ..... Calcul de rmsdpdt ..... + + ge=dp*dp + + rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) +c + rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) + + CALL SCOPY( ijp1llm,bern,1,bernf,1 ) + CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1) + +c ..... Calcul du moment angulaire ..... + + radsg = rad /g + radomeg = rad * omeg +c + DO ij=iip2,ip1jm + cosphi( ij ) = COS(rlatu((ij-1)/iip1+1)) + omegcosp(ij) = radomeg * cosphi(ij) + ENDDO + +c ... Calcul de l'energie,de l'enstrophie,de l'entropie et de rmsv . + + DO l=1,llm + DO ij = 1,ip1jm + vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l) + ENDDO + ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1)) + + DO ij = 1,ip1jmp1 + ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l) + + s bernf(ij,l)-phi(ij,l)) + ENDDO + etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij = 1, ip1jmp1 + ge(ij) = masse(ij,l)*teta(ij,l) + ENDDO + stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij=1,ip1jmp1 + ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.) + ENDDO + rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)) + + DO ij =iip2,ip1jm + ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) * + * cosphi(ij) + ENDDO + angl(l) = radsg * + s (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1)) + ENDDO + + DO ij=1,ip1jmp1 + ge(ij)= ps(ij)*aire(ij) + ENDDO + ptot0 = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1) + etot0 = SSUM( llm, etotl, 1 ) + ztot0 = SSUM( llm, ztotl, 1 ) + stot0 = SSUM( llm, stotl, 1 ) + rmsv = SSUM( llm, rmsvl, 1 ) + ang0 = SSUM( llm, angl, 1 ) + + rday = FLOAT(INT (time )) +c + PRINT 3500, itau, rday, heure, time + PRINT *, ptot0,etot0,ztot0,stot0,ang0 + +3500 FORMAT(10("*"),4x,'pas',i7,5x,'jour',f5.0,'heure',f5.1,4x + * ,'date',f10.5,4x,10("*")) + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/spline.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/spline.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/spline.F (revision 1280) @@ -0,0 +1,79 @@ +! +! $Header$ +! + subroutine spline(x,y,n,yp1,ypn,y2) + +c + +c Routine to set up the interpolating function for a cubic spline + +c interpolation (see "Numerical Recipes" for details). + +c + implicit real (a-h,o-z) + implicit integer (i-n) + + parameter(nllm=4096) + + dimension x(n),y(n),y2(n),u(nllm) + +c +c write(6,*)(x(i),i=1,n) +c write(6,*)(y(i),i=1,n) + + if(yp1.gt.0.99E30) then +c the lower boundary condition is set + y2(1)=0. +c either to be "natural" + u(1)=0. + + else +c or else to have a specified first + y2(1)=-0.5 +c derivative + u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) + + end if + + do 11 i=2,n-1 +c decomposition loop of the tridiagonal + sig=(x(i)-x(i-1))/(x(i+1)-x(i-1)) +c algorithm. Y2 and U are used + p=sig*y2(i-1)+2. +c for temporary storage of the decompo- + y2(i)=(sig-1.)/p +c sed factors + u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) + + . /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p + + 11 continue + + if(ypn.gt.0.99E30) then +c the upper boundary condition is set + qn=0. +c either to be "natural" + un=0. + + else +c or else to have a specified first + qn=0.5 +c derivative + un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1))) + + end if + + y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.) + + do 12 k=n-1,1,-1 +c this is the backsubstitution loop of + y2(k)=y2(k)*y2(k+1)+u(k) +c the tridiagonal algorithm + 12 continue + +c + + return + + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/splint.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/splint.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/splint.F (revision 1280) @@ -0,0 +1,56 @@ +! +! $Header$ +! + + SUBROUTINE splint(xa,ya,y2a,n,x,y) + +c +c Routine to compute a cubic-spline interpolated value Y given the +c value of X, the arrays XA, YA and the 2nd derivative array Y2A +c computed by SUBROUTINE SPLINE. See "Numerical Recipes" for details +c + + IMPLICIT REAL (a-h,o-z) + IMPLICIT INTEGER (i-n) + DIMENSION xa(n),ya(n),y2a(n) + + kl0=1 + + khi=n +c means of bisection + 1 IF(khi-kl0.gt.1) THEN + + k=(khi+kl0)/2 + + IF(xa(k).gt.x) THEN + + khi=k + + ELSE + + kl0=k + + END IF + + GO TO 1 + + END IF +c KL0 and KHI now bracket the X + h=xa(khi)-xa(kl0) + + IF(h.eq.0.0) STOP + a=(xa(khi)-x)/h +c evaluation of cubic spline polynomial + b=(x-xa(kl0))/h + + y=a*ya(kl0)+b*ya(khi)+((a**3-a)*y2a(kl0)+(b**3-b)*y2a(khi))*(h**2) + + ./6. + +c + + RETURN + + END + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/startvar.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/startvar.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/startvar.F (revision 1280) @@ -0,0 +1,1193 @@ +! +! $Id$ +! + MODULE startvar +#ifdef CPP_EARTH +! This module is designed to work for Earth (and with ioipsl) + ! + ! + ! There are three ways to access data from the database of atmospheric data which + ! can be used to initialize the model. This depends on the type of field which needs + ! to be extracted. In any case the call should come after a restget and should be of the type : + ! CALL startget(...) + ! + ! We will details the possible arguments to startget here : + ! + ! - A 2D variable on the dynamical grid : + ! CALL startget(varname, iml, jml, lon_in, lat_in, champ, val_ex, jml2, lon_in2, lat_in2, interbar ) + ! + ! - A 1D variable on the physical grid : + ! CALL startget(varname, iml, jml, lon_in, lat_in, nbindex, champ, val_exp, jml2, lon_in2, lat_in2, interbar ) + ! + ! + ! - A 3D variable on the dynamical grid : + ! CALL startget(varname, iml, jml, lon_in, lat_in, lml, pls, workvar, champ, val_exp, jml2, lon_in2, lat_in2, interbar ) + ! + ! + ! There is special constraint on the atmospheric data base except that the + ! the data needs to be in netCDF and the variables should have the the following + ! names in the file : + ! + ! 'RELIEF' : High resolution orography + ! 'ST' : Surface temperature + ! 'CDSW' : Soil moisture + ! 'Z' : Surface geopotential + ! 'SP' : Surface pressure + ! 'U' : East ward wind + ! 'V' : Northward wind + ! 'TEMP' : Temperature + ! 'R' : Relative humidity + ! + USE ioipsl + ! + ! + IMPLICIT NONE + ! + ! + PRIVATE + PUBLIC startget + ! + ! + INTERFACE startget + MODULE PROCEDURE startget_phys2d, startget_phys1d, startget_dyn + END INTERFACE + ! + INTEGER, SAVE :: fid_phys, fid_dyn + INTEGER, SAVE :: iml_phys, iml_rel, iml_dyn + INTEGER, SAVE :: jml_phys, jml_rel, jml_dyn + INTEGER, SAVE :: llm_dyn, ttm_dyn + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: lon_phys, lon_rug, + . lon_alb, lon_rel, lon_dyn + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: lat_phys, lat_rug, + . lat_alb, lat_rel, lat_dyn + REAL, ALLOCATABLE, SAVE, DIMENSION (:) :: levdyn_ini + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: relief, zstd, zsig, + . zgam, zthe, zpic, zval + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: rugo, masque, phis + ! + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: tsol, qsol, psol_dyn + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: var_ana3d + ! + CONTAINS + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE startget_phys2d(varname, iml, jml, lon_in, lat_in, + . champ, val_exp, jml2, lon_in2, lat_in2 , interbar, masque_lu ) + ! + ! There is a big mess with the size in logitude, should it be iml or iml+1. + ! I have chosen to use the iml+1 as an argument to this routine and we declare + ! internaly smaler fields when needed. This needs to be cleared once and for all in LMDZ. + ! A convention is required. + ! + ! + CHARACTER*(*), INTENT(in) :: varname + INTEGER, INTENT(in) :: iml, jml ,jml2 + REAL, INTENT(in) :: lon_in(iml), lat_in(jml) + REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) + REAL, INTENT(inout) :: champ(iml,jml) + REAL, INTENT(in) :: val_exp + REAL, INTENT(in), optional :: masque_lu(iml,jml) + LOGICAL interbar + ! + ! This routine only works if the variable does not exist or is constant + ! + IF ( MINVAL(champ(:,:)).EQ.MAXVAL(champ(:,:)) .AND. + .MINVAL(champ(:,:)).EQ.val_exp ) THEN + ! + SELECTCASE(varname) + ! + CASE ('relief') + ! + ! If we do not have the orography we need to get it + ! + IF ( .NOT.ALLOCATED(relief)) THEN + ! + if (present(masque_lu)) then + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2,lon_in2,lat_in2, interbar, masque_lu ) + else + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2,lon_in2,lat_in2, interbar) + endif + ! + ENDIF + ! + IF (SIZE(relief) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) 'STARTVAR module has been', + .' initialized to the wrong size' + STOP + ! + ENDIF + ! + champ(:,:) = relief(:,:) + ! + CASE ('rugosite') + ! + ! If we do not have the orography we need to get it + ! + IF ( .NOT.ALLOCATED(rugo)) THEN + ! + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2,lon_in2,lat_in2 , interbar ) + ! + ENDIF + ! + IF (SIZE(rugo) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ! + ENDIF + ! + champ(:,:) = rugo(:,:) + ! + CASE ('masque') + ! + ! If we do not have the orography we need to get it + ! + IF ( .NOT.ALLOCATED(masque)) THEN + ! + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2,lon_in2,lat_in2 , interbar ) + ! + ENDIF + ! + IF (SIZE(masque) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ! + ENDIF + ! + champ(:,:) = masque(:,:) + ! + CASE ('surfgeo') + ! + ! If we do not have the orography we need to get it + ! + IF ( .NOT.ALLOCATED(phis)) THEN + ! + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2,lon_in2, lat_in2 , interbar ) + ! + ENDIF + ! + IF (SIZE(phis) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ! + ENDIF + ! + champ(:,:) = phis(:,:) + ! + CASE ('psol') + ! + ! If we do not have the orography we need to get it + ! + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + ! + CALL start_init_dyn( iml, jml, lon_in, lat_in, + . jml2,lon_in2, lat_in2 , interbar ) + ! + ENDIF + ! + IF (SIZE(psol_dyn) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ! + ENDIF + ! + champ(:,:) = psol_dyn(:,:) + ! + CASE DEFAULT + ! + WRITE(*,*) 'startget_phys2d' + WRITE(*,*) 'No rule is present to extract variable', + . varname(:LEN_TRIM(varname)),' from any data set' + STOP + ! + END SELECT + ! + ELSE + ! + ! There are a few fields we might need if we need to interpolate 3D filed. Thus if they come through here we + ! will catch them + ! + SELECTCASE(varname) + ! + CASE ('surfgeo') + ! + IF ( .NOT.ALLOCATED(phis)) THEN + ALLOCATE(phis(iml,jml)) + ENDIF + ! + IF (SIZE(phis) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ! + ENDIF + ! + phis(:,:) = champ(:,:) + ! + END SELECT + ! + ENDIF + ! + END SUBROUTINE startget_phys2d + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE start_init_orog ( iml,jml,lon_in, lat_in,jml2,lon_in2 , + , lat_in2 , interbar, masque_lu ) + ! + INTEGER, INTENT(in) :: iml, jml, jml2 + REAL, INTENT(in) :: lon_in(iml), lat_in(jml) + REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) + REAL, intent(in), optional :: masque_lu(iml,jml) + LOGICAL interbar + ! + ! LOCAL + ! + LOGICAL interbar2 + REAL :: lev(1), date, dt,chmin,chmax + INTEGER :: itau(1), fid + INTEGER :: llm_tmp, ttm_tmp + INTEGER :: i, j + INTEGER :: iret + CHARACTER*25 title + REAL, ALLOCATABLE :: relief_hi(:,:) + REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:) + REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) + REAL, ALLOCATABLE :: tmp_var(:,:) + INTEGER, ALLOCATABLE :: tmp_int(:,:) + ! + CHARACTER*120 :: orogfname + LOGICAL :: check=.TRUE. + ! + ! + orogfname = 'Relief.nc' + ! + IF ( check ) WRITE(*,*) 'Reading the high resolution orography' + ! + CALL flininfo(orogfname,iml_rel, jml_rel, llm_tmp, ttm_tmp, fid) + ! + ALLOCATE (lat_rel(iml_rel,jml_rel), stat=iret) + ALLOCATE (lon_rel(iml_rel,jml_rel), stat=iret) + ALLOCATE (relief_hi(iml_rel,jml_rel), stat=iret) + ! + CALL flinopen(orogfname, .FALSE., iml_rel, jml_rel, + .llm_tmp, lon_rel, lat_rel, lev, ttm_tmp, + . itau, date, dt, fid) + ! + CALL flinget(fid, 'RELIEF', iml_rel, jml_rel, llm_tmp, + . ttm_tmp, 1, 1, relief_hi) + ! + CALL flinclo(fid) + ! + ! In case we have a file which is in degrees we do the transformation + ! + ALLOCATE(lon_rad(iml_rel)) + ALLOCATE(lon_ini(iml_rel)) + + IF ( MAXVAL(lon_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lon_ini(:) = lon_rel(:,1) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lon_ini(:) = lon_rel(:,1) + ENDIF + + ALLOCATE(lat_rad(jml_rel)) + ALLOCATE(lat_ini(jml_rel)) + + IF ( MAXVAL(lat_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lat_ini(:) = lat_rel(1,:) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lat_ini(:) = lat_rel(1,:) + ENDIF + ! + ! + + title='RELIEF' + + interbar2 = .FALSE. + CALL conf_dat2d(title,iml_rel, jml_rel, lon_ini, lat_ini, + . lon_rad, lat_rad, relief_hi , interbar2 ) + + IF ( check ) WRITE(*,*) 'Computes all the parameters needed', + .' for the gravity wave drag code' + ! + ! Allocate the data we need to put in the interpolated fields + ! + ! RELIEF: orographie moyenne + ALLOCATE(relief(iml,jml)) + ! zphi : orographie moyenne + ALLOCATE(phis(iml,jml)) + ! zstd: deviation standard de l'orographie sous-maille + ALLOCATE(zstd(iml,jml)) + ! zsig: pente de l'orographie sous-maille + ALLOCATE(zsig(iml,jml)) + ! zgam: anisotropy de l'orographie sous maille + ALLOCATE(zgam(iml,jml)) + ! zthe: orientation de l'axe oriente dans la direction + ! de plus grande pente de l'orographie sous maille + ALLOCATE(zthe(iml,jml)) + ! zpic: hauteur pics de la SSO + ALLOCATE(zpic(iml,jml)) + ! zval: hauteur vallees de la SSO + ALLOCATE(zval(iml,jml)) + ! masque : Masque terre ocean + ALLOCATE(tmp_int(iml,jml)) + ALLOCATE(masque(iml,jml)) + + masque = -99999. + if (present(masque_lu)) then + masque = masque_lu + endif + ! + CALL grid_noro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi, + . iml-1, jml, lon_in, lat_in, + . phis, relief, zstd, zsig, zgam, zthe, zpic, zval, masque) + phis = phis * 9.81 + ! +! masque(:,:) = FLOAT(tmp_int(:,:)) + ! + ! Compute surface roughness + ! + IF ( check ) WRITE(*,*) + .'Compute surface roughness induced by the orography' + ! + ALLOCATE(rugo(iml,jml)) + ALLOCATE(tmp_var(iml-1,jml)) + ! + CALL rugsoro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi, + . iml-1, jml, lon_in, lat_in, tmp_var) + ! + DO j = 1, jml + DO i = 1, iml-1 + rugo(i,j) = tmp_var(i,j) + ENDDO + rugo(iml,j) = tmp_var(1,j) + ENDDO +c +cc *** rugo n'est pas utilise pour l'instant ****** + ! + ! Build land-sea mask + ! + ! + RETURN + ! + END SUBROUTINE start_init_orog + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE startget_phys1d(varname, iml, jml, lon_in, + .lat_in, nbindex, champ, val_exp ,jml2, lon_in2, lat_in2,interbar) + ! + CHARACTER*(*), INTENT(in) :: varname + INTEGER, INTENT(in) :: iml, jml, nbindex, jml2 + REAL, INTENT(in) :: lon_in(iml), lat_in(jml) + REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) + REAL, INTENT(inout) :: champ(nbindex) + REAL, INTENT(in) :: val_exp + LOGICAL interbar + ! + ! + ! This routine only works if the variable does not exist or is constant + ! + IF ( MINVAL(champ(:)).EQ.MAXVAL(champ(:)) .AND. + .MINVAL(champ(:)).EQ.val_exp ) THEN + SELECTCASE(varname) + CASE ('tsol') + IF ( .NOT.ALLOCATED(tsol)) THEN + CALL start_init_phys( iml, jml, lon_in, lat_in, + . jml2, lon_in2, lat_in2, interbar ) + ENDIF + IF ( SIZE(tsol) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex, tsol, champ) + CASE ('qsol') + IF ( .NOT.ALLOCATED(qsol)) THEN + CALL start_init_phys( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(qsol) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex, qsol, champ) + CASE ('psol') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF (SIZE(psol_dyn) .NE. SIZE(lon_in)*SIZE(lat_in)) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex, psol_dyn, champ) + CASE ('zmea') + IF ( .NOT.ALLOCATED(relief)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(relief) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex, relief, champ) + CASE ('zstd') + IF ( .NOT.ALLOCATED(zstd)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zstd) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zstd, champ) + CASE ('zsig') + IF ( .NOT.ALLOCATED(zsig)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zsig) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zsig, champ) + CASE ('zgam') + IF ( .NOT.ALLOCATED(zgam)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zgam) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zgam, champ) + CASE ('zthe') + IF ( .NOT.ALLOCATED(zthe)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zthe) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zthe, champ) + CASE ('zpic') + IF ( .NOT.ALLOCATED(zpic)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zpic) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zpic, champ) + CASE ('zval') + IF ( .NOT.ALLOCATED(zval)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zval) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zval, champ) + CASE ('rads') + champ(:) = 0.0 + CASE ('snow') + champ(:) = 0.0 +cIM "slab" ocean + CASE ('tslab') + champ(:) = 0.0 + CASE ('seaice') + champ(:) = 0.0 + CASE ('rugmer') + champ(:) = 0.001 + CASE ('agsno') + champ(:) = 50.0 + CASE DEFAULT + WRITE(*,*) 'startget_phys1d' + WRITE(*,*) 'No rule is present to extract variable ', + . varname(:LEN_TRIM(varname)),' from any data set' + STOP + END SELECT + ELSE + ! + ! If we see tsol we catch it as we may need it for a 3D interpolation + ! + SELECTCASE(varname) + CASE ('tsol') + IF ( .NOT.ALLOCATED(tsol)) THEN + ALLOCATE(tsol(SIZE(lon_in),SIZE(lat_in) )) + ENDIF + CALL gr_fi_dyn(1, iml, jml, nbindex, champ, tsol) + END SELECT + ENDIF + END SUBROUTINE startget_phys1d + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE start_init_phys( iml, jml, lon_in, lat_in, jml2, + . lon_in2, lat_in2 , interbar ) + ! + INTEGER, INTENT(in) :: iml, jml ,jml2 + REAL, INTENT(in) :: lon_in(iml), lat_in(jml) + REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) + LOGICAL interbar + ! + ! LOCAL + ! +!ac REAL :: lev(1), date, dt + REAL :: date, dt + REAL, DIMENSION(:), ALLOCATABLE :: levphys_ini +!ac + INTEGER :: itau(1) + INTEGER :: llm_tmp, ttm_tmp + INTEGER :: i, j + ! + CHARACTER*25 title + CHARACTER*120 :: physfname + LOGICAL :: check=.TRUE. + ! + REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:) + REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) + REAL, ALLOCATABLE :: var_ana(:,:), tmp_var(:,:) + ! + physfname = 'ECPHY.nc' + ! + IF ( check ) WRITE(*,*) 'Opening the surface analysis' + ! + CALL flininfo(physfname, iml_phys, jml_phys, llm_tmp, + . ttm_tmp, fid_phys) + ! + ALLOCATE (lat_phys(iml_phys,jml_phys)) + ALLOCATE (lon_phys(iml_phys,jml_phys)) +!ac + ALLOCATE (levphys_ini(llm_tmp)) + ! +! CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, +! . llm_tmp, lon_phys, lat_phys, lev, ttm_tmp, +! . itau, date, dt, fid_phys) + ! + CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, + . llm_tmp, lon_phys, lat_phys, levphys_ini, ttm_tmp, + . itau, date, dt, fid_phys) + ! + DEALLOCATE (levphys_ini) +!ac + ! + ! Allocate the space we will need to get the data out of this file + ! + ALLOCATE(var_ana(iml_phys, jml_phys)) + ! + ! In case we have a file which is in degrees we do the transformation + ! + ALLOCATE(lon_rad(iml_phys)) + ALLOCATE(lon_ini(iml_phys)) + + IF ( MAXVAL(lon_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lon_ini(:) = lon_phys(:,1) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lon_ini(:) = lon_phys(:,1) + ENDIF + + ALLOCATE(lat_rad(jml_phys)) + ALLOCATE(lat_ini(jml_phys)) + + IF ( MAXVAL(lat_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lat_ini(:) = lat_phys(1,:) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lat_ini(:) = lat_phys(1,:) + ENDIF + + + ! + ! We get the two standard varibales + ! Surface temperature + ! + ALLOCATE(tsol(iml,jml)) + ALLOCATE(tmp_var(iml-1,jml)) + ! + ! + + CALL flinget(fid_phys, 'ST', iml_phys, jml_phys, + .llm_tmp, ttm_tmp, 1, 1, var_ana) + + title='ST' + CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, + . lon_rad, lat_rad, var_ana , interbar ) + + IF ( interbar ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour ST $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + CALL inter_barxy ( iml_phys,jml_phys -1,lon_rad,lat_rad , + , var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var ) + ELSE + CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad, + . var_ana, iml-1, jml, lon_in, lat_in, tmp_var ) + ENDIF + + CALL gr_int_dyn(tmp_var, tsol, iml-1, jml) + ! + ! Soil moisture + ! + ALLOCATE(qsol(iml,jml)) + CALL flinget(fid_phys, 'CDSW', iml_phys, jml_phys, + . llm_tmp, ttm_tmp, 1, 1, var_ana) + + title='CDSW' + CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, + . lon_rad, lat_rad, var_ana, interbar ) + + IF ( interbar ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour CDSW $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + CALL inter_barxy ( iml_phys,jml_phys -1,lon_rad,lat_rad , + , var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var ) + ELSE + CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad, + . var_ana, iml-1, jml, lon_in, lat_in, tmp_var ) + ENDIF +c + CALL gr_int_dyn(tmp_var, qsol, iml-1, jml) + ! + CALL flinclo(fid_phys) + ! + END SUBROUTINE start_init_phys + ! + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! + SUBROUTINE startget_dyn(varname, iml, jml, lon_in, lat_in, + . lml, pls, workvar, champ, val_exp,jml2, lon_in2, lat_in2 , + , interbar ) + ! + ! ARGUMENTS + ! + CHARACTER*(*), INTENT(in) :: varname + INTEGER, INTENT(in) :: iml, jml, lml, jml2 + REAL, INTENT(in) :: lon_in(iml), lat_in(jml) + REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) + REAL, INTENT(in) :: pls(iml, jml, lml) + REAL, INTENT(in) :: workvar(iml, jml, lml) + REAL, INTENT(inout) :: champ(iml, jml, lml) + REAL, INTENT(in) :: val_exp + LOGICAL interbar + ! + ! LOCAL + ! + INTEGER :: il, ij, ii + REAL :: xppn, xpps + ! +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comconst.h" + ! + ! This routine only works if the variable does not exist or is constant + ! + IF ( MINVAL(champ(:,:,:)).EQ.MAXVAL(champ(:,:,:)) .AND. + . MINVAL(champ(:,:,:)).EQ.val_exp ) THEN + ! + SELECTCASE(varname) + CASE ('u') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 , + . lon_in2,lat_in2 , interbar ) + ENDIF + CALL start_inter_3d('U', iml, jml, lml, lon_in, + . lat_in, jml2, lon_in2, lat_in2, pls, champ,interbar ) + DO il=1,lml + DO ij=1,jml + DO ii=1,iml-1 + champ(ii,ij,il) = champ(ii,ij,il) * cu(ii,ij) + ENDDO + champ(iml,ij, il) = champ(1,ij, il) + ENDDO + ENDDO + CASE ('v') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in , jml2, + . lon_in2, lat_in2 , interbar ) + ENDIF + CALL start_inter_3d('V', iml, jml, lml, lon_in, + . lat_in, jml2, lon_in2, lat_in2, pls, champ, interbar ) + DO il=1,lml + DO ij=1,jml + DO ii=1,iml-1 + champ(ii,ij,il) = champ(ii,ij,il) * cv(ii,ij) + ENDDO + champ(iml,ij, il) = champ(1,ij, il) + ENDDO + ENDDO + CASE ('t') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 , + . lon_in2, lat_in2 ,interbar ) + ENDIF + CALL start_inter_3d('TEMP', iml, jml, lml, lon_in, + . lat_in, jml2, lon_in2, lat_in2, pls, champ, interbar ) + + CASE ('tpot') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in , jml2 , + . lon_in2, lat_in2 , interbar ) + ENDIF + CALL start_inter_3d('TEMP', iml, jml, lml, lon_in, + . lat_in, jml2, lon_in2, lat_in2, pls, champ, interbar ) + IF ( MINVAL(workvar(:,:,:)) .NE. MAXVAL(workvar(:,:,:)) ) + . THEN + DO il=1,lml + DO ij=1,jml + DO ii=1,iml-1 + champ(ii,ij,il) = champ(ii,ij,il) * cpp + . / workvar(ii,ij,il) + ENDDO + champ(iml,ij,il) = champ(1,ij,il) + ENDDO + ENDDO + DO il=1,lml + xppn = SUM(aire(:,1)*champ(:,1,il))/apoln + xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols + champ(:,1,il) = xppn + champ(:,jml,il) = xpps + ENDDO + ELSE + WRITE(*,*)'Could not compute potential temperature as the' + WRITE(*,*)'Exner function is missing or constant.' + STOP + ENDIF + CASE ('q') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 , + . lon_in2, lat_in2 , interbar ) + ENDIF + CALL start_inter_3d('R', iml, jml, lml, lon_in, lat_in, + . jml2, lon_in2, lat_in2, pls, champ, interbar ) + IF ( MINVAL(workvar(:,:,:)) .NE. MAXVAL(workvar(:,:,:)) ) + . THEN + DO il=1,lml + DO ij=1,jml + DO ii=1,iml-1 + champ(ii,ij,il) = 0.01 * champ(ii,ij,il) * + . workvar(ii,ij,il) + ENDDO + champ(iml,ij,il) = champ(1,ij,il) + ENDDO + ENDDO + WHERE ( champ .LT. 0.) champ = 1.0E-10 + DO il=1,lml + xppn = SUM(aire(:,1)*champ(:,1,il))/apoln + xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols + champ(:,1,il) = xppn + champ(:,jml,il) = xpps + ENDDO + ELSE + WRITE(*,*)'Could not compute specific humidity as the' + WRITE(*,*)'saturated humidity is missing or constant.' + STOP + ENDIF + CASE DEFAULT + WRITE(*,*) 'startget_dyn' + WRITE(*,*) 'No rule is present to extract variable ', + . varname(:LEN_TRIM(varname)),' from any data set' + STOP + END SELECT + ENDIF + END SUBROUTINE startget_dyn + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE start_init_dyn( iml, jml, lon_in, lat_in,jml2,lon_in2 , + , lat_in2 , interbar ) + ! + INTEGER, INTENT(in) :: iml, jml, jml2 + REAL, INTENT(in) :: lon_in(iml), lat_in(jml) + REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) + LOGICAL interbar + ! + ! LOCAL + ! + REAL :: lev(1), date, dt + INTEGER :: itau(1) + INTEGER :: i, j + integer :: iret + ! + CHARACTER*120 :: physfname + LOGICAL :: check=.TRUE. + ! + REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:) + REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) + REAL, ALLOCATABLE :: var_ana(:,:), tmp_var(:,:), z(:,:) + REAL, ALLOCATABLE :: xppn(:), xpps(:) + LOGICAL :: allo + ! + ! +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" + + CHARACTER*25 title + + ! + physfname = 'ECDYN.nc' + ! + IF ( check ) WRITE(*,*) 'Opening the surface analysis' + ! + CALL flininfo(physfname, iml_dyn, jml_dyn, llm_dyn, + . ttm_dyn, fid_dyn) + IF ( check ) WRITE(*,*) 'Values read: ', iml_dyn, jml_dyn, + . llm_dyn, ttm_dyn + ! + ALLOCATE (lat_dyn(iml_dyn,jml_dyn), stat=iret) + ALLOCATE (lon_dyn(iml_dyn,jml_dyn), stat=iret) + ALLOCATE (levdyn_ini(llm_dyn), stat=iret) + ! + CALL flinopen(physfname, .FALSE., iml_dyn, jml_dyn, llm_dyn, + . lon_dyn, lat_dyn, levdyn_ini, ttm_dyn, + . itau, date, dt, fid_dyn) + ! + + allo = allocated (var_ana) + if (allo) then + DEALLOCATE(var_ana, stat=iret) + endif + ALLOCATE(var_ana(iml_dyn, jml_dyn), stat=iret) + + allo = allocated (lon_rad) + if (allo) then + DEALLOCATE(lon_rad, stat=iret) + endif + + ALLOCATE(lon_rad(iml_dyn), stat=iret) + ALLOCATE(lon_ini(iml_dyn)) + + IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lon_ini(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lon_ini(:) = lon_dyn(:,1) + ENDIF + + ALLOCATE(lat_rad(jml_dyn)) + ALLOCATE(lat_ini(jml_dyn)) + + IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lat_ini(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lat_ini(:) = lat_dyn(1,:) + ENDIF + ! + + + ALLOCATE(z(iml, jml)) + ALLOCATE(tmp_var(iml-1,jml)) + ! + CALL flinget(fid_dyn, 'Z', iml_dyn, jml_dyn, 0, ttm_dyn, + . 1, 1, var_ana) +c + title='Z' + CALL conf_dat2d( title,iml_dyn, jml_dyn,lon_ini, lat_ini, + . lon_rad, lat_rad, var_ana, interbar ) +c + IF ( interbar ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour Z $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + CALL inter_barxy ( iml_dyn,jml_dyn -1,lon_rad,lat_rad , + , var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var) + ELSE + CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana, + . iml-1, jml, lon_in, lat_in, tmp_var) + ENDIF + + CALL gr_int_dyn(tmp_var, z, iml-1, jml) + ! + ALLOCATE(psol_dyn(iml, jml)) + ! + CALL flinget(fid_dyn, 'SP', iml_dyn, jml_dyn, 0, ttm_dyn, + . 1, 1, var_ana) + + title='SP' + CALL conf_dat2d( title,iml_dyn, jml_dyn,lon_ini, lat_ini, + . lon_rad, lat_rad, var_ana, interbar ) + + IF ( interbar ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour SP $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + CALL inter_barxy ( iml_dyn,jml_dyn -1,lon_rad,lat_rad , + , var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var) + ELSE + CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana, + . iml-1, jml, lon_in, lat_in, tmp_var ) + ENDIF + + CALL gr_int_dyn(tmp_var, psol_dyn, iml-1, jml) + ! + IF ( .NOT.ALLOCATED(tsol)) THEN + ! These variables may have been allocated by the need to + ! create a start field for them or by the varibale + ! coming out of the restart file. In case we dor have it we will initialize it. + ! + CALL start_init_phys( iml, jml, lon_in, lat_in,jml2,lon_in2, + . lat_in2 , interbar ) + ELSE + IF ( SIZE(tsol) .NE. SIZE(psol_dyn) ) THEN + WRITE(*,*) 'start_init_dyn :' + WRITE(*,*) 'The temperature field we have does not ', + . 'have the right size' + STOP + ENDIF + ENDIF + IF ( .NOT.ALLOCATED(phis)) THEN + ! + ! These variables may have been allocated by the need to create a start field for them or by the varibale + ! coming out of the restart file. In case we dor have it we will initialize it. + ! + CALL start_init_orog( iml, jml, lon_in, lat_in, jml2, lon_in2 , + . lat_in2 , interbar ) + ! + ELSE + ! + IF (SIZE(phis) .NE. SIZE(psol_dyn)) THEN + ! + WRITE(*,*) 'start_init_dyn :' + WRITE(*,*) 'The orography field we have does not ', + . ' have the right size' + STOP + ENDIF + ! + ENDIF + ! + ! PSOL is computed in Pascals + ! + ! + DO j = 1, jml + DO i = 1, iml-1 + psol_dyn(i,j) = psol_dyn(i,j)*(1.0+(z(i,j)-phis(i,j)) + . /287.0/tsol(i,j)) + ENDDO + psol_dyn(iml,j) = psol_dyn(1,j) + ENDDO + ! + ! + ALLOCATE(xppn(iml-1)) + ALLOCATE(xpps(iml-1)) + ! + DO i = 1, iml-1 + xppn(i) = aire( i,1) * psol_dyn( i,1) + xpps(i) = aire( i,jml) * psol_dyn( i,jml) + ENDDO + ! + DO i = 1, iml + psol_dyn(i,1 ) = SUM(xppn)/apoln + psol_dyn(i,jml) = SUM(xpps)/apols + ENDDO + ! + RETURN + ! + END SUBROUTINE start_init_dyn + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE start_inter_3d(varname, iml, jml, lml, lon_in, + . lat_in, jml2, lon_in2, lat_in2, pls_in, var3d, interbar ) + ! + ! This subroutine gets a variables from a 3D file and does the interpolations needed + ! + ! + ! ARGUMENTS + ! + CHARACTER*(*) :: varname + INTEGER :: iml, jml, lml, jml2 + REAL :: lon_in(iml), lat_in(jml), pls_in(iml, jml, lml) + REAL :: lon_in2(iml) , lat_in2(jml2) + REAL :: var3d(iml, jml, lml) + LOGICAL interbar + real chmin,chmax + ! + ! LOCAL + ! + CHARACTER*25 title + INTEGER :: ii, ij, il, jsort,i,j,l + REAL :: bx, by + REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:) + REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) , lev_dyn(:) + REAL, ALLOCATABLE :: var_tmp2d(:,:), var_tmp3d(:,:,:) + REAL, ALLOCATABLE :: ax(:), ay(:), yder(:) +! REAL, ALLOCATABLE :: varrr(:,:,:) + INTEGER, ALLOCATABLE :: lind(:) + ! + LOGICAL :: check = .TRUE. + ! + IF ( .NOT. ALLOCATED(var_ana3d)) THEN + ALLOCATE(var_ana3d(iml_dyn, jml_dyn, llm_dyn)) + ENDIF +! ALLOCATE(varrr(iml_dyn, jml_dyn, llm_dyn)) + ! + ! + IF ( check) WRITE(*,*) 'Going into flinget to extract the 3D ', + . ' field.', fid_dyn + IF ( check) WRITE(*,*) fid_dyn, varname, iml_dyn, jml_dyn, + . llm_dyn,ttm_dyn + ! + CALL flinget(fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, + . ttm_dyn, 1, 1, var_ana3d) + ! + IF ( check) WRITE(*,*) 'Allocating space for the interpolation', + . iml, jml, llm_dyn + ! + ALLOCATE(lon_rad(iml_dyn)) + ALLOCATE(lon_ini(iml_dyn)) + + IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lon_ini(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lon_ini(:) = lon_dyn(:,1) + ENDIF + + ALLOCATE(lat_rad(jml_dyn)) + ALLOCATE(lat_ini(jml_dyn)) + + ALLOCATE(lev_dyn(llm_dyn)) + + IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lat_ini(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lat_ini(:) = lat_dyn(1,:) + ENDIF + ! + + CALL conf_dat3d ( varname,iml_dyn, jml_dyn, llm_dyn, lon_ini, + . lat_ini, levdyn_ini, lon_rad, lat_rad, lev_dyn, var_ana3d , + , interbar ) + + ALLOCATE(var_tmp2d(iml-1, jml)) + ALLOCATE(var_tmp3d(iml, jml, llm_dyn)) + ALLOCATE(ax(llm_dyn)) + ALLOCATE(ay(llm_dyn)) + ALLOCATE(yder(llm_dyn)) + ALLOCATE(lind(llm_dyn)) + ! + + DO il=1,llm_dyn + ! + IF( interbar ) THEN + IF( il.EQ.1 ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour ', varname + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + ENDIF + CALL inter_barxy ( iml_dyn, jml_dyn -1,lon_rad, lat_rad, + , var_ana3d(:,:,il),iml-1, jml2, lon_in2, lat_in2,jml,var_tmp2d ) + ELSE + CALL grille_m(iml_dyn, jml_dyn, lon_rad, lat_rad, + . var_ana3d(:,:,il), iml-1, jml, lon_in, lat_in, var_tmp2d ) + ENDIF + ! + CALL gr_int_dyn(var_tmp2d, var_tmp3d(:,:,il), iml-1, jml) + ! + ENDDO + ! + DO il=1,llm_dyn + lind(il) = llm_dyn-il+1 + ENDDO + ! +c +c ... Pour l'interpolation verticale ,on interpole du haut de l'atmosphere +c vers le sol ... +c + DO ij=1,jml + DO ii=1,iml-1 + ! + ax(:) = lev_dyn(lind(:)) + ay(:) = var_tmp3d(ii, ij, lind(:)) + ! + + CALL SPLINE(ax, ay, llm_dyn, 1.e30, 1.e30, yder) + ! + DO il=1,lml + bx = pls_in(ii, ij, il) + CALL SPLINT(ax, ay, yder, llm_dyn, bx, by) + var3d(ii, ij, il) = by + ENDDO + ! + ENDDO + var3d(iml, ij, :) = var3d(1, ij, :) + ENDDO + + do il=1,lml + call minmax(iml*jml,var3d(1,1,il),chmin,chmax) + SELECTCASE(varname) + CASE('U') + WRITE(*,*) ' U min max l ',il,chmin,chmax + CASE('V') + WRITE(*,*) ' V min max l ',il,chmin,chmax + CASE('TEMP') + WRITE(*,*) ' TEMP min max l ',il,chmin,chmax + CASE('R') + WRITE(*,*) ' R min max l ',il,chmin,chmax + END SELECT + enddo + + DEALLOCATE(lon_rad) + DEALLOCATE(lon_ini) + DEALLOCATE(lat_rad) + DEALLOCATE(lat_ini) + DEALLOCATE(lev_dyn) + DEALLOCATE(var_tmp2d) + DEALLOCATE(var_tmp3d) + DEALLOCATE(ax) + DEALLOCATE(ay) + DEALLOCATE(yder) + DEALLOCATE(lind) + + ! + RETURN + ! + END SUBROUTINE start_inter_3d + ! +#endif +! of #ifdef CPP_EARTH + END MODULE startvar Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/temps.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/temps.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/temps.h (revision 1280) @@ -0,0 +1,25 @@ +! +! $Id$ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! +! jD_ref = jour julien de la date de reference (lancement de l'experience) +! hD_ref = "heure" julienne de la date de reference +!----------------------------------------------------------------------- +! INCLUDE 'temps.h' + + COMMON/temps/itaufin, dt, day_ini, day_end, annee_ref, day_ref, & + & itau_dyn, itau_phy, jD_ref, jH_ref, calend + + INTEGER itaufin + INTEGER itau_dyn, itau_phy + INTEGER day_ini, day_end, annee_ref, day_ref + REAL dt, jD_ref, jH_ref + CHARACTER (len=10) :: calend + +!$OMP THREADPRIVATE(/temps/) +!----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/test_period.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/test_period.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/test_period.F (revision 1280) @@ -0,0 +1,115 @@ +! +! $Header$ +! + SUBROUTINE test_period ( ucov, vcov, teta, q, p, phis ) + USE infotrac, ONLY : nqtot +c +c Auteur : P. Le Van +c --------- +c .... Cette routine teste la periodicite en longitude des champs ucov, +c teta, q , p et phis .......... +c +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +c +c ...... Arguments ...... +c + REAL ucov(ip1jmp1,llm), vcov(ip1jm,llm), teta(ip1jmp1,llm) , + , q(ip1jmp1,llm,nqtot), p(ip1jmp1,llmp1), phis(ip1jmp1) +c +c ..... Variables locales ..... +c + INTEGER ij,l,nq +c + DO l = 1, llm + DO ij = 1, ip1jmp1, iip1 + IF( ucov(ij,l).NE.ucov(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- UCOV --- n est pas', + , ' periodique en longitude ! ' + PRINT *,' l, ij = ', l, ij, ij+iim + STOP + ENDIF + IF( teta(ij,l).NE.teta(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- TETA --- n est pas', + , ' periodique en longitude ! ' + PRINT *,' l, ij = ', l, ij, ij+iim + , , teta(ij,l), teta(ij+iim,l) + STOP + ENDIF + ENDDO + + do ij=1,iim + if (teta(ij,l).ne.teta(1,l) + s .or.teta(ip1jm+ij,l).ne.teta(ip1jm+1,l) ) then + PRINT *,'STOP dans test_period car --- TETA --- n est pas', + , ' constant aux poles ! ' + print*,'teta(',1 ,',',l,')=',teta(1 ,l) + print*,'teta(',ij,',',l,')=',teta(ij,l) + print*,'teta(',ip1jm+1 ,',',l,')=',teta(ip1jm+1 ,l) + print*,'teta(',ip1jm+ij,',',l,')=',teta(ip1jm+ij,l) + stop + endif + enddo + ENDDO + +c + DO l = 1, llm + DO ij = 1, ip1jm, iip1 + IF( vcov(ij,l).NE.vcov(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- VCOV --- n est pas', + , ' periodique en longitude !' + PRINT *,' l, ij = ', l, ij, ij+iim,vcov(ij+iim,l),vcov(ij,l) + vcov(ij+iim,l)=vcov(ij,l) +c STOP + ENDIF + ENDDO + ENDDO + +c + DO nq =1, nqtot + DO l =1, llm + DO ij = 1, ip1jmp1, iip1 + IF( q(ij,l,nq).NE.q(ij+iim,l,nq) ) THEN + PRINT *,'STOP dans test_period car --- Q --- n est pas ', + , 'periodique en longitude !' + PRINT *,' nq , l, ij = ', nq, l, ij, ij+iim + STOP + ENDIF + ENDDO + ENDDO + ENDDO +c + DO l = 1, llm + DO ij = 1, ip1jmp1, iip1 + IF( p(ij,l).NE.p(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- P --- n est pas', + , ' periodique en longitude !' + PRINT *,' l ij = ',l, ij, ij+iim + STOP + ENDIF + IF( phis(ij).NE.phis(ij+iim) ) THEN + PRINT *,'STOP dans test_period car --- PHIS --- n est pas', + , ' periodique en longitude ! l, IJ = ', l, ij,ij+iim + PRINT *,' ij = ', ij, ij+iim + STOP + ENDIF + ENDDO + do ij=1,iim + if (p(ij,l).ne.p(1,l) + s .or.p(ip1jm+ij,l).ne.p(ip1jm+1,l) ) then + PRINT *,'STOP dans test_period car --- P --- n est pas', + , ' constant aux poles ! ' + print*,'p(',1 ,',',l,')=',p(1 ,l) + print*,'p(',ij,',',l,')=',p(ij,l) + print*,'p(',ip1jm+1 ,',',l,')=',p(ip1jm+1 ,l) + print*,'p(',ip1jm+ij,',',l,')=',p(ip1jm+ij,l) + stop + endif + enddo + ENDDO +c +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/times.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/times.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/times.F90 (revision 1280) @@ -0,0 +1,248 @@ +module times + integer,private,save :: Last_Count=0 + real, private,save :: Last_cpuCount=0 + logical, private,save :: AllTimer_IsActive=.false. + + integer, parameter :: nb_timer = 4 + integer, parameter :: timer_caldyn = 1 + integer, parameter :: timer_vanleer = 2 + integer, parameter :: timer_dissip = 3 + integer, parameter :: timer_physic = 4 + integer, parameter :: stopped = 1 + integer, parameter :: running = 2 + integer, parameter :: suspended = 3 + + integer :: max_size + real, allocatable, dimension(:,:,:) :: timer_table + real, allocatable, dimension(:,:,:) :: timer_table_sqr + integer, allocatable, dimension(:,:,:) :: timer_iteration + real, allocatable, dimension(:,:,:) :: timer_average + real, allocatable, dimension(:,:,:) :: timer_delta + real, allocatable,dimension(:) :: timer_running, last_time + integer, allocatable,dimension(:) :: timer_state + + contains + + subroutine init_timer + use parallel + implicit none +#include "dimensions.h" +#include "paramet.h" + + max_size=jjm+1 + allocate(timer_table(max_size,nb_timer,0:mpi_size-1)) + allocate(timer_table_sqr(max_size,nb_timer,0:mpi_size-1)) + allocate(timer_iteration(max_size,nb_timer,0:mpi_size-1)) + allocate(timer_average(max_size,nb_timer,0:mpi_size-1)) + allocate(timer_delta(max_size,nb_timer,0:mpi_size-1)) + allocate(timer_running(nb_timer)) + allocate(timer_state(nb_timer)) + allocate(last_time(nb_timer)) + + timer_table(:,:,:)=0 + timer_table_sqr(:,:,:)=0 + timer_iteration(:,:,:)=0 + timer_average(:,:,:)=0 + timer_delta(:,:,:)=0 + timer_state(:)=stopped + end subroutine init_timer + + subroutine start_timer(no_timer) + implicit none + integer :: no_timer + + if (AllTimer_IsActive) then + + if (timer_state(no_timer)/=stopped) then + stop 'start_timer :: timer is already running or suspended' + else + timer_state(no_timer)=running + endif + + timer_running(no_timer)=0 + call cpu_time(last_time(no_timer)) + + endif + + end subroutine start_timer + + subroutine suspend_timer(no_timer) + implicit none + integer :: no_timer + + if (AllTimer_IsActive) then + if (timer_state(no_timer)/=running) then + stop 'suspend_timer :: timer is not running' + else + timer_state(no_timer)=suspended + endif + + timer_running(no_timer)=timer_running(no_timer)-last_time(no_timer) + call cpu_time(last_time(no_timer)) + timer_running(no_timer)=timer_running(no_timer)+last_time(no_timer) + endif + end subroutine suspend_timer + + subroutine resume_timer(no_timer) + implicit none + integer :: no_timer + + if (AllTimer_IsActive) then + if (timer_state(no_timer)/=suspended) then + stop 'resume_timer :: timer is not suspended' + else + timer_state(no_timer)=running + endif + + call cpu_time(last_time(no_timer)) + endif + + end subroutine resume_timer + + subroutine stop_timer(no_timer) + use parallel + implicit none + integer :: no_timer + integer :: N + real :: V,V2 + + if (AllTimer_IsActive) then + + if (timer_state(no_timer)/=running) then + stop 'stop_timer :: timer is not running' + else + timer_state(no_timer)=stopped + endif + + timer_running(no_timer)=timer_running(no_timer)-last_time(no_timer) + call cpu_time(last_time(no_timer)) + timer_running(no_timer)=timer_running(no_timer)+last_time(no_timer) + + timer_table(jj_nb,no_timer,mpi_rank)=timer_table(jj_nb,no_timer,mpi_rank)+timer_running(no_timer) + timer_table_sqr(jj_nb,no_timer,mpi_rank)=timer_table_sqr(jj_nb,no_timer,mpi_rank)+timer_running(no_timer)**2 + timer_iteration(jj_nb,no_timer,mpi_rank)=timer_iteration(jj_nb,no_timer,mpi_rank)+1 + timer_average(jj_nb,no_timer,mpi_rank)=timer_table(jj_nb,no_timer,mpi_rank)/timer_iteration(jj_nb,no_timer,mpi_rank) + if (timer_iteration(jj_nb,no_timer,mpi_rank)>=2) then + N=timer_iteration(jj_nb,no_timer,mpi_rank) + V2=timer_table_sqr(jj_nb,no_timer,mpi_rank) + V=timer_table(jj_nb,no_timer,mpi_rank) + timer_delta(jj_nb,no_timer,mpi_rank)=sqrt(ABS(V2-V*V/N)/(N-1)) + else + timer_delta(jj_nb,no_timer,mpi_rank)=0 + endif + endif + + end subroutine stop_timer + + subroutine allgather_timer + use parallel + implicit none +#ifdef CPP_MPI + include 'mpif.h' +#endif + integer :: ierr + integer :: data_size + real, allocatable,dimension(:,:) :: tmp_table + + IF (using_mpi) THEN + + if (AllTimer_IsActive) then + + + allocate(tmp_table(max_size,nb_timer)) + + data_size=max_size*nb_timer + + tmp_table(:,:)=timer_table(:,:,mpi_rank) +#ifdef CPP_MPI + call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_table(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr) +#endif + tmp_table(:,:)=timer_table_sqr(:,:,mpi_rank) +#ifdef CPP_MPI + call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_table_sqr(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr) +#endif + deallocate(tmp_table) + + endif + + ENDIF ! using_mpi + + end subroutine allgather_timer + + subroutine allgather_timer_average + use parallel + implicit none +#ifdef CPP_MPI + include 'mpif.h' +#endif + integer :: ierr + integer :: data_size + real, allocatable,dimension(:,:),target :: tmp_table + integer, allocatable,dimension(:,:),target :: tmp_iter + integer :: istats + + IF (using_mpi) THEN + + if (AllTimer_IsActive) then + + allocate(tmp_table(max_size,nb_timer)) + allocate(tmp_iter(max_size,nb_timer)) + + data_size=max_size*nb_timer + + tmp_table(:,:)=timer_average(:,:,mpi_rank) +#ifdef CPP_MPI + call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_average(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr) +#endif + tmp_table(:,:)=timer_delta(:,:,mpi_rank) +#ifdef CPP_MPI + call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_delta(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr) +#endif + tmp_iter(:,:)=timer_iteration(:,:,mpi_rank) +#ifdef CPP_MPI + call mpi_allgather(tmp_iter(1,1),data_size,MPI_INTEGER,timer_iteration(1,1,0),data_size,MPI_INTEGER,COMM_LMDZ,ierr) +#endif + deallocate(tmp_table) + + endif + + ENDIF ! using_mp� + end subroutine allgather_timer_average + + subroutine InitTime + implicit none + integer :: count,count_rate,count_max + + AllTimer_IsActive=.TRUE. + if (AllTimer_IsActive) then + call system_clock(count,count_rate,count_max) + call cpu_time(Last_cpuCount) + Last_Count=count + endif + end subroutine InitTime + + function DiffTime() + implicit none + double precision :: DiffTime + integer :: count,count_rate,count_max + + call system_clock(count,count_rate,count_max) + if (Count>=Last_Count) then + DiffTime=(1.*(Count-last_Count))/count_rate + else + DiffTime=(1.*(Count-last_Count+Count_max))/count_rate + endif + Last_Count=Count + end function DiffTime + + function DiffCpuTime() + implicit none + real :: DiffCpuTime + real :: Count + + call cpu_time(Count) + DiffCpuTime=Count-Last_cpuCount + Last_cpuCount=Count + end function DiffCpuTime + +end module times Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/top_bound_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/top_bound_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/top_bound_p.F (revision 1280) @@ -0,0 +1,161 @@ + SUBROUTINE top_bound_p( vcov,ucov,teta,masse, du,dv,dh ) + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + + +c .. DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO, +C F. LOTT DEC. 2006 +c ( 10/12/06 ) + +c======================================================================= +c +c Auteur: F. LOTT +c ------- +c +c Objet: +c ------ +c +c Dissipation linéaire (ex top_bound de la physique) +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "comdissipn.h" + +c Arguments: +c ---------- + + REAL ucov(iip1,jjp1,llm),vcov(iip1,jjm,llm),teta(iip1,jjp1,llm) + REAL masse(iip1,jjp1,llm) + REAL dv(iip1,jjm,llm),du(iip1,jjp1,llm),dh(iip1,jjp1,llm) + +c Local: +c ------ + REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm),zm + REAL uzon(jjp1,llm),vzon(jjm,llm),tzon(jjp1,llm) + + INTEGER NDAMP + PARAMETER (NDAMP=4) + integer i + REAL,SAVE :: rdamp(llm) +! & (/(0., i =1,llm-NDAMP),0.125E-5,.25E-5,.5E-5,1.E-5/) + LOGICAL,SAVE :: first=.true. + INTEGER j,l,jjb,jje + + + if (iflag_top_bound == 0) return + if (first) then +c$OMP BARRIER +c$OMP MASTER + if (iflag_top_bound == 1) then +! couche eponge dans les 4 dernieres couches du modele + rdamp(:)=0. + rdamp(llm)=tau_top_bound + rdamp(llm-1)=tau_top_bound/2. + rdamp(llm-2)=tau_top_bound/4. + rdamp(llm-3)=tau_top_bound/8. + else if (iflag_top_bound == 2) then +! couce eponge dans toutes les couches de pression plus faible que +! 100 fois la pression de la derniere couche + rdamp(:)=tau_top_bound + s *max(presnivs(llm)/presnivs(:)-0.01,0.) + endif + first=.false. + print*,'TOP_BOUND rdamp=',rdamp +c$OMP END MASTER +c$OMP BARRIER + endif + + + CALL massbar_p(masse,massebx,masseby) +C CALCUL DES CHAMPS EN MOYENNE ZONALE: + + jjb=jj_begin + jje=jj_end + IF (pole_sud) jje=jj_end-1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + zm=0. + vzon(j,l)=0 + do i=1,iim +! Rm: on peut travailler directement avec la moyenne zonale de vcov +! plutot qu'avec celle de v car le coefficient cv qui relie les deux +! ne varie qu'en latitude + vzon(j,l)=vzon(j,l)+vcov(i,j,l)*masseby(i,j,l) + zm=zm+masseby(i,j,l) + enddo + vzon(j,l)=vzon(j,l)/zm + enddo + enddo +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + do i=1,iip1 + dv(i,j,l)=dv(i,j,l)-rdamp(l)*(vcov(i,j,l)-vzon(j,l)) + enddo + enddo + enddo +c$OMP END DO NOWAIT + + jjb=jj_begin + jje=jj_end + IF (pole_nord) jjb=jj_begin+1 + IF (pole_sud) jje=jj_end-1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + uzon(j,l)=0. + zm=0. + do i=1,iim + uzon(j,l)=uzon(j,l)+massebx(i,j,l)*ucov(i,j,l)/cu(i,j) + zm=zm+massebx(i,j,l) + enddo + uzon(j,l)=uzon(j,l)/zm + enddo + enddo +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + zm=0. + tzon(j,l)=0. + do i=1,iim + tzon(j,l)=tzon(j,l)+teta(i,j,l)*masse(i,j,l) + zm=zm+masse(i,j,l) + enddo + tzon(j,l)=tzon(j,l)/zm + enddo + enddo +c$OMP END DO NOWAIT + +C AMORTISSEMENTS LINEAIRES: + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + do i=1,iip1 + du(i,j,l)=du(i,j,l) + s -rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l)) + dh(i,j,l)=dh(i,j,l)-rdamp(l)*(teta(i,j,l)-tzon(j,l)) + enddo + enddo + enddo +c$OMP END DO NOWAIT + + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/tourabs.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/tourabs.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/tourabs.F (revision 1280) @@ -0,0 +1,98 @@ + SUBROUTINE tourabs ( ntetaSTD,vcov, ucov, vorabs ) + IMPLICIT NONE + +c======================================================================= +c +c Modif: I. Musat (28/10/04) +c ------- +c adaptation du code tourpot.F pour le calcul de la vorticite absolue +c cf. P. Le Van +c +c Objet: +c ------ +c +c ******************************************************************* +c ............. calcul de la vorticite absolue ................. +c ******************************************************************* +c +c ntetaSTD, vcov,ucov sont des argum. d'entree pour le s-pg . +c vorabs est un argum.de sortie pour le s-pg . +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "logic.h" +#include "comconst.h" +c + INTEGER ntetaSTD + REAL vcov( ip1jm,ntetaSTD ), ucov( ip1jmp1,ntetaSTD ) + REAL vorabs( ip1jm,ntetaSTD ) +c +c variables locales + INTEGER l, ij, i, j + REAL rot( ip1jm,ntetaSTD ) + + + +c ... vorabs = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) .. + + + +c ........ Calcul du rotationnel du vent V puis filtrage ........ + + DO 5 l = 1,ntetaSTD + + DO 2 i = 1, iip1 + DO 2 j = 1, jjm +c + ij=i+(j-1)*iip1 + IF(ij.LE.ip1jm - 1) THEN +c + IF(cv(ij).EQ.0..OR.cv(ij+1).EQ.0..OR. + $ cu(ij).EQ.0..OR.cu(ij+iip1).EQ.0.) THEN + rot( ij,l ) = 0. + continue + ELSE + rot( ij,l ) = (vcov(ij+1,l)/cv(ij+1)-vcov(ij,l)/cv(ij))/ + $ (2.*pi*RAD*cos(rlatv(j)))*float(iim) + $ +(ucov(ij+iip1,l)/cu(ij+iip1)-ucov(ij,l)/cu(ij))/ + $ (pi*RAD)*(float(jjm)-1.) +c + ENDIF + ENDIF !(ij.LE.ip1jm - 1) THEN + 2 CONTINUE + +c .... correction pour rot( iip1,j,l ) ..... +c .... rot(iip1,j,l) = rot(1,j,l) ..... + +CDIR$ IVDEP + + DO 3 ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim, l ) + 3 CONTINUE + + 5 CONTINUE + + + CALL filtreg( rot, jjm, ntetaSTD, 2, 1, .FALSE., 1 ) + + + DO 10 l = 1, ntetaSTD + + DO 6 ij = 1, ip1jm - 1 + vorabs( ij,l ) = ( rot(ij,l) + fext(ij)*unsairez(ij) ) + 6 CONTINUE + +c ..... correction pour vorabs( iip1,j,l) ..... +c .... vorabs(iip1,j,l)= vorabs(1,j,l) .... +CDIR$ IVDEP + DO 8 ij = iip1, ip1jm, iip1 + vorabs( ij,l ) = vorabs( ij -iim,l ) + 8 CONTINUE + + 10 CONTINUE + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/tourpot.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/tourpot.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/tourpot.F (revision 1280) @@ -0,0 +1,81 @@ +! +! $Header$ +! + SUBROUTINE tourpot ( vcov, ucov, massebxy, vorpot ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c ......... calcul du tourbillon potentiel ......... +c ******************************************************************* +c +c vcov,ucov,fext et pbarxyfl sont des argum. d'entree pour le s-pg . +c vorpot est un argum.de sortie pour le s-pg . +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "logic.h" + + REAL rot( ip1jm,llm ) + REAL vcov( ip1jm,llm ),ucov( ip1jmp1,llm ) + REAL massebxy( ip1jm,llm ),vorpot( ip1jm,llm ) + + INTEGER l, ij + + + + +c ... vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy .. + + + +c ........ Calcul du rotationnel du vent V puis filtrage ........ + + DO 5 l = 1,llm + + DO 2 ij = 1, ip1jm - 1 + rot( ij,l ) = vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l) + 2 CONTINUE + +c .... correction pour rot( iip1,j,l ) ..... +c .... rot(iip1,j,l) = rot(1,j,l) ..... + +CDIR$ IVDEP + + DO 3 ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim, l ) + 3 CONTINUE + + 5 CONTINUE + + + CALL filtreg( rot, jjm, llm, 2, 1, .FALSE., 1 ) + + + DO 10 l = 1, llm + + DO 6 ij = 1, ip1jm - 1 + vorpot( ij,l ) = ( rot(ij,l) + fext(ij) ) / massebxy(ij,l) + 6 CONTINUE + +c ..... correction pour vorpot( iip1,j,l) ..... +c .... vorpot(iip1,j,l)= vorpot(1,j,l) .... +CDIR$ IVDEP + DO 8 ij = iip1, ip1jm, iip1 + vorpot( ij,l ) = vorpot( ij -iim,l ) + 8 CONTINUE + + 10 CONTINUE + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/tourpot_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/tourpot_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/tourpot_p.F (revision 1280) @@ -0,0 +1,93 @@ + SUBROUTINE tourpot_p ( vcov, ucov, massebxy, vorpot ) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c ......... calcul du tourbillon potentiel ......... +c ******************************************************************* +c +c vcov,ucov,fext et pbarxyfl sont des argum. d'entree pour le s-pg . +c vorpot est un argum.de sortie pour le s-pg . +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "logic.h" + + REAL rot( ip1jm,llm ) + REAL vcov( ip1jm,llm ),ucov( ip1jmp1,llm ) + REAL massebxy( ip1jm,llm ),vorpot( ip1jm,llm ) + + INTEGER l, ij ,ije,ijb,jje,jjb + + + ijb=ij_begin-iip1 + ije=ij_end + + if (pole_nord) ijb=ij_begin + + +c ... vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy .. + + + +c ........ Calcul du rotationnel du vent V puis filtrage ........ +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,llm + + if (pole_sud) ije=ij_end-iip1-1 + DO 2 ij = ijb, ije + rot( ij,l ) = vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l) + 2 CONTINUE + +c .... correction pour rot( iip1,j,l ) ..... +c .... rot(iip1,j,l) = rot(1,j,l) ..... + +CDIR$ IVDEP + + if (pole_sud) ije=ij_end-iip1 + + DO 3 ij = ijb+iip1-1, ije, iip1 + rot( ij,l ) = rot( ij -iim, l ) + 3 CONTINUE + + 5 CONTINUE +c$OMP END DO NOWAIT + jjb=jj_begin-1 + jje=jj_end + + if (pole_nord) jjb=jjb+1 + if (pole_sud) jje=jje-1 + CALL filtreg_p( rot, jjb,jje,jjm, llm, 2, 1, .FALSE., 1 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1, llm + + if (pole_sud) ije=ij_end-iip1-1 + + DO 6 ij = ijb, ije + vorpot( ij,l ) = ( rot(ij,l) + fext(ij) ) / massebxy(ij,l) + 6 CONTINUE + +c ..... correction pour vorpot( iip1,j,l) ..... +c .... vorpot(iip1,j,l)= vorpot(1,j,l) .... +CDIR$ IVDEP + if (pole_sud) ije=ij_end-iip1 + DO 8 ij = ijb+iip1-1, ije, iip1 + vorpot( ij,l ) = vorpot( ij -iim,l ) + 8 CONTINUE + + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/traceurpole.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/traceurpole.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/traceurpole.F (revision 1280) @@ -0,0 +1,69 @@ +! +! $Header$ +! + subroutine traceurpole(q,masse) + + implicit none + +#include "dimensions.h" +c#include "paramr2.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissip.h" +#include "comvert.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "control.h" +#include "ener.h" +#include "description.h" + + +c Arguments + integer iq + real masse(iip1,jjp1,llm) + real q(iip1,jjp1,llm) + + +c Locals + integer i,j,l + real sommemassen(llm) + real sommemqn(llm) + real sommemasses(llm) + real sommemqs(llm) + real qpolen(llm),qpoles(llm) + + +c On impose une seule valeur au pôle Sud j=jjm+1=jjp1 + sommemasses=0 + sommemqs=0 + do l=1,llm + do i=1,iip1 + sommemasses(l)=sommemasses(l)+masse(i,jjp1,l) + sommemqs(l)=sommemqs(l)+masse(i,jjp1,l)*q(i,jjp1,l) + enddo + qpoles(l)=sommemqs(l)/sommemasses(l) + enddo + +c On impose une seule valeur du traceur au pôle Nord j=1 + sommemassen=0 + sommemqn=0 + do l=1,llm + do i=1,iip1 + sommemassen(l)=sommemassen(l)+masse(i,1,l) + sommemqn(l)=sommemqn(l)+masse(i,1,l)*q(i,1,l) + enddo + qpolen(l)=sommemqn(l)/sommemassen(l) + enddo + +c On force le traceur à prendre cette valeur aux pôles + do l=1,llm + do i=1,iip1 + q(i,1,l)=qpolen(l) + q(i,jjp1,l)=qpoles(l) + enddo + enddo + + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/tracstoke.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/tracstoke.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/tracstoke.h (revision 1280) @@ -0,0 +1,5 @@ +! +! $Header$ +! + common /tracstoke/istdyn,istphy,unittrac + integer istdyn,istphy,unittrac Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ugeostr.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ugeostr.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/ugeostr.F (revision 1280) @@ -0,0 +1,69 @@ +! +! $Id$ +! + subroutine ugeostr(phi,ucov) + + +c Calcul du vent covariant geostrophique a partir du champs de +c geopotentiel en supposant que le vent au sol est nul. + + implicit none + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" + + real ucov(iip1,jjp1,llm),phi(iip1,jjp1,llm) + real um(jjm,llm),fact,u(iip1,jjm,llm) + integer i,j,l + + real zlat + + um(:,:)=0 ! initialize um() + + DO j=1,jjm + + if (abs(sin(rlatv(j))).lt.1.e-4) then + zlat=1.e-4 + else + zlat=rlatv(j) + endif + fact=cos(zlat) + fact=fact*fact + fact=fact*fact + fact=fact*fact + fact=(1.-fact)/ + s (2.*omeg*sin(zlat)*(rlatu(j+1)-rlatu(j))) + fact=-fact/rad + DO l=1,llm + DO i=1,iim + u(i,j,l)=fact*(phi(i,j+1,l)-phi(i,j,l)) + um(j,l)=um(j,l)+u(i,j,l)/float(iim) + ENDDO + ENDDO + ENDDO + call dump2d(jjm,llm,um,'Vent-u geostrophique') + +c +c----------------------------------------------------------------------- +c calcul des champ de vent: +c ------------------------- + + DO 301 l=1,llm + DO 302 i=1,iip1 + ucov(i,1,l)=0. + ucov(i,jjp1,l)=0. +302 CONTINUE + DO 304 j=2,jjm + DO 305 i=1,iim + ucov(i,j,l) = 0.5*(u(i,j,l)+u(i,j-1,l))*cu(i,j) +305 CONTINUE + ucov(iip1,j,l)=ucov(1,j,l) +304 CONTINUE +301 CONTINUE + + print*,301 + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/vitvert.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/vitvert.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/vitvert.F (revision 1280) @@ -0,0 +1,52 @@ +! +! $Header$ +! + SUBROUTINE vitvert ( convm , w ) +c + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c .... calcul de la vitesse verticale aux niveaux sigma .... +c ******************************************************************* +c convm est un argument d'entree pour le s-pg ...... +c w est un argument de sortie pour le s-pg ...... +c +c la vitesse verticale est orientee de haut en bas . +c au sol, au niveau sigma(1), w(i,j,1) = 0. +c au sommet, au niveau sigma(llm+1) , la vit.verticale est aussi +c egale a 0. et n'est pas stockee dans le tableau w . +c +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + + REAL w(ip1jmp1,llm),convm(ip1jmp1,llm) + INTEGER l, ij + + + + DO 2 l = 1,llmm1 + + DO 1 ij = 1,ip1jmp1 + w( ij, l+1 ) = convm( ij, l+1 ) - bp(l+1) * convm( ij, 1 ) + 1 CONTINUE + + 2 CONTINUE + + DO 5 ij = 1,ip1jmp1 + w(ij,1) = 0. +5 CONTINUE + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/vitvert_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/vitvert_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/vitvert_p.F (revision 1280) @@ -0,0 +1,56 @@ + SUBROUTINE vitvert_p ( convm , w ) +c + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c .... calcul de la vitesse verticale aux niveaux sigma .... +c ******************************************************************* +c convm est un argument d'entree pour le s-pg ...... +c w est un argument de sortie pour le s-pg ...... +c +c la vitesse verticale est orientee de haut en bas . +c au sol, au niveau sigma(1), w(i,j,1) = 0. +c au sommet, au niveau sigma(llm+1) , la vit.verticale est aussi +c egale a 0. et n'est pas stockee dans le tableau w . +c +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + + REAL w(ip1jmp1,llm),convm(ip1jmp1,llm) + INTEGER l, ij,ijb,ije + + + ijb=ij_begin + ije=ij_end+iip1 + + if (pole_sud) ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 2 l = 1,llmm1 + + DO 1 ij = ijb,ije + w( ij, l+1 ) = convm( ij, l+1 ) - bp(l+1) * convm( ij, 1 ) + 1 CONTINUE + + 2 CONTINUE +c$OMP END DO +c$OMP MASTER + DO 5 ij = ijb,ije + w(ij,1) = 0. +5 CONTINUE +c$OMP END MASTER +c$OMP BARRIER + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/vlsplt_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/vlsplt_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/vlsplt_p.F (revision 1280) @@ -0,0 +1,1138 @@ + SUBROUTINE vlsplt_p(q,pente_max,masse,w,pbaru,pbarv,pdt) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c pente_max facteur de limitation des pentes: 2 en general +c 0 pour un schema amont +c pbaru,pbarv,w flux de masse en u ,v ,w +c pdt pas de temps +c +c -------------------------------------------------------------------- + USE parallel + USE mod_hallo + USE Vampir + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" + +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max +c REAL masse(iip1,jjp1,llm),pente_max + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL q(ip1jmp1,llm) +c REAL q(iip1,jjp1,llm) + REAL w(ip1jmp1,llm),pdt +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii + INTEGER ijlqmin,iqmin,jqmin,lqmin +c + REAL zm(ip1jmp1,llm),newmasse + REAL mu(ip1jmp1,llm) + REAL mv(ip1jm,llm) + REAL mw(ip1jmp1,llm+1) + REAL zq(ip1jmp1,llm),zz + REAL dqx(ip1jmp1,llm),dqy(ip1jmp1,llm),dqz(ip1jmp1,llm) + REAL second,temps0,temps1,temps2,temps3 + REAL ztemps1,ztemps2,ztemps3 + REAL zzpbar, zzw + LOGICAL testcpu + SAVE testcpu + SAVE temps1,temps2,temps3 + INTEGER iminn,imaxx + + REAL qmin,qmax + DATA qmin,qmax/0.,1.e33/ + DATA testcpu/.false./ + DATA temps1,temps2,temps3/0.,0.,0./ + INTEGER ijb,ije + type(request) :: MyRequest1 + type(request) :: MyRequest2 + + call SetTag(MyRequest1,100) + call SetTag(MyRequest2,101) + + zzpbar = 0.5 * pdt + zzw = pdt + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + DO l=1,llm + DO ij = ijb,ije + mu(ij,l)=pbaru(ij,l) * zzpbar + ENDDO + ENDDO + + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO l=1,llm + DO ij=ijb,ije + mv(ij,l)=pbarv(ij,l) * zzpbar + ENDDO + ENDDO + + ijb=ij_begin + ije=ij_end + + DO l=1,llm + DO ij=ijb,ije + mw(ij,l)=w(ij,l) * zzw + ENDDO + ENDDO + + DO ij=ijb,ije + mw(ij,llm+1)=0. + ENDDO + +c CALL SCOPY(ijp1llm,q,1,zq,1) +c CALL SCOPY(ijp1llm,masse,1,zm,1) + + ijb=ij_begin + ije=ij_end + zq(ijb:ije,:)=q(ijb:ije,:) + zm(ijb:ije,:)=masse(ijb:ije,:) + + +c print*,'Entree vlx1' +c call minmaxq(zq,qmin,qmax,'avant vlx ') + call vlx_p(zq,pente_max,zm,mu,ij_begin,ij_begin+2*iip1-1) + call vlx_p(zq,pente_max,zm,mu,ij_end-2*iip1+1,ij_end) + call VTb(VTHallo) + call Register_Hallo(zq,ip1jmp1,llm,2,2,2,2,MyRequest1) + call Register_Hallo(zm,ip1jmp1,llm,1,1,1,1,MyRequest1) + call SendRequest(MyRequest1) + call VTe(VTHallo) + call vlx_p(zq,pente_max,zm,mu,ij_begin+2*iip1,ij_end-2*iip1) +c call vlx_p(zq,pente_max,zm,mu,ij_begin,ij_end) + call VTb(VTHallo) + call WaitRecvRequest(MyRequest1) + call VTe(VTHallo) + + +c print*,'Sortie vlx1' +c call minmaxq(zq,qmin,qmax,'apres vlx1 ') + +c print*,'Entree vly1' +c call exchange_hallo(zq,ip1jmp1,llm,2,2) +c call exchange_hallo(zm,ip1jmp1,llm,1,1) + + call vly_p(zq,pente_max,zm,mv) +c call minmaxq(zq,qmin,qmax,'apres vly1 ') +c print*,'Sortie vly1' + call vlz_p(zq,pente_max,zm,mw,ij_begin,ij_begin+2*iip1-1) + call vlz_p(zq,pente_max,zm,mw,ij_end-2*iip1+1,ij_end) + call VTb(VTHallo) + call Register_Hallo(zq,ip1jmp1,llm,2,2,2,2,MyRequest2) + call Register_Hallo(zm,ip1jmp1,llm,1,1,1,1,MyRequest2) + call SendRequest(MyRequest2) + call VTe(VTHallo) + call vlz_p(zq,pente_max,zm,mw,ij_begin+2*iip1,ij_end-2*iip1) + call VTb(VTHallo) + call WaitRecvRequest(MyRequest2) + + call VTe(VTHallo) + +c call minmaxq(zq,qmin,qmax,'apres vlz ') + + + + + call vly_p(zq,pente_max,zm,mv) +c call minmaxq(zq,qmin,qmax,'apres vly ') + + + call vlx_p(zq,pente_max,zm,mu,ij_begin,ij_end) +c call minmaxq(zq,qmin,qmax,'apres vlx2 ') + + + ijb=ij_begin + ije=ij_end + + DO l=1,llm + DO ij=ijb,ije + q(ij,l)=zq(ij,l) + ENDDO + ENDDO + + + DO l=1,llm + DO ij=ijb,ije-iip1+1,iip1 + q(ij+iim,l)=q(ij,l) + ENDDO + ENDDO + + call WaitSendRequest(MyRequest1) + call WaitSendRequest(MyRequest2) + + RETURN + END + + + SUBROUTINE vlx_p(q,pente_max,masse,u_m,ijb_x,ije_x) + +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + USE Parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL u_m( ip1jmp1,llm ),pbarv( iip1,jjm,llm) + REAL q(ip1jmp1,llm) + REAL w(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL new_m,zu_m,zdum(ip1jmp1,llm) + REAL sigu(ip1jmp1),dxq(ip1jmp1,llm),dxqu(ip1jmp1) + REAL zz(ip1jmp1) + REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm) + REAL u_mq(ip1jmp1,llm) + + Logical extremum + + REAL SSUM + EXTERNAL SSUM + + REAL z1,z2,z3 + + INTEGER ijb,ije,ijb_x,ije_x + +c calcul de la pente a droite et a gauche de la maille + + ijb=ijb_x + ije=ije_x + + if (pole_nord.and.ijb==1) ijb=ijb+iip1 + if (pole_sud.and.ije==ip1jmp1) ije=ije-iip1 + + IF (pente_max.gt.-1.e-5) THEN +c IF (pente_max.gt.10) THEN + +c calcul des pentes avec limitation, Van Leer scheme I: +c ----------------------------------------------------- + +c calcul de la pente aux points u +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + + DO ij=ijb,ije-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) +c IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0' +c sigu(ij)=u_m(ij,l)/masse(ij,l) + ENDDO + DO ij=ijb+iip1-1,ije,iip1 + dxqu(ij)=dxqu(ij-iim) +c sigu(ij)=sigu(ij-iim) + ENDDO + + DO ij=ijb,ije + adxqu(ij)=abs(dxqu(ij)) + ENDDO + +c calcul de la pente maximum dans la maille en valeur absolue + + DO ij=ijb+1,ije + dxqmax(ij,l)=pente_max* + , min(adxqu(ij-1),adxqu(ij)) +c limitation subtile +c , min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij))) + + + ENDDO + + DO ij=ijb+iip1-1,ije,iip1 + dxqmax(ij-iim,l)=dxqmax(ij,l) + ENDDO + + DO ij=ijb+1,ije +#ifdef CRAY + dxq(ij,l)= + , cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij)) +#else + IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN + dxq(ij,l)=dxqu(ij-1)+dxqu(ij) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF +#endif + dxq(ij,l)=0.5*dxq(ij,l) + dxq(ij,l)= + , sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l)) + ENDDO + + ENDDO ! l=1,llm +c$OMP END DO NOWAIT +c print*,'Ok calcul des pentes' + + ELSE ! (pente_max.lt.-1.e-5) + +c Pentes produits: +c ---------------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij=ijb,ije-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + ENDDO + DO ij=ijb+iip1-1,ije,iip1 + dxqu(ij)=dxqu(ij-iim) + ENDDO + + DO ij=ijb+1,ije + zz(ij)=dxqu(ij-1)*dxqu(ij) + zz(ij)=zz(ij)+zz(ij) + IF(zz(ij).gt.0) THEN + dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij)) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF + ENDDO + + ENDDO +c$OMP END DO NOWAIT + ENDIF ! (pente_max.lt.-1.e-5) + +c bouclage de la pente en iip1: +c ----------------------------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + dxq(ij-iim,l)=dxq(ij,l) + ENDDO + DO ij=ijb,ije + iadvplus(ij,l)=0 + ENDDO + + ENDDO +c$OMP END DO NOWAIT +c print*,'Bouclage en iip1' + +c calcul des flux a gauche et a droite + +#ifdef CRAY +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l), + , 1.+u_m(ij,l)/masse(ij+1,l), + , u_m(ij,l)) + zdum(ij,l)=0.5*zdum(ij,l) + u_mq(ij,l)=cvmgp( + , q(ij,l)+zdum(ij,l)*dxq(ij,l), + , q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l), + , u_m(ij,l)) + u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +#else +c on cumule le flux correspondant a toutes les mailles dont la masse +c au travers de la paroi pENDant le pas de temps. +c print*,'Cumule ....' +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 +c print*,'masse(',ij,')=',masse(ij,l) + IF (u_m(ij,l).gt.0.) THEN + zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l) + u_mq(ij,l)=u_m(ij,l)*(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l)) + ELSE + zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l) + u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l)) + ENDIF + ENDDO + ENDDO +c$OMP END DO NOWAIT +#endif +c stop + +c go to 9999 +c detection des points ou on advecte plus que la masse de la +c maille +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + IF(zdum(ij,l).lt.0) THEN + iadvplus(ij,l)=1 + u_mq(ij,l)=0. + ENDIF + ENDDO + ENDDO +c$OMP END DO NOWAIT +c print*,'Ok test 1' +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + iadvplus(ij,l)=iadvplus(ij-iim,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c print*,'Ok test 2' + + +c traitement special pour le cas ou on advecte en longitude plus que le +c contenu de la maille. +c cette partie est mal vectorisee. + +c calcul du nombre de maille sur lequel on advecte plus que la maille. + + n0=0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + nl(l)=0 + DO ij=ijb,ije + nl(l)=nl(l)+iadvplus(ij,l) + ENDDO + n0=n0+nl(l) + ENDDO +c$OMP END DO NOWAIT +cym IF(n0.gt.1) THEN +cym IF(n0.gt.0) THEN + +c PRINT*,'Nombre de points pour lesquels on advect plus que le' +c & ,'contenu de la maille : ',n0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + IF(nl(l).gt.0) THEN + iju=0 +c indicage des mailles concernees par le traitement special + DO ij=ijb,ije + IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN + iju=iju+1 + indu(iju)=ij + ENDIF + ENDDO + niju=iju +c PRINT*,'niju,nl',niju,nl(l) + +c traitement des mailles + DO iju=1,niju + ij=indu(iju) + j=(ij-1)/iip1+1 + zu_m=u_m(ij,l) + u_mq(ij,l)=0. + IF(zu_m.gt.0.) THEN + ijq=ij + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l) + zu_m=zu_m-masse(ijq,l) + i=mod(i-2+iim,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m* + & (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l)) + ELSE + ijq=ij+1 + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(-zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l) + zu_m=zu_m+masse(ijq,l) + i=mod(i,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)- + & 0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l)) + ENDIF + ENDDO + ENDIF + ENDDO +c$OMP END DO NOWAIT +cym ENDIF ! n0.gt.0 +9999 continue + + +c bouclage en latitude +c print*,'Avant bouclage en latitude' +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c calcul des tENDances +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+1,ije + new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+ + & u_mq(ij-1,l)-u_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + ENDDO +c ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous) + DO ij=ijb+iip1-1,ije,iip1 + q(ij-iim,l)=q(ij,l) + masse(ij-iim,l)=masse(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1) +c CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1) + + + RETURN + END + + + SUBROUTINE vly_p(q,pente_max,masse,masse_adv_v) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,masse_adv_v,w sont des arguments d'entree pour le s-pg .... +c dq sont des arguments de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL masse_adv_v( ip1jm,llm) + REAL q(ip1jmp1,llm), dq( ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,ij,l +c + REAL airej2,airejjm,airescb(iim),airesch(iim) + REAL dyq(ip1jmp1,llm),dyqv(ip1jm),zdvm(ip1jmp1,llm) + REAL adyqv(ip1jm),dyqmax(ip1jmp1) + REAL qbyv(ip1jm,llm) + + REAL qpns,qpsn,apn,aps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs +c REAL newq,oldmasse + Logical extremum,first,testcpu + REAL temps0,temps1,temps2,temps3,temps4,temps5,second + SAVE temps0,temps1,temps2,temps3,temps4,temps5 +c$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5) + SAVE first,testcpu +c$OMP THREADPRIVATE(first,testcpu) + + REAL convpn,convps,convmpn,convmps + real massepn,masseps,qpn,qps + REAL sinlon(iip1),sinlondlon(iip1) + REAL coslon(iip1),coslondlon(iip1) + SAVE sinlon,coslon,sinlondlon,coslondlon +c$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon) + SAVE airej2,airejjm +c$OMP THREADPRIVATE(airej2,airejjm) +c +c + REAL SSUM + EXTERNAL SSUM + + DATA first,testcpu/.true.,.false./ + DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ + INTEGER ijb,ije + + IF(first) THEN +c PRINT*,'Shema Amont nouveau appele dans Vanleer ' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + ENDDO + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + airej2 = SSUM( iim, aire(iip2), 1 ) + airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) + ENDIF + +c +c PRINT*,'CALCUL EN LATITUDE' + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm +c +c -------------------------------- +c CALCUL EN LATITUDE +c -------------------------------- + +c On commence par calculer la valeur du traceur moyenne sur le premier cercle +c de latitude autour du pole (qpns pour le pole nord et qpsn pour +c le pole nord) qui sera utilisee pour evaluer les pentes au pole. + + if (pole_nord) then + DO i = 1, iim + airescb(i) = aire(i+ iip1) * q(i+ iip1,l) + ENDDO + qpns = SSUM( iim, airescb ,1 ) / airej2 + endif + + if (pole_sud) then + DO i = 1, iim + airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l) + ENDDO + qpsn = SSUM( iim, airesch ,1 ) / airejjm + endif + + + +c calcul des pentes aux points v + + ijb=ij_begin-2*iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + adyqv(ij)=abs(dyqv(ij)) + ENDDO + +c calcul des pentes aux points scalaires + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij)) + dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) + dyqmax(ij)=pente_max*dyqmax(ij) + ENDDO + +c calcul des pentes aux poles + IF (pole_nord) THEN + DO ij=1,iip1 + dyq(ij,l)=qpns-q(ij+iip1,l) + ENDDO + + dyn1=0. + dyn2=0. + DO ij=1,iim + dyn1=dyn1+sinlondlon(ij)*dyq(ij,l) + dyn2=dyn2+coslondlon(ij)*dyq(ij,l) + ENDDO + DO ij=1,iip1 + dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij) + ENDDO + + DO ij=1,iip1 + dyq(ij,l)=0. + ENDDO +c ym tout cela ne sert pas a grand chose + ENDIF + + IF (pole_sud) THEN + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn + ENDDO + + dys1=0. + dys2=0. + + DO ij=1,iim + dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l) + dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l) + ENDDO + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij) + ENDDO + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=0. + ENDDO +c ym tout cela ne sert pas a grand chose + ENDIF + +c filtrage de la derivee + +c calcul des pentes limites aux poles +c ym partie inutile +c goto 8888 +c fn=1. +c fs=1. +c DO ij=1,iim +c IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN +c fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn) +c ENDIF +c IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN +c fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs) +c ENDIF +c ENDDO +c DO ij=1,iip1 +c dyq(ij,l)=fn*dyq(ij,l) +c dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l) +c ENDDO +c 8888 continue + + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C En memoire de dIFferents tests sur la +C limitation des pentes aux poles. +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C PRINT*,dyq(1) +C PRINT*,dyqv(iip1+1) +C apn=abs(dyq(1)/dyqv(iip1+1)) +C PRINT*,dyq(ip1jm+1) +C PRINT*,dyqv(ip1jm-iip1+1) +C aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) +C DO ij=2,iim +C apn=amax1(abs(dyq(ij)/dyqv(ij)),apn) +C aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps) +C ENDDO +C apn=min(pente_max/apn,1.) +C aps=min(pente_max/aps,1.) +C +C +C cas ou on a un extremum au pole +C +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & apn=0. +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C & aps=0. +C +C limitation des pentes aux poles +C DO ij=1,iip1 +C dyq(ij)=apn*dyq(ij) +C dyq(ip1jm+ij)=aps*dyq(ip1jm+ij) +C ENDDO +C +C test +C DO ij=1,iip1 +C dyq(iip1+ij)=0. +C dyq(ip1jm+ij-iip1)=0. +C ENDDO +C DO ij=1,ip1jmp1 +C dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) +C ENDDO +C +C changement 10 07 96 +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & THEN +C DO ij=1,iip1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=1,iip1 +C dyqmax(ij)=pente_max*abs(dyqv(ij)) +C ENDDO +C ENDIF +C +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C &THEN +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) +C ENDDO +C ENDIF +C fin changement 10 07 96 +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + +c calcul des pentes limitees + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN + dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l)) + ELSE + dyq(ij,l)=0. + ENDIF + ENDDO + + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + IF(masse_adv_v(ij,l).gt.0) THEN + qbyv(ij,l)=q(ij+iip1,l)+dyq(ij+iip1,l)* + , 0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l)) + ELSE + qbyv(ij,l)=q(ij,l)-dyq(ij,l)* + , 0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) + ENDIF + qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + newmasse=masse(ij,l) + & +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l) + + q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l)) + & /newmasse + masse(ij,l)=newmasse + ENDDO +c.-. ancienne version +c convpn=SSUM(iim,qbyv(1,l),1)/apoln +c convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln + if (pole_nord) then + convpn=SSUM(iim,qbyv(1,l),1) + convmpn=ssum(iim,masse_adv_v(1,l),1) + massepn=ssum(iim,masse(1,l),1) + qpn=0. + do ij=1,iim + qpn=qpn+masse(ij,l)*q(ij,l) + enddo + qpn=(qpn+convpn)/(massepn+convmpn) + do ij=1,iip1 + q(ij,l)=qpn + enddo + endif + +c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols +c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols + + if (pole_sud) then + + convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) + convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) + masseps=ssum(iim, masse(ip1jm+1,l),1) + qps=0. + do ij = ip1jm+1,ip1jmp1-1 + qps=qps+masse(ij,l)*q(ij,l) + enddo + qps=(qps+convps)/(masseps+convmps) + do ij=ip1jm+1,ip1jmp1 + q(ij,l)=qps + enddo + endif +c.-. fin ancienne version + +c._. nouvelle version +c convpn=SSUM(iim,qbyv(1,l),1) +c convmpn=ssum(iim,masse_adv_v(1,l),1) +c oldmasse=ssum(iim,masse(1,l),1) +c newmasse=oldmasse+convmpn +c newq=(q(1,l)*oldmasse+convpn)/newmasse +c newmasse=newmasse/apoln +c DO ij = 1,iip1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) +c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) +c oldmasse=ssum(iim,masse(ip1jm-iim,l),1) +c newmasse=oldmasse+convmps +c newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse +c newmasse=newmasse/apols +c DO ij = ip1jm+1,ip1jmp1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c._. fin nouvelle version + ENDDO +c$OMP END DO NOWAIT + + RETURN + END + + + + SUBROUTINE vlz_p(q,pente_max,masse,w,ijb_x,ije_x) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c dq sont des arguments de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + USE Parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL q(ip1jmp1,llm) + REAL w(ip1jmp1,llm+1) +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii +c + REAL,SAVE :: wq(ip1jmp1,llm+1) + REAL newmasse + + REAL,SAVE :: dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm) + REAL dzqmax + REAL sigw + + LOGICAL testcpu + SAVE testcpu +c$OMP THREADPRIVATE(testcpu) + REAL temps0,temps1,temps2,temps3,temps4,temps5,second + SAVE temps0,temps1,temps2,temps3,temps4,temps5 +c$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5) + + REAL SSUM + EXTERNAL SSUM + + DATA testcpu/.false./ + DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ + INTEGER ijb,ije,ijb_x,ije_x +c On oriente tout dans le sens de la pression c'est a dire dans le +c sens de W + +#ifdef BIDON + IF(testcpu) THEN + temps0=second(0.) + ENDIF +#endif + + ijb=ijb_x + ije=ije_x + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=2,llm + DO ij=ijb,ije + dzqw(ij,l)=q(ij,l-1)-q(ij,l) + adzqw(ij,l)=abs(dzqw(ij,l)) + ENDDO + ENDDO +c$OMP END DO + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=2,llm-1 + DO ij=ijb,ije +#ifdef CRAY + dzq(ij,l)=0.5* + , cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1)) +#else + IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN + dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1)) + ELSE + dzq(ij,l)=0. + ENDIF +#endif + dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1)) + dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l)) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + DO ij=ijb,ije + dzq(ij,1)=0. + dzq(ij,llm)=0. + ENDDO +c$OMP END MASTER +c$OMP BARRIER +#ifdef BIDON + IF(testcpu) THEN + temps1=temps1+second(0.)-temps0 + ENDIF +#endif +c --------------------------------------------------------------- +c .... calcul des termes d'advection verticale ....... +c --------------------------------------------------------------- + +c calcul de - d( q * w )/ d(sigma) qu'on ajoute a dq pour calculer dq + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm-1 + do ij = ijb,ije + IF(w(ij,l+1).gt.0.) THEN + sigw=w(ij,l+1)/masse(ij,l+1) + wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1)+0.5*(1.-sigw)*dzq(ij,l+1)) + ELSE + sigw=w(ij,l+1)/masse(ij,l) + wq(ij,l+1)=w(ij,l+1)*(q(ij,l)-0.5*(1.+sigw)*dzq(ij,l)) + ENDIF + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + DO ij=ijb,ije + wq(ij,llm+1)=0. + wq(ij,1)=0. + ENDDO +c$OMP END MASTER +c$OMP BARRIER + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + newmasse=masse(ij,l)+w(ij,l+1)-w(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+wq(ij,l+1)-wq(ij,l)) + & /newmasse + masse(ij,l)=newmasse + ENDDO + ENDDO +c$OMP END DO NOWAIT + + + RETURN + END +c SUBROUTINE minmaxq(zq,qmin,qmax,comment) +c +c#include "dimensions.h" +c#include "paramet.h" + +c CHARACTER*(*) comment +c real qmin,qmax +c real zq(ip1jmp1,llm) + +c INTEGER jadrs(ip1jmp1), jbad, k, i + + +c DO k = 1, llm +c jbad = 0 +c DO i = 1, ip1jmp1 +c IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN +c jbad = jbad + 1 +c jadrs(jbad) = i +c ENDIF +c ENDDO +c IF (jbad.GT.0) THEN +c PRINT*, comment +c DO i = 1, jbad +cc PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k) +c ENDDO +c ENDIF +c ENDDO + +c return +c end + + + subroutine minmaxq_p(zq,qmin,qmax,comment) + +#include "dimensions.h" +#include "paramet.h" + + character*20 comment + real qmin,qmax + real zq(ip1jmp1,llm) + real zzq(iip1,jjp1,llm) + + integer imin,jmin,lmin,ijlmin + integer imax,jmax,lmax,ijlmax + + integer ismin,ismax + +#ifdef isminismax + call scopy (ip1jmp1*llm,zq,1,zzq,1) + + ijlmin=ismin(ijp1llm,zq,1) + lmin=(ijlmin-1)/ip1jmp1+1 + ijlmin=ijlmin-(lmin-1.)*ip1jmp1 + jmin=(ijlmin-1)/iip1+1 + imin=ijlmin-(jmin-1.)*iip1 + zqmin=zq(ijlmin,lmin) + + ijlmax=ismax(ijp1llm,zq,1) + lmax=(ijlmax-1)/ip1jmp1+1 + ijlmax=ijlmax-(lmax-1.)*ip1jmp1 + jmax=(ijlmax-1)/iip1+1 + imax=ijlmax-(jmax-1.)*iip1 + zqmax=zq(ijlmax,lmax) + + if(zqmin.lt.qmin) +c s write(*,9999) comment, + s write(*,*) comment, + s imin,jmin,lmin,zqmin,zzq(imin,jmin,lmin) + if(zqmax.gt.qmax) +c s write(*,9999) comment, + s write(*,*) comment, + s imax,jmax,lmax,zqmax,zzq(imax,jmax,lmax) +#endif + return +9999 format(a20,' q(',i3,',',i2,',',i2,')=',e12.5,e12.5) + end + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/vlspltgen_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/vlspltgen_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/vlspltgen_p.F (revision 1280) @@ -0,0 +1,497 @@ +! +! $Header$ +! + SUBROUTINE vlspltgen_p( q,iadv,pente_max,masse,w,pbaru,pbarv,pdt, + , p,pk,teta ) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget, F.Codron +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c + test sur humidite specifique: Q advecte< Qsat aval +c (F. Codron, 10/99) +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c pente_max facteur de limitation des pentes: 2 en general +c 0 pour un schema amont +c pbaru,pbarv,w flux de masse en u ,v ,w +c pdt pas de temps +c +c teta temperature potentielle, p pression aux interfaces, +c pk exner au milieu des couches necessaire pour calculer Qsat +c -------------------------------------------------------------------- + USE parallel + USE mod_hallo + USE Write_Field_p + USE VAMPIR + USE infotrac, ONLY : nqtot + IMPLICIT NONE + +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" + +c +c Arguments: +c ---------- + INTEGER iadv(nqtot) + REAL masse(ip1jmp1,llm),pente_max + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL q(ip1jmp1,llm,nqtot) + REAL w(ip1jmp1,llm),pdt + REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + REAL,SAVE :: qsat(ip1jmp1,llm) + REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: zm + REAL,SAVE :: mu(ip1jmp1,llm) + REAL,SAVE :: mv(ip1jm,llm) + REAL,SAVE :: mw(ip1jmp1,llm+1) + REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: zq + REAL zzpbar, zzw + + REAL qmin,qmax + DATA qmin,qmax/0.,1.e33/ + +c--pour rapport de melange saturant-- + + REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play + REAL ptarg,pdelarg,foeew,zdelta + REAL tempe(ip1jmp1) + INTEGER ijb,ije,iq + LOGICAL, SAVE :: firstcall=.TRUE. +!$OMP THREADPRIVATE(firstcall) + type(request) :: MyRequest1 + type(request) :: MyRequest2 + +c fonction psat(T) + + FOEEW ( PTARG,PDELARG ) = EXP ( + * (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT) + * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) ) + + r2es = 380.11733 + r3les = 17.269 + r3ies = 21.875 + r4les = 35.86 + r4ies = 7.66 + retv = 0.6077667 + rtt = 273.16 + +c Allocate variables depending on dynamic variable nqtot + + IF (firstcall) THEN + firstcall=.FALSE. +!$OMP MASTER + ALLOCATE(zm(ip1jmp1,llm,nqtot)) + ALLOCATE(zq(ip1jmp1,llm,nqtot)) +!$OMP END MASTER +!$OMP BARRIER + END IF +c-- Calcul de Qsat en chaque point +c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2 +c pour eviter une exponentielle. + + call SetTag(MyRequest1,100) + call SetTag(MyRequest2,101) + + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije + tempe(ij) = teta(ij,l) * pk(ij,l) /cpp + ENDDO + DO ij = ijb, ije + zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) ) + play = 0.5*(p(ij,l)+p(ij,l+1)) + qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play ) + qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) ) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c PRINT*,'Debut vlsplt version debug sans vlyqs' + + zzpbar = 0.5 * pdt + zzw = pdt + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij = ijb,ije + mu(ij,l)=pbaru(ij,l) * zzpbar + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + mv(ij,l)=pbarv(ij,l) * zzpbar + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + mw(ij,l)=w(ij,l) * zzw + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + DO ij=ijb,ije + mw(ij,llm+1)=0. + ENDDO +c$OMP END MASTER + +c CALL SCOPY(ijp1llm,q,1,zq,1) +c CALL SCOPY(ijp1llm,masse,1,zm,1) + + ijb=ij_begin + ije=ij_end + + DO iq=1,nqtot +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + zq(ijb:ije,l,iq)=q(ijb:ije,l,iq) + zm(ijb:ije,l,iq)=masse(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + ENDDO + + +c$OMP BARRIER + DO iq=1,nqtot + + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10) then + +#ifdef _ADV_HALO + call vlx_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu, + & ij_begin,ij_begin+2*iip1-1) + call vlx_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu, + & ij_end-2*iip1+1,ij_end) +#else + call vlx_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu, + & ij_begin,ij_end) +#endif + +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + call Register_Hallo(zq(1,1,iq),ip1jmp1,llm,2,2,2,2,MyRequest1) + call Register_Hallo(zm(1,1,iq),ip1jmp1,llm,1,1,1,1,MyRequest1) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER + else if (iadv(iq)==14) then + +#ifdef _ADV_HALO + call vlxqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,qsat, + & ij_begin,ij_begin+2*iip1-1) + call vlxqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,qsat, + & ij_end-2*iip1+1,ij_end) +#else + + call vlxqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,qsat, + & ij_begin,ij_end) +#endif + +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + + call Register_Hallo(zq(1,1,iq),ip1jmp1,llm,2,2,2,2,MyRequest1) + call Register_Hallo(zm(1,1,iq),ip1jmp1,llm,1,1,1,1,MyRequest1) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo + + +c$OMP BARRIER +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + + call SendRequest(MyRequest1) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER +c$OMP BARRIER + do iq=1,nqtot + + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10) then + +#ifdef _ADV_HALLO + call vlx_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu, + & ij_begin+2*iip1,ij_end-2*iip1) +#endif + else if (iadv(iq)==14) then +#ifdef _ADV_HALLO + call vlxqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,qsat, + & ij_begin+2*iip1,ij_end-2*iip1) +#endif + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo +c$OMP BARRIER +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + +! call WaitRecvRequest(MyRequest1) +! call WaitSendRequest(MyRequest1) +c$OMP BARRIER + call WaitRequest(MyRequest1) + + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER +c$OMP BARRIER + + do iq=1,nqtot + + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10) then + + call vly_p(zq(1,1,iq),pente_max,zm(1,1,iq),mv) + + else if (iadv(iq)==14) then + + call vlyqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mv,qsat) + + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo + + + do iq=1,nqtot + + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10 .or. iadv(iq)==14 ) then + +c$OMP BARRIER +#ifdef _ADV_HALLO + call vlz_p(zq(1,1,iq),pente_max,zm(1,1,iq),mw, + & ij_begin,ij_begin+2*iip1-1) + call vlz_p(zq(1,1,iq),pente_max,zm(1,1,iq),mw, + & ij_end-2*iip1+1,ij_end) +#else + call vlz_p(zq(1,1,iq),pente_max,zm(1,1,iq),mw, + & ij_begin,ij_end) +#endif +c$OMP BARRIER + +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + + call Register_Hallo(zq(1,1,iq),ip1jmp1,llm,2,2,2,2,MyRequest2) + call Register_Hallo(zm(1,1,iq),ip1jmp1,llm,1,1,1,1,MyRequest2) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER +c$OMP BARRIER + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo +c$OMP BARRIER + +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + + call SendRequest(MyRequest2) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER + +c$OMP BARRIER + do iq=1,nqtot + + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10 .or. iadv(iq)==14 ) then +c$OMP BARRIER + +#ifdef _ADV_HALLO + call vlz_p(zq(1,1,iq),pente_max,zm(1,1,iq),mw, + & ij_begin+2*iip1,ij_end-2*iip1) +#endif + +c$OMP BARRIER + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo + +c$OMP BARRIER +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + +! call WaitRecvRequest(MyRequest2) +! call WaitSendRequest(MyRequest2) +c$OMP BARRIER + CALL WaitRequest(MyRequest2) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER +c$OMP BARRIER + + + do iq=1,nqtot + + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10) then + + call vly_p(zq(1,1,iq),pente_max,zm(1,1,iq),mv) + + else if (iadv(iq)==14) then + + call vlyqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mv,qsat) + + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo + + do iq=1,nqtot + + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10) then + + call vlx_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu, + & ij_begin,ij_end) + + else if (iadv(iq)==14) then + + call vlxqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,qsat, + & ij_begin,ij_end) + + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo + + + ijb=ij_begin + ije=ij_end +c$OMP BARRIER + + + DO iq=1,nqtot + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije +c print *,'zq-->',ij,l,iq,zq(ij,l,iq) +c print *,'q-->',ij,l,iq,q(ij,l,iq) + q(ij,l,iq)=zq(ij,l,iq) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-iip1+1,iip1 + q(ij+iim,l,iq)=q(ij,l,iq) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ENDDO + + +c$OMP BARRIER + +cc$OMP MASTER +c call WaitSendRequest(MyRequest1) +c call WaitSendRequest(MyRequest2) +cc$OMP END MASTER +cc$OMP BARRIER + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/vlspltqs_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/vlspltqs_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/vlspltqs_p.F (revision 1280) @@ -0,0 +1,940 @@ +! +! $Header$ +! + SUBROUTINE vlspltqs_p ( q,pente_max,masse,w,pbaru,pbarv,pdt, + , p,pk,teta ) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget, F.Codron +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c + test sur humidite specifique: Q advecte< Qsat aval +c (F. Codron, 10/99) +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c pente_max facteur de limitation des pentes: 2 en general +c 0 pour un schema amont +c pbaru,pbarv,w flux de masse en u ,v ,w +c pdt pas de temps +c +c teta temperature potentielle, p pression aux interfaces, +c pk exner au milieu des couches necessaire pour calculer Qsat +c -------------------------------------------------------------------- + USE parallel + USE mod_hallo + USE VAMPIR + IMPLICIT NONE + +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" + +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL q(ip1jmp1,llm) + REAL w(ip1jmp1,llm),pdt + REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii +c + REAL qsat(ip1jmp1,llm) + REAL zm(ip1jmp1,llm) + REAL mu(ip1jmp1,llm) + REAL mv(ip1jm,llm) + REAL mw(ip1jmp1,llm+1) + REAL zq(ip1jmp1,llm) + REAL temps1,temps2,temps3 + REAL zzpbar, zzw + LOGICAL testcpu + SAVE testcpu + SAVE temps1,temps2,temps3 + + REAL qmin,qmax + DATA qmin,qmax/0.,1.e33/ + DATA testcpu/.false./ + DATA temps1,temps2,temps3/0.,0.,0./ + +c--pour rapport de melange saturant-- + + REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play + REAL ptarg,pdelarg,foeew,zdelta + REAL tempe(ip1jmp1) + INTEGER ijb,ije + type(request) :: MyRequest1 + type(request) :: MyRequest2 + +c fonction psat(T) + + FOEEW ( PTARG,PDELARG ) = EXP ( + * (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT) + * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) ) + + r2es = 380.11733 + r3les = 17.269 + r3ies = 21.875 + r4les = 35.86 + r4ies = 7.66 + retv = 0.6077667 + rtt = 273.16 + +c-- Calcul de Qsat en chaque point +c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2 +c pour eviter une exponentielle. + + call SetTag(MyRequest1,100) + call SetTag(MyRequest2,101) + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end + + + DO l = 1, llm + DO ij = ijb, ije + tempe(ij) = teta(ij,l) * pk(ij,l) /cpp + ENDDO + DO ij = ijb, ije + zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) ) + play = 0.5*(p(ij,l)+p(ij,l+1)) + qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play ) + qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) ) + ENDDO + ENDDO + +c PRINT*,'Debut vlsplt version debug sans vlyqs' + + zzpbar = 0.5 * pdt + zzw = pdt + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + + DO l=1,llm + DO ij = ijb,ije + mu(ij,l)=pbaru(ij,l) * zzpbar + ENDDO + ENDDO + + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO l=1,llm + DO ij=ijb,ije + mv(ij,l)=pbarv(ij,l) * zzpbar + ENDDO + ENDDO + + ijb=ij_begin + ije=ij_end + + DO l=1,llm + DO ij=ijb,ije + mw(ij,l)=w(ij,l) * zzw + ENDDO + ENDDO + + DO ij=ijb,ije + mw(ij,llm+1)=0. + ENDDO + +c CALL SCOPY(ijp1llm,q,1,zq,1) +c CALL SCOPY(ijp1llm,masse,1,zm,1) + + ijb=ij_begin + ije=ij_end + zq(ijb:ije,1:llm)=q(ijb:ije,1:llm) + zm(ijb:ije,1:llm)=masse(ijb:ije,1:llm) + + + call vlxqs_p(zq,pente_max,zm,mu,qsat,ij_begin,ij_begin+2*iip1-1) + call vlxqs_p(zq,pente_max,zm,mu,qsat,ij_end-2*iip1+1,ij_end) + + call VTb(VTHallo) + call Register_Hallo(zq,ip1jmp1,llm,2,2,2,2,MyRequest1) + call Register_Hallo(zm,ip1jmp1,llm,1,1,1,1,MyRequest1) + call SendRequest(MyRequest1) + call VTe(VTHallo) + + call vlxqs_p(zq,pente_max,zm,mu,qsat, + . ij_begin+2*iip1,ij_end-2*iip1) + + call VTb(VTHallo) + call WaitRecvRequest(MyRequest1) + call VTe(VTHallo) + + call vlyqs_p(zq,pente_max,zm,mv,qsat) + + call vlz_p(zq,pente_max,zm,mw,ij_begin,ij_begin+2*iip1-1) + call vlz_p(zq,pente_max,zm,mw,ij_end-2*iip1+1,ij_end) + + call VTb(VTHallo) + call Register_Hallo(zq,ip1jmp1,llm,2,2,2,2,MyRequest2) + call Register_Hallo(zm,ip1jmp1,llm,1,1,1,1,MyRequest2) + call SendRequest(MyRequest2) + call VTe(VTHallo) + + call vlz_p(zq,pente_max,zm,mw,ij_begin+2*iip1,ij_end-2*iip1) + + call VTb(VTHallo) + call WaitRecvRequest(MyRequest2) + call VTe(VTHallo) + + call vlyqs_p(zq,pente_max,zm,mv,qsat) + + + call vlxqs_p(zq,pente_max,zm,mu,qsat,ij_begin,ij_end) + + + ijb=ij_begin + ije=ij_end + + DO l=1,llm + DO ij=ijb,ije + q(ij,l)=zq(ij,l) + ENDDO + ENDDO + + DO l=1,llm + DO ij=ijb,ije-iip1+1,iip1 + q(ij+iim,l)=q(ij,l) + ENDDO + ENDDO + + call WaitSendRequest(MyRequest1) + call WaitSendRequest(MyRequest2) + + RETURN + END + SUBROUTINE vlxqs_p(q,pente_max,masse,u_m,qsat,ijb_x,ije_x) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c +c -------------------------------------------------------------------- + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL u_m( ip1jmp1,llm ) + REAL q(ip1jmp1,llm) + REAL qsat(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL new_m,zu_m,zdum(ip1jmp1,llm) + REAL dxq(ip1jmp1,llm),dxqu(ip1jmp1) + REAL zz(ip1jmp1) + REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm) + REAL u_mq(ip1jmp1,llm) + + REAL SSUM + + + INTEGER ijb,ije,ijb_x,ije_x + + +c calcul de la pente a droite et a gauche de la maille + +c ijb=ij_begin +c ije=ij_end + + ijb=ijb_x + ije=ije_x + + if (pole_nord.and.ijb==1) ijb=ijb+iip1 + if (pole_sud.and.ije==ip1jmp1) ije=ije-iip1 + + IF (pente_max.gt.-1.e-5) THEN +c IF (pente_max.gt.10) THEN + +c calcul des pentes avec limitation, Van Leer scheme I: +c ----------------------------------------------------- + +c calcul de la pente aux points u + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij=ijb,ije-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) +c IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0' +c sigu(ij)=u_m(ij,l)/masse(ij,l) + ENDDO + DO ij=ijb+iip1-1,ije,iip1 + dxqu(ij)=dxqu(ij-iim) +c sigu(ij)=sigu(ij-iim) + ENDDO + + DO ij=ijb,ije + adxqu(ij)=abs(dxqu(ij)) + ENDDO + +c calcul de la pente maximum dans la maille en valeur absolue + + DO ij=ijb+1,ije + dxqmax(ij,l)=pente_max* + , min(adxqu(ij-1),adxqu(ij)) +c limitation subtile +c , min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij))) + + + ENDDO + + DO ij=ijb+iip1-1,ije,iip1 + dxqmax(ij-iim,l)=dxqmax(ij,l) + ENDDO + + DO ij=ijb+1,ije +#ifdef CRAY + dxq(ij,l)= + , cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij)) +#else + IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN + dxq(ij,l)=dxqu(ij-1)+dxqu(ij) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF +#endif + dxq(ij,l)=0.5*dxq(ij,l) + dxq(ij,l)= + , sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l)) + ENDDO + + ENDDO ! l=1,llm +c$OMP END DO NOWAIT + + ELSE ! (pente_max.lt.-1.e-5) + +c Pentes produits: +c ---------------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij=ijb,ije-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + ENDDO + DO ij=ijb+iip1-1,ije,iip1 + dxqu(ij)=dxqu(ij-iim) + ENDDO + + DO ij=ijb+1,ije + zz(ij)=dxqu(ij-1)*dxqu(ij) + zz(ij)=zz(ij)+zz(ij) + IF(zz(ij).gt.0) THEN + dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij)) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF + ENDDO + + ENDDO +c$OMP END DO NOWAIT + ENDIF ! (pente_max.lt.-1.e-5) + +c bouclage de la pente en iip1: +c ----------------------------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + dxq(ij-iim,l)=dxq(ij,l) + ENDDO + + DO ij=ijb,ije + iadvplus(ij,l)=0 + ENDDO + + ENDDO +c$OMP END DO NOWAIT + + if (pole_nord) THEN +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + iadvplus(1:iip1,l)=0 + ENDDO +c$OMP END DO NOWAIT + endif + + if (pole_sud) THEN +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + iadvplus(ip1jm+1:ip1jmp1,l)=0 + ENDDO +c$OMP END DO NOWAIT + endif + +c calcul des flux a gauche et a droite + +#ifdef CRAY +c--pas encore modification sur Qsat +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l), + , 1.+u_m(ij,l)/masse(ij+1,l), + , u_m(ij,l)) + zdum(ij,l)=0.5*zdum(ij,l) + u_mq(ij,l)=cvmgp( + , q(ij,l)+zdum(ij,l)*dxq(ij,l), + , q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l), + , u_m(ij,l)) + u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +#else +c on cumule le flux correspondant a toutes les mailles dont la masse +c au travers de la paroi pENDant le pas de temps. +c le rapport de melange de l'air advecte est min(q_vanleer, Qsat_downwind) +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + IF (u_m(ij,l).gt.0.) THEN + zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l) + u_mq(ij,l)=u_m(ij,l)* + $ min(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l)) + ELSE + zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l) + u_mq(ij,l)=u_m(ij,l)* + $ min(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l)) + ENDIF + ENDDO + ENDDO +c$OMP END DO NOWAIT +#endif + + +c detection des points ou on advecte plus que la masse de la +c maille +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + IF(zdum(ij,l).lt.0) THEN + iadvplus(ij,l)=1 + u_mq(ij,l)=0. + ENDIF + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + iadvplus(ij,l)=iadvplus(ij-iim,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + + +c traitement special pour le cas ou on advecte en longitude plus que le +c contenu de la maille. +c cette partie est mal vectorisee. + +c pas d'influence de la pression saturante (pour l'instant) + +c calcul du nombre de maille sur lequel on advecte plus que la maille. + + n0=0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + nl(l)=0 + DO ij=ijb,ije + nl(l)=nl(l)+iadvplus(ij,l) + ENDDO + n0=n0+nl(l) + ENDDO +c$OMP END DO NOWAIT + +cym ATTENTION ICI en OpenMP reduction pas forcement nécessaire +cym IF(n0.gt.1) THEN +cym IF(n0.gt.0) THEN +ccc PRINT*,'Nombre de points pour lesquels on advect plus que le' +ccc & ,'contenu de la maille : ',n0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + IF(nl(l).gt.0) THEN + iju=0 +c indicage des mailles concernees par le traitement special + DO ij=ijb,ije + IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN + iju=iju+1 + indu(iju)=ij + ENDIF + ENDDO + niju=iju +c PRINT*,'niju,nl',niju,nl(l) + +c traitement des mailles + DO iju=1,niju + ij=indu(iju) + j=(ij-1)/iip1+1 + zu_m=u_m(ij,l) + u_mq(ij,l)=0. + IF(zu_m.gt.0.) THEN + ijq=ij + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l) + zu_m=zu_m-masse(ijq,l) + i=mod(i-2+iim,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m* + & (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l)) + ELSE + ijq=ij+1 + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(-zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l) + zu_m=zu_m+masse(ijq,l) + i=mod(i,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)- + & 0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l)) + ENDIF + ENDDO + ENDIF + ENDDO +c$OMP END DO NOWAIT +cym ENDIF ! n0.gt.0 + + + +c bouclage en latitude +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c calcul des tendances +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+1,ije + new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+ + & u_mq(ij-1,l)-u_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + ENDDO +c Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous) + DO ij=ijb+iip1-1,ije,iip1 + q(ij-iim,l)=q(ij,l) + masse(ij-iim,l)=masse(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1) +c CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1) + + + RETURN + END + SUBROUTINE vlyqs_p(q,pente_max,masse,masse_adv_v,qsat) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,masse_adv_v,w sont des arguments d'entree pour le s-pg .... +c qsat est un argument de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL masse_adv_v( ip1jm,llm) + REAL q(ip1jmp1,llm) + REAL qsat(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,ij,l +c + REAL airej2,airejjm,airescb(iim),airesch(iim) + REAL dyq(ip1jmp1,llm),dyqv(ip1jm) + REAL adyqv(ip1jm),dyqmax(ip1jmp1) + REAL qbyv(ip1jm,llm) + + REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs +c REAL newq,oldmasse + Logical first + SAVE first +c$OMP THREADPRIVATE(first) + REAL convpn,convps,convmpn,convmps + REAL sinlon(iip1),sinlondlon(iip1) + REAL coslon(iip1),coslondlon(iip1) + SAVE sinlon,coslon,sinlondlon,coslondlon + SAVE airej2,airejjm +c$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon) +c$OMP THREADPRIVATE(airej2,airejjm) +c +c + REAL SSUM + + DATA first/.true./ + INTEGER ijb,ije + + IF(first) THEN + PRINT*,'Shema Amont nouveau appele dans Vanleer ' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + ENDDO + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + airej2 = SSUM( iim, aire(iip2), 1 ) + airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) + ENDIF + +c + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm +c +c -------------------------------- +c CALCUL EN LATITUDE +c -------------------------------- + +c On commence par calculer la valeur du traceur moyenne sur le premier cercle +c de latitude autour du pole (qpns pour le pole nord et qpsn pour +c le pole nord) qui sera utilisee pour evaluer les pentes au pole. + + if (pole_nord) then + DO i = 1, iim + airescb(i) = aire(i+ iip1) * q(i+ iip1,l) + ENDDO + qpns = SSUM( iim, airescb ,1 ) / airej2 + endif + + if (pole_sud) then + DO i = 1, iim + airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l) + ENDDO + qpsn = SSUM( iim, airesch ,1 ) / airejjm + endif + + +c calcul des pentes aux points v + + ijb=ij_begin-2*iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + adyqv(ij)=abs(dyqv(ij)) + ENDDO + + +c calcul des pentes aux points scalaires + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij)) + dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) + dyqmax(ij)=pente_max*dyqmax(ij) + ENDDO + + IF (pole_nord) THEN + +c calcul des pentes aux poles + DO ij=1,iip1 + dyq(ij,l)=qpns-q(ij+iip1,l) + ENDDO + +c filtrage de la derivee + dyn1=0. + dyn2=0. + DO ij=1,iim + dyn1=dyn1+sinlondlon(ij)*dyq(ij,l) + dyn2=dyn2+coslondlon(ij)*dyq(ij,l) + ENDDO + DO ij=1,iip1 + dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij) + ENDDO + +c calcul des pentes limites aux poles + fn=1. + DO ij=1,iim + IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN + fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn) + ENDIF + ENDDO + + DO ij=1,iip1 + dyq(ij,l)=fn*dyq(ij,l) + ENDDO + + ENDIF + + IF (pole_sud) THEN + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn + ENDDO + + dys1=0. + dys2=0. + + DO ij=1,iim + dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l) + dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l) + ENDDO + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij) + ENDDO + +c calcul des pentes limites aux poles + fs=1. + DO ij=1,iim + IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN + fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs) + ENDIF + ENDDO + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l) + ENDDO + + ENDIF + + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C En memoire de dIFferents tests sur la +C limitation des pentes aux poles. +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C PRINT*,dyq(1) +C PRINT*,dyqv(iip1+1) +C apn=abs(dyq(1)/dyqv(iip1+1)) +C PRINT*,dyq(ip1jm+1) +C PRINT*,dyqv(ip1jm-iip1+1) +C aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) +C DO ij=2,iim +C apn=amax1(abs(dyq(ij)/dyqv(ij)),apn) +C aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps) +C ENDDO +C apn=min(pente_max/apn,1.) +C aps=min(pente_max/aps,1.) +C +C +C cas ou on a un extremum au pole +C +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & apn=0. +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C & aps=0. +C +C limitation des pentes aux poles +C DO ij=1,iip1 +C dyq(ij)=apn*dyq(ij) +C dyq(ip1jm+ij)=aps*dyq(ip1jm+ij) +C ENDDO +C +C test +C DO ij=1,iip1 +C dyq(iip1+ij)=0. +C dyq(ip1jm+ij-iip1)=0. +C ENDDO +C DO ij=1,ip1jmp1 +C dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) +C ENDDO +C +C changement 10 07 96 +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & THEN +C DO ij=1,iip1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=1,iip1 +C dyqmax(ij)=pente_max*abs(dyqv(ij)) +C ENDDO +C ENDIF +C +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C &THEN +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) +C ENDDO +C ENDIF +C fin changement 10 07 96 +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + +c calcul des pentes limitees + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN + dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l)) + ELSE + dyq(ij,l)=0. + ENDIF + ENDDO + + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + IF( masse_adv_v(ij,l).GT.0. ) THEN + qbyv(ij,l)= MIN( qsat(ij+iip1,l), q(ij+iip1,l ) + + , dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l))) + ELSE + qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l) - dyq(ij,l) * + , 0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) ) + ENDIF + qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + newmasse=masse(ij,l) + & +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l)) + & /newmasse + masse(ij,l)=newmasse + ENDDO +c.-. ancienne version + + IF (pole_nord) THEN + + convpn=SSUM(iim,qbyv(1,l),1)/apoln + convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln + DO ij = 1,iip1 + newmasse=masse(ij,l)+convmpn*aire(ij) + q(ij,l)=(q(ij,l)*masse(ij,l)+convpn*aire(ij))/ + & newmasse + masse(ij,l)=newmasse + ENDDO + + ENDIF + + IF (pole_sud) THEN + + convps = -SSUM(iim,qbyv(ip1jm-iim,l),1)/apols + convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols + DO ij = ip1jm+1,ip1jmp1 + newmasse=masse(ij,l)+convmps*aire(ij) + q(ij,l)=(q(ij,l)*masse(ij,l)+convps*aire(ij))/ + & newmasse + masse(ij,l)=newmasse + ENDDO + + ENDIF +c.-. fin ancienne version + +c._. nouvelle version +c convpn=SSUM(iim,qbyv(1,l),1) +c convmpn=ssum(iim,masse_adv_v(1,l),1) +c oldmasse=ssum(iim,masse(1,l),1) +c newmasse=oldmasse+convmpn +c newq=(q(1,l)*oldmasse+convpn)/newmasse +c newmasse=newmasse/apoln +c DO ij = 1,iip1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) +c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) +c oldmasse=ssum(iim,masse(ip1jm-iim,l),1) +c newmasse=oldmasse+convmps +c newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse +c newmasse=newmasse/apols +c DO ij = ip1jm+1,ip1jmp1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c._. fin nouvelle version + ENDDO +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/wrgrads.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/wrgrads.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/wrgrads.F (revision 1280) @@ -0,0 +1,128 @@ +! +! $Header$ +! + subroutine wrgrads(if,nl,field,name,titlevar) + implicit none + +c Declarations +c if indice du fichier +c nl nombre de couches +c field champ +c name petit nom +c titlevar Titre + +#include "gradsdef.h" + +c arguments + integer if,nl + real field(imx*jmx*lmx) + character*10 name,file + character*10 titlevar + +c local + + integer im,jm,lm,i,j,l,lnblnk,iv,iii,iji,iif,ijf + + logical writectl + + + writectl=.false. + + print*,if,iid(if),jid(if),ifd(if),jfd(if) + iii=iid(if) + iji=jid(if) + iif=ifd(if) + ijf=jfd(if) + im=iif-iii+1 + jm=ijf-iji+1 + lm=lmd(if) + + print*,'im,jm,lm,name,firsttime(if)' + print*,im,jm,lm,name,firsttime(if) + + if(firsttime(if)) then + if(name.eq.var(1,if)) then + firsttime(if)=.false. + ivar(if)=1 + print*,'fin de l initialiation de l ecriture du fichier' + print*,file + print*,'fichier no: ',if + print*,'unit ',unit(if) + print*,'nvar ',nvar(if) + print*,'vars ',(var(iv,if),iv=1,nvar(if)) + else + ivar(if)=ivar(if)+1 + nvar(if)=ivar(if) + var(ivar(if),if)=name + tvar(ivar(if),if)=titlevar(1:lnblnk(titlevar)) + nld(ivar(if),if)=nl + print*,'initialisation ecriture de ',var(ivar(if),if) + print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if) + endif + writectl=.true. + itime(if)=1 + else + ivar(if)=mod(ivar(if),nvar(if))+1 + if (ivar(if).eq.nvar(if)) then + writectl=.true. + itime(if)=itime(if)+1 + endif + + if(var(ivar(if),if).ne.name) then + print*,'Il faut stoker la meme succession de champs a chaque' + print*,'pas de temps' + print*,'fichier no: ',if + print*,'unit ',unit(if) + print*,'nvar ',nvar(if) + print*,'vars ',(var(iv,if),iv=1,nvar(if)) + + stop + endif + endif + + print*,'ivar(if),nvar(if),var(ivar(if),if),writectl' + print*,ivar(if),nvar(if),var(ivar(if),if),writectl + do l=1,nl + irec(if)=irec(if)+1 +c print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf, +c s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii +c s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif + write(unit(if)+1,rec=irec(if)) + s ((field((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i) + s ,i=iii,iif),j=iji,ijf) + enddo + if (writectl) then + + file=fichier(if) +c WARNING! on reecrase le fichier .ctl a chaque ecriture + open(unit(if),file=file(1:lnblnk(file))//'.ctl' + & ,form='formatted',status='unknown') + write(unit(if),'(a5,1x,a40)') + & 'DSET ','^'//file(1:lnblnk(file))//'.dat' + + write(unit(if),'(a12)') 'UNDEF 1.0E30' + write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if) + call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF') + call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF') + call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF') + write(unit(if),'(a4,i10,a30)') + & 'TDEF ',itime(if),' LINEAR 02JAN1987 1MO ' + write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if) + do iv=1,nvar(if) +c print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)' +c print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if) + write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if) + & ,99,tvar(iv,if) + enddo + write(unit(if),'(a7)') 'ENDVARS' +c +1000 format(a5,3x,i4,i3,1x,a39) + + close(unit(if)) + + endif ! writectl + + return + + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/write_field_p.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/write_field_p.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/write_field_p.F90 (revision 1280) @@ -0,0 +1,73 @@ +module write_field_p +implicit none + + interface WriteField_p + module procedure Write_field3d_p,Write_Field2d_p,Write_Field1d_p + end interface WriteField_p + + contains + + subroutine write_field1D_p(name,Field) + USE parallel + USE write_field + implicit none + + integer, parameter :: MaxDim=1 + character(len=*) :: name + real, dimension(:) :: Field + real, dimension(:),allocatable :: New_Field + integer, dimension(MaxDim) :: Dim + + + Dim=shape(Field) + allocate(New_Field(Dim(1))) + New_Field(:)=Field(:) + call Gather_Field(New_Field,dim(1),1,0) + + if (MPI_Rank==0) call WriteField(name,New_Field) + + end subroutine write_field1D_p + + subroutine write_field2D_p(name,Field) + USE parallel + USE write_field + implicit none + + integer, parameter :: MaxDim=2 + character(len=*) :: name + real, dimension(:,:) :: Field + real, dimension(:,:),allocatable :: New_Field + integer, dimension(MaxDim) :: Dim + + Dim=shape(Field) + allocate(New_Field(Dim(1),Dim(2))) + New_Field(:,:)=Field(:,:) + call Gather_Field(New_Field(1,1),dim(1)*dim(2),1,0) + + if (MPI_Rank==0) call WriteField(name,New_Field) + + + end subroutine write_field2D_p + + subroutine write_field3D_p(name,Field) + USE parallel + USE write_field + implicit none + + integer, parameter :: MaxDim=3 + character(len=*) :: name + real, dimension(:,:,:) :: Field + real, dimension(:,:,:),allocatable :: New_Field + integer, dimension(MaxDim) :: Dim + + Dim=shape(Field) + allocate(New_Field(Dim(1),Dim(2),Dim(3))) + New_Field(:,:,:)=Field(:,:,:) + call Gather_Field(New_Field(1,1,1),dim(1)*dim(2),dim(3),0) + + if (MPI_Rank==0) call WriteField(name,New_Field) + + end subroutine write_field3D_p + +end module write_field_p + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/write_grads_dyn.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/write_grads_dyn.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/write_grads_dyn.h (revision 1280) @@ -0,0 +1,31 @@ +! +! $Header$ +! + if (callinigrads) then + + string10='dyn' + call inigrads(1,iip1 + s ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi + s ,llm,presnivs,1. + s ,dtvr*iperiod,string10,'dyn_zon ') + + callinigrads=.false. + + + endif + + string10='ps' + CALL wrgrads(1,1,ps,string10,string10) + + string10='u' + CALL wrgrads(1,llm,unat,string10,string10) + string10='v' + CALL wrgrads(1,llm,vnat,string10,string10) + string10='teta' + CALL wrgrads(1,llm,teta,string10,string10) + do iq=1,nqtot + string10='q' + write(string10(2:2),'(i1)') iq + CALL wrgrads(1,llm,q(:,:,iq),string10,string10) + enddo + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/writedynav_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/writedynav_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/writedynav_p.F (revision 1280) @@ -0,0 +1,169 @@ +! +! $Id$ +! + subroutine writedynav_p( histid, time, vcov, + , ucov,teta,ppk,phi,q,masse,ps,phis) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE ioipsl +#endif + USE parallel + USE misc_mod + USE infotrac + implicit none + +C +C Ecriture du fichier histoire au format IOIPSL +C +C Appels succesifs des routines: histwrite +C +C Entree: +C histid: ID du fichier histoire +C time: temps de l'ecriture +C vcov: vents v covariants +C ucov: vents u covariants +C teta: temperature potentielle +C phi : geopotentiel instantane +C q : traceurs +C masse: masse +C ps :pression au sol +C phis : geopotentiel au sol +C +C +C Sortie: +C fileid: ID du fichier netcdf cree +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C +C Arguments +C + + INTEGER histid + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm),phi(ip1jmp1,llm),ppk(ip1jmp1,llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL phis(ip1jmp1) + REAL q(ip1jmp1,llm,nqtot) + integer time + + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + integer ndex2d(iip1*jjp1),ndex3d(iip1*jjp1*llm),iq, ii, ll + real us(ip1jmp1,llm), vs(ip1jmp1,llm) + real tm(ip1jmp1,llm) + REAL vnat(ip1jm,llm),unat(ip1jmp1,llm) + logical ok_sync + integer itau_w + integer :: ijb,ije,jjn +C +C Initialisations +C + if (adjust) return + + ndex3d = 0 + ndex2d = 0 + ok_sync = .TRUE. + us = 999.999 + vs = 999.999 + tm = 999.999 + vnat = 999.999 + unat = 999.999 + itau_w = itau_dyn + time + +C Passage aux composantes naturelles du vent + call covnat_p(llm, ucov, vcov, unat, vnat) + +C +C Appels a histwrite pour l'ecriture des variables a sauvegarder +C +C Vents U scalaire +C + call gr_u_scal_p(llm, unat, us) + + ijb=ij_begin + ije=ij_end + jjn=jj_nb + + call histwrite(histid, 'u', itau_w, us(ijb:ije,:), + . iip1*jjn*llm, ndex3d) +C +C Vents V scalaire +C + + call gr_v_scal_p(llm, vnat, vs) + call histwrite(histid, 'v', itau_w, vs(ijb:ije,:), + . iip1*jjn*llm, ndex3d) +C +C Temperature potentielle moyennee +C + + call histwrite(histid, 'theta', itau_w, teta(ijb:ije,:), + . iip1*jjn*llm, ndex3d) +C +C Temperature moyennee +C + do ll=1,llm + do ii = ijb, ije + tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp + enddo + enddo + + call histwrite(histid, 'temp', itau_w, tm(ijb:ije,:), + . iip1*jjn*llm, ndex3d) +C +C Geopotentiel +C + call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), + . iip1*jjn*llm, ndex3d) +C +C Traceurs +C + DO iq=1,nqtot + call histwrite(histid, ttext(iq), itau_w, q(ijb:ije,:,iq), + . iip1*jjn*llm, ndex3d) + enddo +C +C Masse +C + call histwrite(histid, 'masse', itau_w, masse(ijb:ije,1), + . iip1*jjn, ndex2d) +C +C Pression au sol +C + call histwrite(histid, 'ps', itau_w, ps(ijb:ije), + . iip1*jjn, ndex2d) +C +C Geopotentiel au sol +C + call histwrite(histid, 'phis', itau_w, phis(ijb:ije), + . iip1*jjn, ndex2d) +C +C Fin +C + if (ok_sync) call histsync(histid) +#else + write(lunout,*)'writedynav_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/writehist_p.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/writehist_p.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/dyn3dpar/writehist_p.F (revision 1280) @@ -0,0 +1,156 @@ +! +! $Id$ +! + subroutine writehist_p( histid, histvid, time, vcov, + , ucov,teta,phi,q,masse,ps,phis) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE ioipsl +#endif + USE parallel + USE misc_mod + USE infotrac + implicit none + +C +C Ecriture du fichier histoire au format IOIPSL +C +C Appels succesifs des routines: histwrite +C +C Entree: +C histid: ID du fichier histoire +C histvid:ID du fichier histoire pour les vents V (appele a disparaitre) +C time: temps de l'ecriture +C vcov: vents v covariants +C ucov: vents u covariants +C teta: temperature potentielle +C phi : geopotentiel instantane +C q : traceurs +C masse: masse +C ps :pression au sol +C phis : geopotentiel au sol +C +C +C Sortie: +C fileid: ID du fichier netcdf cree +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C +C Arguments +C + + INTEGER histid, histvid + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm),phi(ip1jmp1,llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL phis(ip1jmp1) + REAL q(ip1jmp1,llm,nqtot) + integer time + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + integer iq, ii, ll + integer ndexu(ip1jmp1*llm),ndexv(ip1jm*llm),ndex2d(ip1jmp1) + logical ok_sync + integer itau_w + integer :: ijb,ije,jjn +C +C Initialisations +C + if (adjust) return + + + ndexu = 0 + ndexv = 0 + ndex2d = 0 + ok_sync =.TRUE. + itau_w = itau_dyn + time +C +C Appels a histwrite pour l'ecriture des variables a sauvegarder +C +C Vents U +C + ijb=ij_begin + ije=ij_end + jjn=jj_nb + + call histwrite(histid, 'ucov', itau_w, ucov(ijb:ije,:), + . iip1*jjn*llm, ndexu) + +C +C Vents V +C + if (pole_sud) ije=ij_end-iip1 + if (pole_sud) jjn=jj_nb-1 + + call histwrite(histvid, 'vcov', itau_w, vcov(ijb:ije,:), + . iip1*jjn*llm, ndexv) + +C +C Temperature potentielle +C + ijb=ij_begin + ije=ij_end + jjn=jj_nb + + call histwrite(histid, 'teta', itau_w, teta(ijb:ije,:), + . iip1*jjn*llm, ndexu) +C +C Geopotentiel +C + call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), + . iip1*jjn*llm, ndexu) +C +C Traceurs +C + DO iq=1,nqtot + call histwrite(histid, ttext(iq), itau_w, q(ijb:ije,:,iq), + . iip1*jjn*llm, ndexu) + enddo +C +C Masse +C + call histwrite(histid, 'masse', itau_w, masse(ijb:ije,1), + . iip1*jjn, ndex2d) +C +C Pression au sol +C + call histwrite(histid, 'ps', itau_w, ps(ijb:ije), + . iip1*jjn, ndex2d) +C +C Geopotentiel au sol +C + call histwrite(histid, 'phis', itau_w, phis(ijb:ije), + . iip1*jjn, ndex2d) +C +C Fin +C + if (ok_sync) then + call histsync(histid) + call histsync(histvid) + endif +#else + write(lunout,*)'writehist_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/acc.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/acc.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/acc.F (revision 1280) @@ -0,0 +1,17 @@ +! +! $Header$ +! + subroutine acc(vec,d,im) + dimension vec(im,im),d(im) + do j=1,im + do i=1,im + d(i)=vec(i,j)*vec(i,j) + enddo + sum=ssum(im,d,1) + sum=sqrt(sum) + do i=1,im + vec(i,j)=vec(i,j)/sum + enddo + enddo + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/coefils.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/coefils.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/coefils.h (revision 1280) @@ -0,0 +1,11 @@ +! +! $Header$ +! + COMMON/coefils/jfiltnu,jfiltsu,jfiltnv,jfiltsv,sddu(iim),sddv(iim)& + & ,unsddu(iim),unsddv(iim),coefilu(iim,jjm),coefilv(iim,jjm), & + & modfrstu(jjm),modfrstv(jjm),eignfnu(iim,iim),eignfnv(iim,iim) & + & ,coefilu2(iim,jjm),coefilv2(iim,jjm) +!c + INTEGER jfiltnu,jfiltsu,jfiltnv,jfiltsv,modfrstu,modfrstv + REAL sddu,sddv,unsddu,unsddv,coefilu,coefilv,eignfnu,eignfnv + REAL coefilu2,coefilv2 Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/eigen.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/eigen.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/eigen.F (revision 1280) @@ -0,0 +1,31 @@ +! +! $Header$ +! + SUBROUTINE eigen( e,d) +#include "dimensions.h" + dimension e( iim,iim ), d( iim ) + dimension asm( iim ) + im=iim +c + DO 48 i = 1,im + asm( i ) = d( im-i+1 ) + 48 CONTINUE + DO 49 i = 1,iim + d( i ) = asm( i ) + 49 CONTINUE +c +c PRINT 70,d + 70 FORMAT(5x,'Valeurs propres',/,8(1x,8f10.4,/),/) + print * +c + DO 51 i = 1,im + DO 52 j = 1,im + asm( j ) = e( i , im-j+1 ) + 52 CONTINUE + DO 50 j = 1,im + e( i,j ) = asm( j ) + 50 CONTINUE + 51 CONTINUE + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/eigen_sort.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/eigen_sort.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/eigen_sort.F (revision 1280) @@ -0,0 +1,32 @@ +! +! $Header$ +! + SUBROUTINE eigen_sort(d,v,n,np) + INTEGER n,np + REAL d(np),v(np,np) + INTEGER i,j,k + REAL p + + DO i=1,n-1 + k=i + p=d(i) + DO j=i+1,n + IF(d(j).ge.p) THEN + k=j + p=d(j) + ENDIF + ENDDO + + IF(k.ne.i) THEN + d(k)=d(i) + d(i)=p + DO j=1,n + p=v(j,i) + v(j,i)=v(j,k) + v(j,k)=p + ENDDO + ENDIF + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/filtreg.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/filtreg.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/filtreg.F (revision 1280) @@ -0,0 +1,319 @@ +! +! $Header$ +! + SUBROUTINE filtreg ( champ, nlat, nbniv, ifiltre,iaire, + & griscal ,iter) + + USE filtreg_mod + + IMPLICIT NONE +c======================================================================= +c +c Auteur: P. Le Van 07/10/97 +c ------ +c +c Objet: filtre matriciel longitudinal ,avec les matrices precalculees +c pour l'operateur Filtre . +c ------ +c +c Arguments: +c ---------- +c +c nblat nombre de latitudes a filtrer +c nbniv nombre de niveaux verticaux a filtrer +c champ(iip1,nblat,nbniv) en entree : champ a filtrer +c en sortie : champ filtre +c ifiltre +1 Transformee directe +c -1 Transformee inverse +c +2 Filtre directe +c -2 Filtre inverse +c +c iaire 1 si champ intensif +c 2 si champ extensif (pondere par les aires) +c +c iter 1 filtre simple +c +c======================================================================= +c +c +c Variable Intensive +c ifiltre = 1 filtre directe +c ifiltre =-1 filtre inverse +c +c Variable Extensive +c ifiltre = 2 filtre directe +c ifiltre =-2 filtre inverse +c +c +#include "dimensions.h" +#include "paramet.h" +#include "coefils.h" + + INTEGER nlat,nbniv,ifiltre,iter + INTEGER i,j,l,k + INTEGER iim2,immjm + INTEGER jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil + + REAL champ( iip1,nlat,nbniv) + + REAL eignq(iim,nlat,nbniv), sdd1(iim),sdd2(iim) + LOGICAL griscal + INTEGER hemisph, iaire + + LOGICAL,SAVE :: first=.TRUE. + + REAL, SAVE :: sdd12(iim,4) + + INTEGER, PARAMETER :: type_sddu=1 + INTEGER, PARAMETER :: type_sddv=2 + INTEGER, PARAMETER :: type_unsddu=3 + INTEGER, PARAMETER :: type_unsddv=4 + + INTEGER :: sdd1_type, sdd2_type + + IF (first) THEN + sdd12(1:iim,type_sddu) = sddu(1:iim) + sdd12(1:iim,type_sddv) = sddv(1:iim) + sdd12(1:iim,type_unsddu) = unsddu(1:iim) + sdd12(1:iim,type_unsddv) = unsddv(1:iim) + + first=.FALSE. + ENDIF + + IF(ifiltre.EQ.1.or.ifiltre.EQ.-1) + & STOP'Pas de transformee simple dans cette version' + + IF( iter.EQ. 2 ) THEN + PRINT *,' Pas d iteration du filtre dans cette version !' + & , ' Utiliser old_filtreg et repasser !' + STOP + ENDIF + + IF( ifiltre.EQ. -2 .AND..NOT.griscal ) THEN + PRINT *,' Cette routine ne calcule le filtre inverse que ' + & , ' sur la grille des scalaires !' + STOP + ENDIF + + IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 ) THEN + PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2' + & , ' corriger et repasser !' + STOP + ENDIF + + iim2 = iim * iim + immjm = iim * jjm + + IF( griscal ) THEN + IF( nlat. NE. jjp1 ) THEN + PRINT 1111 + STOP + ELSE + + IF( iaire.EQ.1 ) THEN + sdd1_type = type_sddv + sdd2_type = type_unsddv + ELSE + sdd1_type = type_unsddv + sdd2_type = type_sddv + ENDIF + +c IF( iaire.EQ.1 ) THEN +c CALL SCOPY( iim, sddv, 1, sdd1, 1 ) +c CALL SCOPY( iim, unsddv, 1, sdd2, 1 ) +c ELSE +c CALL SCOPY( iim, unsddv, 1, sdd1, 1 ) +c CALL SCOPY( iim, sddv, 1, sdd2, 1 ) +c END IF + + jdfil1 = 2 + jffil1 = jfiltnu + jdfil2 = jfiltsu + jffil2 = jjm + END IF + ELSE + IF( nlat.NE.jjm ) THEN + PRINT 2222 + STOP + ELSE + + IF( iaire.EQ.1 ) THEN + sdd1_type = type_sddu + sdd2_type = type_unsddu + ELSE + sdd1_type = type_unsddu + sdd2_type = type_sddu + ENDIF + +c IF( iaire.EQ.1 ) THEN +c CALL SCOPY( iim, sddu, 1, sdd1, 1 ) +c CALL SCOPY( iim, unsddu, 1, sdd2, 1 ) +c ELSE +c CALL SCOPY( iim, unsddu, 1, sdd1, 1 ) +c CALL SCOPY( iim, sddu, 1, sdd2, 1 ) +c END IF + + jdfil1 = 1 + jffil1 = jfiltnv + jdfil2 = jfiltsv + jffil2 = jjm + END IF + END IF + + DO hemisph = 1, 2 + + IF ( hemisph.EQ.1 ) THEN + jdfil = jdfil1 + jffil = jffil1 + ELSE + jdfil = jdfil2 + jffil = jffil2 + END IF + + DO l = 1, nbniv + DO j = jdfil,jffil + DO i = 1, iim + champ(i,j,l) = champ(i,j,l) * sdd12(i,sdd1_type) ! sdd1(i) + END DO + END DO + END DO + + IF( hemisph. EQ. 1 ) THEN + + IF( ifiltre. EQ. -2 ) THEN + + DO j = jdfil,jffil +#ifdef BLAS + CALL DGEMM("N", "N", iim, nbniv, iim, 1.0, + & matrinvn(1,1,j), + & iim, champ(1,j,1), iip1*nlat, 0.0, + & eignq(1,j-jdfil+1,1), iim*nlat) +#else + eignq(:,j-jdfil+1,:) + $ = matmul(matrinvn(:,:,j), champ(:iim,j,:)) +#endif + END DO + + ELSE IF ( griscal ) THEN + + DO j = jdfil,jffil +#ifdef BLAS + CALL DGEMM("N", "N", iim, nbniv, iim, 1.0, + & matriceun(1,1,j), + & iim, champ(1,j,1), iip1*nlat, 0.0, + & eignq(1,j-jdfil+1,1), iim*nlat) +#else + eignq(:,j-jdfil+1,:) + $ = matmul(matriceun(:,:,j), champ(:iim,j,:)) +#endif + END DO + + ELSE + + DO j = jdfil,jffil +#ifdef BLAS + CALL DGEMM("N", "N", iim, nbniv, iim, 1.0, + & matricevn(1,1,j), + & iim, champ(1,j,1), iip1*nlat, 0.0, + & eignq(1,j-jdfil+1,1), iim*nlat) +#else + eignq(:,j-jdfil+1,:) + $ = matmul(matricevn(:,:,j), champ(:iim,j,:)) +#endif + END DO + + ENDIF + + ELSE + + IF( ifiltre. EQ. -2 ) THEN + + DO j = jdfil,jffil +#ifdef BLAS + CALL DGEMM("N", "N", iim, nbniv, iim, 1.0, + & matrinvs(1,1,j-jfiltsu+1), + & iim, champ(1,j,1), iip1*nlat, 0.0, + & eignq(1,j-jdfil+1,1), iim*nlat) +#else + eignq(:,j-jdfil+1,:) + $ = matmul(matrinvs(:,:,j-jfiltsu+1), + $ champ(:iim,j,:)) +#endif + END DO + + + ELSE IF ( griscal ) THEN + + DO j = jdfil,jffil +#ifdef BLAS + CALL DGEMM("N", "N", iim, nbniv, iim, 1.0, + & matriceus(1,1,j-jfiltsu+1), + & iim, champ(1,j,1), iip1*nlat, 0.0, + & eignq(1,j-jdfil+1,1), iim*nlat) +#else + eignq(:,j-jdfil+1,:) + $ = matmul(matriceus(:,:,j-jfiltsu+1), + $ champ(:iim,j,:)) +#endif + END DO + + ELSE + + DO j = jdfil,jffil +#ifdef BLAS + CALL DGEMM("N", "N", iim, nbniv, iim, 1.0, + & matricevs(1,1,j-jfiltsv+1), + & iim, champ(1,j,1), iip1*nlat, 0.0, + & eignq(1,j-jdfil+1,1), iim*nlat) +#else + eignq(:,j-jdfil+1,:) + $ = matmul(matricevs(:,:,j-jfiltsv+1), + $ champ(:iim,j,:)) +#endif + END DO + + ENDIF + + ENDIF + + IF( ifiltre.EQ. 2 ) THEN + + DO l = 1, nbniv + DO j = jdfil,jffil + DO i = 1, iim + champ( i,j,l ) = + & (champ(i,j,l) + eignq(i,j-jdfil+1,l)) + & * sdd12(i,sdd2_type) ! sdd2(i) + END DO + END DO + END DO + + ELSE + + DO l = 1, nbniv + DO j = jdfil,jffil + DO i = 1, iim + champ( i,j,l ) = + & (champ(i,j,l) - eignq(i,j-jdfil+1,l)) + & * sdd12(i,sdd2_type) ! sdd2(i) + END DO + END DO + END DO + + ENDIF + + DO l = 1, nbniv + DO j = jdfil,jffil + champ( iip1,j,l ) = champ( 1,j,l ) + END DO + END DO + + + ENDDO + +1111 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a + & filtrer, sur la grille des scalaires'/) +2222 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi + & ltrer, sur la grille de V ou de Z'/) + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/filtreg_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/filtreg_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/filtreg_mod.F90 (revision 1280) @@ -0,0 +1,536 @@ +MODULE filtreg_mod + + REAL, DIMENSION(:,:,:), ALLOCATABLE :: matriceun,matriceus,matricevn + REAL, DIMENSION(:,:,:), ALLOCATABLE :: matricevs,matrinvn,matrinvs + +CONTAINS + + SUBROUTINE inifilr + USE mod_filtre_fft + ! + ! ... H. Upadhyaya, O.Sharma ... + ! + IMPLICIT NONE + ! + ! version 3 ..... + + ! Correction le 28/10/97 P. Le Van . + ! ------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" + ! ------------------------------------------------------------------- +#include "comgeom.h" +#include "coefils.h" +#include "logic.h" +#include "serre.h" + + REAL dlonu(iim),dlatu(jjm) + REAL rlamda( iim ), eignvl( iim ) + ! + + REAL lamdamax,pi,cof + INTEGER i,j,modemax,imx,k,kf,ii + REAL dymin,dxmin,colat0 + REAL eignft(iim,iim), coff + + LOGICAL, SAVE :: first_call_inifilr = .TRUE. + +#ifdef CRAY + INTEGER ISMIN + EXTERNAL ISMIN + INTEGER iymin + INTEGER ixmineq +#endif + EXTERNAL inifgn + ! + ! ------------------------------------------------------------ + ! This routine computes the eigenfunctions of the laplacien + ! on the stretched grid, and the filtering coefficients + ! + ! We designate: + ! eignfn eigenfunctions of the discrete laplacien + ! eigenvl eigenvalues + ! jfiltn indexof the last scalar line filtered in NH + ! jfilts index of the first line filtered in SH + ! modfrst index of the mode from WHERE modes are filtered + ! modemax maximum number of modes ( im ) + ! coefil filtering coefficients ( lamda_max*COS(rlat)/lamda ) + ! sdd SQRT( dx ) + ! + ! the modes are filtered from modfrst to modemax + ! + !----------------------------------------------------------- + ! + + pi = 2. * ASIN( 1. ) + + DO i = 1,iim + dlonu(i) = xprimu( i ) + ENDDO + ! + CALL inifgn(eignvl) + ! + PRINT *,' EIGNVL ' + PRINT 250,eignvl +250 FORMAT( 1x,5e13.6) + ! + ! compute eigenvalues and eigenfunctions + ! + ! + !................................................................. + ! + ! compute the filtering coefficients for scalar lines and + ! meridional wind v-lines + ! + ! we filter all those latitude lines WHERE coefil < 1 + ! NO FILTERING AT POLES + ! + ! colat0 is to be used when alpha (stretching coefficient) + ! is set equal to zero for the regular grid CASE + ! + ! ....... Calcul de colat0 ......... + ! ..... colat0 = minimum de ( 0.5, min dy/ min dx ) ... + ! + ! + DO j = 1,jjm + dlatu( j ) = rlatu( j ) - rlatu( j+1 ) + ENDDO + ! +#ifdef CRAY + iymin = ISMIN( jjm, dlatu, 1 ) + ixmineq = ISMIN( iim, dlonu, 1 ) + dymin = dlatu( iymin ) + dxmin = dlonu( ixmineq ) +#else + dxmin = dlonu(1) + DO i = 2, iim + dxmin = MIN( dxmin,dlonu(i) ) + ENDDO + dymin = dlatu(1) + DO j = 2, jjm + dymin = MIN( dymin,dlatu(j) ) + ENDDO +#endif + ! + ! + colat0 = MIN( 0.5, dymin/dxmin ) + ! + IF( .NOT.fxyhypb.AND.ysinus ) THEN + colat0 = 0.6 + ! ...... a revoir pour ysinus ! ....... + alphax = 0. + ENDIF + ! + PRINT 50, colat0,alphax +50 FORMAT(/15x,' Inifilr colat0 alphax ',2e16.7) + ! + IF(alphax.EQ.1. ) THEN + PRINT *,' Inifilr alphax doit etre < a 1. Corriger ' + STOP + ENDIF + ! + lamdamax = iim / ( pi * colat0 * ( 1. - alphax ) ) + + ! ... Correction le 28/10/97 ( P.Le Van ) .. + ! + DO i = 2,iim + rlamda( i ) = lamdamax/ SQRT( ABS( eignvl(i) ) ) + ENDDO + ! + + DO j = 1,jjm + DO i = 1,iim + coefilu( i,j ) = 0.0 + coefilv( i,j ) = 0.0 + coefilu2( i,j ) = 0.0 + coefilv2( i,j ) = 0.0 + ENDDO + ENDDO + + ! + ! ... Determination de jfiltnu,jfiltnv,jfiltsu,jfiltsv .... + ! ......................................................... + ! + modemax = iim + +!!!! imx = modemax - 4 * (modemax/iim) + + imx = iim + ! + PRINT *,' TRUNCATION AT ',imx + ! + DO j = 2, jjm/2+1 + cof = COS( rlatu(j) )/ colat0 + IF ( cof .LT. 1. ) THEN + IF( rlamda(imx) * COS(rlatu(j) ).LT.1. ) jfiltnu= j + ENDIF + + cof = COS( rlatu(jjp1-j+1) )/ colat0 + IF ( cof .LT. 1. ) THEN + IF( rlamda(imx) * COS(rlatu(jjp1-j+1) ).LT.1. ) & + jfiltsu= jjp1-j+1 + ENDIF + ENDDO + ! + DO j = 1, jjm/2 + cof = COS( rlatv(j) )/ colat0 + IF ( cof .LT. 1. ) THEN + IF( rlamda(imx) * COS(rlatv(j) ).LT.1. ) jfiltnv= j + ENDIF + + cof = COS( rlatv(jjm-j+1) )/ colat0 + IF ( cof .LT. 1. ) THEN + IF( rlamda(imx) * COS(rlatv(jjm-j+1) ).LT.1. ) & + jfiltsv= jjm-j+1 + ENDIF + ENDDO + ! + + IF ( jfiltnu.LE.0 ) jfiltnu=1 + IF( jfiltnu.GT. jjm/2 +1 ) THEN + PRINT *,' jfiltnu en dehors des valeurs acceptables ' ,jfiltnu + STOP + ENDIF + + IF( jfiltsu.LE.0) jfiltsu=1 + IF( jfiltsu.GT. jjm +1 ) THEN + PRINT *,' jfiltsu en dehors des valeurs acceptables ' ,jfiltsu + STOP + ENDIF + + IF( jfiltnv.LE.0) jfiltnv=1 + IF( jfiltnv.GT. jjm/2 ) THEN + PRINT *,' jfiltnv en dehors des valeurs acceptables ' ,jfiltnv + STOP + ENDIF + + IF( jfiltsv.LE.0) jfiltsv=1 + IF( jfiltsv.GT. jjm ) THEN + PRINT *,' jfiltsv en dehors des valeurs acceptables ' ,jfiltsv + STOP + ENDIF + + PRINT *,' jfiltnv jfiltsv jfiltnu jfiltsu ' , & + jfiltnv,jfiltsv,jfiltnu,jfiltsu + + IF(first_call_inifilr) THEN + ALLOCATE(matriceun(iim,iim,jfiltnu)) + ALLOCATE(matriceus(iim,iim,jfiltsu)) + ALLOCATE(matricevn(iim,iim,jfiltnv)) + ALLOCATE(matricevs(iim,iim,jfiltsv)) + ALLOCATE( matrinvn(iim,iim,jfiltnu)) + ALLOCATE( matrinvs(iim,iim,jfiltsu)) + first_call_inifilr = .FALSE. + ENDIF + + ! + ! ... Determination de coefilu,coefilv,n=modfrstu,modfrstv .... + !................................................................ + ! + ! + DO j = 1,jjm + modfrstu( j ) = iim + modfrstv( j ) = iim + ENDDO + ! + DO j = 2,jfiltnu + DO k = 2,modemax + cof = rlamda(k) * COS( rlatu(j) ) + IF ( cof .LT. 1. ) GOTO 82 + ENDDO + GOTO 84 +82 modfrstu( j ) = k + ! + kf = modfrstu( j ) + DO k = kf , modemax + cof = rlamda(k) * COS( rlatu(j) ) + coefilu(k,j) = cof - 1. + coefilu2(k,j) = cof*cof - 1. + ENDDO +84 CONTINUE + ENDDO + ! + ! + DO j = 1,jfiltnv + ! + DO k = 2,modemax + cof = rlamda(k) * COS( rlatv(j) ) + IF ( cof .LT. 1. ) GOTO 87 + ENDDO + GOTO 89 +87 modfrstv( j ) = k + ! + kf = modfrstv( j ) + DO k = kf , modemax + cof = rlamda(k) * COS( rlatv(j) ) + coefilv(k,j) = cof - 1. + coefilv2(k,j) = cof*cof - 1. + ENDDO +89 CONTINUE + ENDDO + ! + DO j = jfiltsu,jjm + DO k = 2,modemax + cof = rlamda(k) * COS( rlatu(j) ) + IF ( cof .LT. 1. ) GOTO 92 + ENDDO + GOTO 94 +92 modfrstu( j ) = k + ! + kf = modfrstu( j ) + DO k = kf , modemax + cof = rlamda(k) * COS( rlatu(j) ) + coefilu(k,j) = cof - 1. + coefilu2(k,j) = cof*cof - 1. + ENDDO +94 CONTINUE + ENDDO + ! + DO j = jfiltsv,jjm + DO k = 2,modemax + cof = rlamda(k) * COS( rlatv(j) ) + IF ( cof .LT. 1. ) GOTO 97 + ENDDO + GOTO 99 +97 modfrstv( j ) = k + ! + kf = modfrstv( j ) + DO k = kf , modemax + cof = rlamda(k) * COS( rlatv(j) ) + coefilv(k,j) = cof - 1. + coefilv2(k,j) = cof*cof - 1. + ENDDO +99 CONTINUE + ENDDO + ! + + IF(jfiltnv.GE.jjm/2 .OR. jfiltnu.GE.jjm/2)THEN + + IF(jfiltnv.EQ.jfiltsv)jfiltsv=1+jfiltnv + IF(jfiltnu.EQ.jfiltsu)jfiltsu=1+jfiltnu + + PRINT *,'jfiltnv jfiltsv jfiltnu jfiltsu' , & + jfiltnv,jfiltsv,jfiltnu,jfiltsu + ENDIF + + PRINT *,' Modes premiers v ' + PRINT 334,modfrstv + PRINT *,' Modes premiers u ' + PRINT 334,modfrstu + + ! + ! ................................................................... + ! + ! ... Calcul de la matrice filtre 'matriceu' pour les champs situes + ! sur la grille scalaire ........ + ! ................................................................... + ! + DO j = 2, jfiltnu + + DO i=1,iim + coff = coefilu(i,j) + IF( i.LT.modfrstu(j) ) coff = 0. + DO k=1,iim + eignft(i,k) = eignfnv(k,i) * coff + ENDDO + ENDDO +#ifdef CRAY + CALL MXM( eignfnv,iim,eignft,iim,matriceun(1,1,j),iim ) +#else +#ifdef BLAS + CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, & + eignfnv, iim, eignft, iim, 0.0, matriceun(1,1,j), iim) +#else + DO k = 1, iim + DO i = 1, iim + matriceun(i,k,j) = 0.0 + DO ii = 1, iim + matriceun(i,k,j) = matriceun(i,k,j) & + + eignfnv(i,ii)*eignft(ii,k) + ENDDO + ENDDO + ENDDO +#endif +#endif + + ENDDO + + DO j = jfiltsu, jjm + + DO i=1,iim + coff = coefilu(i,j) + IF( i.LT.modfrstu(j) ) coff = 0. + DO k=1,iim + eignft(i,k) = eignfnv(k,i) * coff + ENDDO + ENDDO +#ifdef CRAY + CALL MXM(eignfnv,iim,eignft,iim,matriceus(1,1,j-jfiltsu+1),iim) +#else +#ifdef BLAS + CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, & + eignfnv, iim, eignft, iim, 0.0, & + matriceus(1,1,j-jfiltsu+1), iim) +#else + DO k = 1, iim + DO i = 1, iim + matriceus(i,k,j-jfiltsu+1) = 0.0 + DO ii = 1, iim + matriceus(i,k,j-jfiltsu+1) = matriceus(i,k,j-jfiltsu+1) & + + eignfnv(i,ii)*eignft(ii,k) + ENDDO + ENDDO + ENDDO +#endif +#endif + + ENDDO + + ! ................................................................... + ! + ! ... Calcul de la matrice filtre 'matricev' pour les champs situes + ! sur la grille de V ou de Z ........ + ! ................................................................... + ! + DO j = 1, jfiltnv + + DO i = 1, iim + coff = coefilv(i,j) + IF( i.LT.modfrstv(j) ) coff = 0. + DO k = 1, iim + eignft(i,k) = eignfnu(k,i) * coff + ENDDO + ENDDO +#ifdef CRAY + CALL MXM( eignfnu,iim,eignft,iim,matricevn(1,1,j),iim ) +#else +#ifdef BLAS + CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, & + eignfnu, iim, eignft, iim, 0.0, matricevn(1,1,j), iim) +#else + DO k = 1, iim + DO i = 1, iim + matricevn(i,k,j) = 0.0 + DO ii = 1, iim + matricevn(i,k,j) = matricevn(i,k,j) & + + eignfnu(i,ii)*eignft(ii,k) + ENDDO + ENDDO + ENDDO +#endif +#endif + + ENDDO + + DO j = jfiltsv, jjm + + DO i = 1, iim + coff = coefilv(i,j) + IF( i.LT.modfrstv(j) ) coff = 0. + DO k = 1, iim + eignft(i,k) = eignfnu(k,i) * coff + ENDDO + ENDDO +#ifdef CRAY + CALL MXM(eignfnu,iim,eignft,iim,matricevs(1,1,j-jfiltsv+1),iim) +#else +#ifdef BLAS + CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, & + eignfnu, iim, eignft, iim, 0.0, & + matricevs(1,1,j-jfiltsv+1), iim) +#else + DO k = 1, iim + DO i = 1, iim + matricevs(i,k,j-jfiltsv+1) = 0.0 + DO ii = 1, iim + matricevs(i,k,j-jfiltsv+1) = matricevs(i,k,j-jfiltsv+1) & + + eignfnu(i,ii)*eignft(ii,k) + ENDDO + ENDDO + ENDDO +#endif +#endif + + ENDDO + + ! ................................................................... + ! + ! ... Calcul de la matrice filtre 'matrinv' pour les champs situes + ! sur la grille scalaire , pour le filtre inverse ........ + ! ................................................................... + ! + DO j = 2, jfiltnu + + DO i = 1,iim + coff = coefilu(i,j)/ ( 1. + coefilu(i,j) ) + IF( i.LT.modfrstu(j) ) coff = 0. + DO k=1,iim + eignft(i,k) = eignfnv(k,i) * coff + ENDDO + ENDDO +#ifdef CRAY + CALL MXM( eignfnv,iim,eignft,iim,matrinvn(1,1,j),iim ) +#else +#ifdef BLAS + CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, & + eignfnv, iim, eignft, iim, 0.0, matrinvn(1,1,j), iim) +#else + DO k = 1, iim + DO i = 1, iim + matrinvn(i,k,j) = 0.0 + DO ii = 1, iim + matrinvn(i,k,j) = matrinvn(i,k,j) & + + eignfnv(i,ii)*eignft(ii,k) + ENDDO + ENDDO + ENDDO +#endif +#endif + + ENDDO + + DO j = jfiltsu, jjm + + DO i = 1,iim + coff = coefilu(i,j) / ( 1. + coefilu(i,j) ) + IF( i.LT.modfrstu(j) ) coff = 0. + DO k=1,iim + eignft(i,k) = eignfnv(k,i) * coff + ENDDO + ENDDO +#ifdef CRAY + CALL MXM(eignfnv,iim,eignft,iim,matrinvs(1,1,j-jfiltsu+1),iim) +#else +#ifdef BLAS + CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, & + eignfnv, iim, eignft, iim, 0.0, matrinvs(1,1,j-jfiltsu+1), iim) +#else + DO k = 1, iim + DO i = 1, iim + matrinvs(i,k,j-jfiltsu+1) = 0.0 + DO ii = 1, iim + matrinvs(i,k,j-jfiltsu+1) = matrinvs(i,k,j-jfiltsu+1) & + + eignfnv(i,ii)*eignft(ii,k) + ENDDO + ENDDO + ENDDO +#endif +#endif + + ENDDO + + IF (use_filtre_fft) THEN + CALL Init_filtre_fft(coefilu,modfrstu,jfiltnu,jfiltsu, & + coefilv,modfrstv,jfiltnv,jfiltsv) + ENDIF + + ! ................................................................... + + ! +334 FORMAT(1x,24i3) +755 FORMAT(1x,6f10.3,i3) + + RETURN + END SUBROUTINE inifilr + +END MODULE filtreg_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/inifgn.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/inifgn.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/inifgn.F (revision 1280) @@ -0,0 +1,106 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/filtrez/inifgn.F,v 1.1.1.1 2004-05-19 12:53:09 lmdzadmin Exp $ +! + SUBROUTINE inifgn(dv) +c +c ... H.Upadyaya , O.Sharma ... +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "serre.h" + +c + REAL vec(iim,iim),vec1(iim,iim) + REAL dlonu(iim),dlonv(iim) + REAL du(iim),dv(iim),d(iim) + REAL pi + INTEGER i,j,k,imm1,nrot +C +#include "coefils.h" +c + EXTERNAL SSUM, acc,eigen,jacobi + REAL SSUM +c + + imm1 = iim -1 + pi = 2.* ASIN(1.) +C + DO 5 i=1,iim + dlonu(i)= xprimu( i ) + dlonv(i)= xprimv( i ) + 5 CONTINUE + + DO 12 i=1,iim + sddv(i) = SQRT(dlonv(i)) + sddu(i) = SQRT(dlonu(i)) + unsddu(i) = 1./sddu(i) + unsddv(i) = 1./sddv(i) + 12 CONTINUE +C + DO 17 j=1,iim + DO 17 i=1,iim + vec(i,j) = 0. + vec1(i,j) = 0. + eignfnv(i,j) = 0. + eignfnu(i,j) = 0. + 17 CONTINUE +c +c + eignfnv(1,1) = -1. + eignfnv(iim,1) = 1. + DO 20 i=1,imm1 + eignfnv(i+1,i+1)= -1. + eignfnv(i,i+1) = 1. + 20 CONTINUE + DO 25 j=1,iim + DO 25 i=1,iim + eignfnv(i,j) = eignfnv(i,j)/(sddu(i)*sddv(j)) + 25 CONTINUE + DO 30 j=1,iim + DO 30 i=1,iim + eignfnu(i,j) = -eignfnv(j,i) + 30 CONTINUE +c +#ifdef CRAY + CALL MXM(eignfnu,iim,eignfnv,iim,vec ,iim) + CALL MXM(eignfnv,iim,eignfnu,iim,vec1,iim) +#else + DO j = 1, iim + DO i = 1, iim + vec (i,j) = 0.0 + vec1(i,j) = 0.0 + DO k = 1, iim + vec (i,j) = vec(i,j) + eignfnu(i,k) * eignfnv(k,j) + vec1(i,j) = vec1(i,j) + eignfnv(i,k) * eignfnu(k,j) + ENDDO + ENDDO + ENDDO +#endif + +c + CALL jacobi(vec,iim,iim,dv,eignfnv,nrot) + CALL acc(eignfnv,d,iim) + CALL eigen_sort(dv,eignfnv,iim,iim) +c + CALL jacobi(vec1,iim,iim,du,eignfnu,nrot) + CALL acc(eignfnu,d,iim) + CALL eigen_sort(du,eignfnu,iim,iim) + +cc ancienne version avec appels IMSL +c +c CALL MXM(eignfnu,iim,eignfnv,iim,vec,iim) +c CALL MXM(eignfnv,iim,eignfnu,iim,vec1,iim) +c CALL EVCSF(iim,vec,iim,dv,eignfnv,iim) +c CALL acc(eignfnv,d,iim) +c CALL eigen(eignfnv,dv) +c +c CALL EVCSF(iim,vec1,iim,du,eignfnu,iim) +c CALL acc(eignfnu,d,iim) +c CALL eigen(eignfnu,du) + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/jacobi.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/jacobi.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/jacobi.F (revision 1280) @@ -0,0 +1,97 @@ +! +! $Header$ +! + SUBROUTINE JACOBI(A,N,NP,D,V,NROT) + PARAMETER (NMAX=400) + DIMENSION A(NP,NP),D(NP),V(NP,NP),B(NMAX),Z(NMAX) + IF (n.gt.nmax) THEN + print*, 'n, nmax=', n, nmax + print*, 'Surdimensionnement insuffisant dans jacobi' + CALL abort + ENDIF + DO 12 IP=1,N + DO 11 IQ=1,N + V(IP,IQ)=0. +11 CONTINUE + V(IP,IP)=1. +12 CONTINUE + DO 13 IP=1,N + B(IP)=A(IP,IP) + D(IP)=B(IP) + Z(IP)=0. +13 CONTINUE + NROT=0 + DO 24 I=1,50 + SM=0. + DO 15 IP=1,N-1 + DO 14 IQ=IP+1,N + SM=SM+ABS(A(IP,IQ)) +14 CONTINUE +15 CONTINUE + IF(SM.EQ.0.)RETURN + IF(I.LT.4)THEN + TRESH=0.2*SM/N**2 + ELSE + TRESH=0. + ENDIF + DO 22 IP=1,N-1 + DO 21 IQ=IP+1,N + G=100.*ABS(A(IP,IQ)) + IF((I.GT.4).AND.(ABS(D(IP))+G.EQ.ABS(D(IP))) + * .AND.(ABS(D(IQ))+G.EQ.ABS(D(IQ))))THEN + A(IP,IQ)=0. + ELSE IF(ABS(A(IP,IQ)).GT.TRESH)THEN + H=D(IQ)-D(IP) + IF(ABS(H)+G.EQ.ABS(H))THEN + T=A(IP,IQ)/H + ELSE + THETA=0.5*H/A(IP,IQ) + T=1./(ABS(THETA)+SQRT(1.+THETA**2)) + IF(THETA.LT.0.)T=-T + ENDIF + C=1./SQRT(1+T**2) + S=T*C + TAU=S/(1.+C) + H=T*A(IP,IQ) + Z(IP)=Z(IP)-H + Z(IQ)=Z(IQ)+H + D(IP)=D(IP)-H + D(IQ)=D(IQ)+H + A(IP,IQ)=0. + DO 16 J=1,IP-1 + G=A(J,IP) + H=A(J,IQ) + A(J,IP)=G-S*(H+G*TAU) + A(J,IQ)=H+S*(G-H*TAU) +16 CONTINUE + DO 17 J=IP+1,IQ-1 + G=A(IP,J) + H=A(J,IQ) + A(IP,J)=G-S*(H+G*TAU) + A(J,IQ)=H+S*(G-H*TAU) +17 CONTINUE + DO 18 J=IQ+1,N + G=A(IP,J) + H=A(IQ,J) + A(IP,J)=G-S*(H+G*TAU) + A(IQ,J)=H+S*(G-H*TAU) +18 CONTINUE + DO 19 J=1,N + G=V(J,IP) + H=V(J,IQ) + V(J,IP)=G-S*(H+G*TAU) + V(J,IQ)=H+S*(G-H*TAU) +19 CONTINUE + NROT=NROT+1 + ENDIF +21 CONTINUE +22 CONTINUE + DO 23 IP=1,N + B(IP)=B(IP)+Z(IP) + D(IP)=B(IP) + Z(IP)=0. +23 CONTINUE +24 CONTINUE + STOP '50 iterations should never happen' + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_fft.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_fft.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_fft.F90 (revision 1280) @@ -0,0 +1,13 @@ +MODULE mod_fft + +#ifdef FFT_MATHKEISAN + USE mod_fft_mathkeisan +#elif FFT_FFTW + USE mod_fft_fftw +#elif FFT_MKL + USE mod_fft_mkl +#else + USE mod_fft_wrapper +#endif + +END MODULE mod_fft Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_fft_fftw.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_fft_fftw.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_fft_fftw.F90 (revision 1280) @@ -0,0 +1,74 @@ +MODULE mod_fft_fftw + +#ifdef FFT_FFTW + + REAL,SAVE,ALLOCATABLE :: Table_forward(:) + REAL,SAVE,ALLOCATABLE :: Table_backward(:) + REAL,SAVE :: scale_factor + INTEGER,SAVE :: vsize + INTEGER,PARAMETER :: inc=1 + + INTEGER,SAVE :: plan_forward + INTEGER,SAVE :: plan_backward + +CONTAINS + + SUBROUTINE Init_fft(iim) + IMPLICIT NONE +#include + INTEGER :: iim + REAL :: rtmp=1. + COMPLEX*16 :: ctmp + INTEGER :: itmp=1 + INTEGER :: isign=0 + INTEGER :: ierr + + vsize=iim + scale_factor=1./SQRT(1.*vsize) + ALLOCATE(Table_forward(2*vsize+64)) + ALLOCATE(Table_backward(2*vsize+64)) + +! CALL DZFFTM(isign,vsize,itmp,scale_factor,rtmp,vsize+inc,ctmp,vsize/2+1,table_forward,rtmp,ierr) + +! CALL ZDFFTM(isign,vsize,itmp,scale_factor,ctmp,vsize/2+1,rtmp,vsize+inc,table_backward,rtmp,ierr) + + CALL rfftw_f77_create_plan(plan_forward,iim,FFTW_REAL_TO_COMPLEX,FFTW_ESTIMATE) + CALL rfftw_f77_create_plan(plan_backward,iim,FFTW_COMPLEX_TO_REAL,FFTW_ESTIMATE) + + END SUBROUTINE Init_fft + + + SUBROUTINE fft_forward(vect,TF_vect,nb_vect) + IMPLICIT NONE +#include + INTEGER,INTENT(IN) :: nb_vect + REAL,INTENT(IN) :: vect(vsize+inc,nb_vect) + COMPLEX*16,INTENT(OUT) :: TF_vect(vsize/2+1,nb_vect) + REAL :: work(4*vsize*nb_vect) + INTEGER :: ierr + INTEGER, PARAMETER :: isign=-1 + +! CALL DZFFTM(isign,vsize,nb_vect,scale_factor,vect,vsize+inc,TF_vect,vsize/2+1,table_forward,work,ierr) + CALL rfftwnd_f77_real_to_complex(plan_forward,nb_vect,vect, 1, vsize+inc , TF_vect, 1, vsize/2+1); + + END SUBROUTINE fft_forward + + SUBROUTINE fft_backward(TF_vect,vect,nb_vect) + IMPLICIT NONE +#include + INTEGER,INTENT(IN) :: nb_vect + REAL,INTENT(OUT) :: vect(vsize+inc,nb_vect) + COMPLEX*16,INTENT(IN ) :: TF_vect(vsize/2+1,nb_vect) + REAL :: work(4*vsize*nb_vect) + INTEGER :: ierr + INTEGER, PARAMETER :: isign=1 + +! CALL ZDFFTM(isign,vsize,nb_vect,scale_factor,TF_vect,vsize/2+1,vect,vsize+inc,table_backward,work,ierr) + CALL rfftwnd_f77_complex_to_real(plan_forward,nb_vect,TF_vect, 1, vsize/2+1 , vect, 1, vsize+inc); + + END SUBROUTINE fft_backward + +#endif + +END MODULE mod_fft_fftw + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_fft_mathkeisan.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_fft_mathkeisan.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_fft_mathkeisan.F90 (revision 1280) @@ -0,0 +1,67 @@ +MODULE mod_fft_mathkeisan +#ifdef FFT_MATHKEISAN + + REAL,SAVE,ALLOCATABLE :: Table_forward(:) + REAL,SAVE,ALLOCATABLE :: Table_backward(:) + REAL,SAVE :: scale_factor + INTEGER,SAVE :: vsize + INTEGER,PARAMETER :: inc=2 + +CONTAINS + + SUBROUTINE Init_fft(iim,nb_vect_max) + IMPLICIT NONE + INTEGER :: iim + INTEGER :: nb_vect_max + REAL :: rtmp=1. + COMPLEX*16 :: ctmp + INTEGER :: itmp=1 + INTEGER :: isign=0 + INTEGER :: ierr + + vsize=iim + scale_factor=1./SQRT(1.*vsize) + ALLOCATE(Table_forward(2*vsize+64)) + ALLOCATE(Table_backward(2*vsize+64)) + + CALL DZFFTM(isign,vsize,itmp,scale_factor,rtmp,vsize+inc,ctmp,vsize/2+1,table_forward,rtmp,ierr) + + CALL ZDFFTM(isign,vsize,itmp,scale_factor,ctmp,vsize/2+1,rtmp,vsize+inc,table_backward,rtmp,ierr) + + + END SUBROUTINE Init_fft + + + SUBROUTINE fft_forward(vect,TF_vect,nb_vect) + IMPLICIT NONE + INTEGER,INTENT(IN) :: nb_vect + REAL,INTENT(IN) :: vect(vsize+inc,nb_vect) + COMPLEX*16,INTENT(OUT) :: TF_vect(vsize/2+1,nb_vect) + REAL :: work(4*vsize*nb_vect) + INTEGER :: ierr + INTEGER, PARAMETER :: isign=-1 + + work=0 + CALL DZFFTM(isign,vsize,nb_vect,scale_factor,vect,vsize+inc,TF_vect,vsize/2+1,table_forward,work,ierr) + + END SUBROUTINE fft_forward + + SUBROUTINE fft_backward(TF_vect,vect,nb_vect) + IMPLICIT NONE + INTEGER,INTENT(IN) :: nb_vect + REAL,INTENT(OUT) :: vect(vsize+inc,nb_vect) + COMPLEX*16,INTENT(IN ) :: TF_vect(vsize/2+1,nb_vect) + REAL :: work(4*vsize*nb_vect) + INTEGER :: ierr + INTEGER, PARAMETER :: isign=1 + + work(:)=0 + CALL ZDFFTM(isign,vsize,nb_vect,scale_factor,TF_vect,vsize/2+1,vect,vsize+inc,table_backward,work,ierr) + + END SUBROUTINE fft_backward + +#endif + +END MODULE mod_fft_mathkeisan + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_fft_mkl.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_fft_mkl.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_fft_mkl.F90 (revision 1280) @@ -0,0 +1,128 @@ +MODULE mod_fft_mkl +#ifdef FFT_MKL + + USE MKL_DFTI + + REAL,SAVE :: scale_factor + INTEGER,SAVE :: vsize + INTEGER,PARAMETER :: inc=1 + +! TYPE FFT_HANDLE +! TYPE(DFTI_DESCRIPTOR), POINTER :: Pt +! LOGICAL :: IsAllocated +! END TYPE FFT_HANDLE + +! TYPE(FFT_HANDLE),SAVE,ALLOCATABLE :: Forward_Handle(:) +! TYPE(FFT_HANDLE),SAVE,ALLOCATABLE :: Backward_Handle(:) +!!$OMP THREADPRIVATE(Forward_Handle,Backward_Handle) + +CONTAINS + + SUBROUTINE Init_fft(iim,nb_vect_max) + IMPLICIT NONE + INTEGER :: iim + INTEGER :: nb_vect_max + REAL :: rtmp=1. + COMPLEX*16 :: ctmp + INTEGER :: itmp=1 + INTEGER :: isign=0 + INTEGER :: ierr + + vsize=iim + scale_factor=1./SQRT(1.*vsize) +! ALLOCATE(Forward_Handle(nb_vect_max)) +! ALLOCATE(Backward_Handle(nb_vect_max)) + +! Forward_Handle(:)%IsAllocated=.FALSE. +! Backward_Handle(:)%IsAllocated=.FALSE. + +! ALLOCATE(Table_forward(2*vsize+64)) +! ALLOCATE(Table_backward(2*vsize+64)) +! +! CALL DZFFTM(isign,vsize,itmp,scale_factor,rtmp,vsize+inc,ctmp,vsize/2+1,table_forward,rtmp,ierr) +! +! CALL ZDFFTM(isign,vsize,itmp,scale_factor,ctmp,vsize/2+1,rtmp,vsize+inc,table_backward,rtmp,ierr) + +! ierr = DftiCreateDescriptor( FFT_Handle, DFTI_DOUBLE, DFTI_REAL, 1, vsize ) +! ierr = DftiSetValue(FFT_Handle,DFTI_NUMBER_OF_TRANSFORMS,nb_vect) +! ierr = DftiSetValue(FFT_Handle,DFTI_FORWARD_SCALE,scale_factor) +! ierr = DftiSetValue(FFT_Handle,DFTI_BACKWARD_SCALE,scale_factor) +! ierr = DftiSetValue(FFT_Handle,DFTI_PLACEMENT,DFTI_NOT_INPLACE) +! ierr = DftiSetValue(Desc_Handle, DFTI_INPUT_DISTANCE, vsize+inc) +! ierr = DftiSetValue(Desc_Handle, DFTI_OUTPUT_DISTANCE, vsize) +! ierr = DftiCommitDescriptor( FFT_HANDLE ) + + END SUBROUTINE Init_fft + + + SUBROUTINE fft_forward(vect,TF_vect,nb_vect) + IMPLICIT NONE + INTEGER,INTENT(IN) :: nb_vect + REAL,INTENT(IN) :: vect((vsize+inc)*nb_vect) + COMPLEX*16,INTENT(OUT) :: TF_vect((vsize/2+1)*nb_vect) + REAL :: work(4*vsize*nb_vect) + INTEGER :: ierr + INTEGER, PARAMETER :: isign=-1 + REAL :: vect_out((vsize+inc)*nb_vect) + TYPE(DFTI_DESCRIPTOR), POINTER :: FFT_Handle + +! IF ( .NOT. Forward_handle(nb_vect)%IsAllocated) THEN + ierr = DftiCreateDescriptor( FFT_Handle, DFTI_DOUBLE, DFTI_REAL, 1, vsize ) + ierr = DftiSetValue(FFT_Handle,DFTI_NUMBER_OF_TRANSFORMS,nb_vect) + ierr = DftiSetValue(FFT_Handle,DFTI_FORWARD_SCALE,scale_factor) + ierr = DftiSetValue(FFT_Handle,DFTI_BACKWARD_SCALE,scale_factor) + ierr = DftiSetValue(FFT_Handle,DFTI_PLACEMENT,DFTI_NOT_INPLACE) + ierr = DftiSetValue(FFT_Handle, DFTI_INPUT_DISTANCE, vsize+inc) + ierr = DftiSetValue(FFT_Handle, DFTI_OUTPUT_DISTANCE, (vsize/2+1)*2) + ierr = DftiCommitDescriptor( FFT_Handle ) +! Forward_handle(nb_vect)%IsAllocated=.TRUE. +! ENDIF + + ierr = DftiComputeForward( FFT_Handle, vect, TF_vect ) + + ierr = DftiFreeDescriptor( FFT_Handle ) + +! ierr = DftiCreateDescriptor( FFT_Handle, DFTI_DOUBLE, DFTI_REAL, 1, vsize ) +! ierr = DftiSetValue(FFT_Handle,DFTI_NUMBER_OF_TRANSFORMS,nb_vect) +! ierr = DftiSetValue(FFT_Handle,DFTI_FORWARD_SCALE,scale_factor) +! ierr = DftiSetValue(FFT_Handle,DFTI_BACKWARD_SCALE,scale_factor) +! ierr = DftiSetValue(FFT_Handle,DFTI_PLACEMENT,DFTI_NOT_INPLACE) +! ierr = DftiSetValue(FFT_HANDLE, DFTI_INPUT_DISTANCE, vsize/2+1) +! ierr = DftiSetValue(FFT_HANDLE, DFTI_OUTPUT_DISTANCE, vsize+inc) +! ierr = DftiCommitDescriptor( FFT_HANDLE ) +! ierr = DftiComputeBackward( FFT_HANDLE, TF_vect, vect_out ) +! ierr = DftiFreeDescriptor( FFT_HANDLE ) + +! CALL DZFFTM(isign,vsize,nb_vect,scale_factor,vect,vsize+inc,TF_vect,vsize/2+1,table_forward,work,ierr) + + END SUBROUTINE fft_forward + + SUBROUTINE fft_backward(TF_vect,vect,nb_vect) + IMPLICIT NONE + INTEGER,INTENT(IN) :: nb_vect + REAL,INTENT(OUT) :: vect((vsize+inc)*nb_vect) + COMPLEX*16,INTENT(IN ) :: TF_vect((vsize/2+1)*nb_vect) + REAL :: work(4*vsize*nb_vect) + INTEGER :: ierr + INTEGER, PARAMETER :: isign=1 + TYPE(DFTI_DESCRIPTOR),POINTER :: FFT_Handle +! CALL ZDFFTM(isign,vsize,nb_vect,scale_factor,TF_vect,vsize/2+1,vect,vsize+inc,table_backward,work,ierr) +! IF ( .NOT. Backward_handle(nb_vect)%IsAllocated) THEN + ierr = DftiCreateDescriptor( FFT_Handle, DFTI_DOUBLE, DFTI_REAL, 1, vsize ) + ierr = DftiSetValue(FFT_Handle,DFTI_NUMBER_OF_TRANSFORMS,nb_vect) + ierr = DftiSetValue(FFT_Handle,DFTI_FORWARD_SCALE,scale_factor) + ierr = DftiSetValue(FFT_Handle,DFTI_BACKWARD_SCALE,scale_factor) + ierr = DftiSetValue(FFT_Handle,DFTI_PLACEMENT,DFTI_NOT_INPLACE) + ierr = DftiSetValue(FFT_Handle, DFTI_INPUT_DISTANCE, (vsize/2+1)*2) + ierr = DftiSetValue(FFT_Handle, DFTI_OUTPUT_DISTANCE, vsize+inc) + ierr = DftiCommitDescriptor( FFT_Handle ) +! Backward_handle(nb_vect)%IsAllocated=.TRUE. +! ENDIF + ierr = DftiComputeBackward( FFT_Handle, TF_vect, vect ) + ierr = DftiFreeDescriptor( FFT_Handle) + + END SUBROUTINE fft_backward + +#endif + +END MODULE mod_fft_mkl Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_fft_wrapper.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_fft_wrapper.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_fft_wrapper.F90 (revision 1280) @@ -0,0 +1,37 @@ +MODULE mod_fft_wrapper + + INTEGER,SAVE :: vsize + INTEGER,PARAMETER :: inc=1 + +CONTAINS + + SUBROUTINE Init_fft(iim,nb) + IMPLICIT NONE + INTEGER :: iim + INTEGER :: nb + + STOP "wrapper fft : une FFT doit etre specifiee a l'aide d'une clee CPP, sinon utiliser le filtre classique" + END SUBROUTINE Init_fft + + + SUBROUTINE fft_forward(vect,TF_vect,nb_vect) + IMPLICIT NONE + INTEGER,INTENT(IN) :: nb_vect + REAL,INTENT(IN) :: vect(vsize+inc,nb_vect) + COMPLEX*16,INTENT(INOUT) :: TF_vect(vsize/2+1,nb_vect) + + STOP "wrapper fft : une FFT doit etre specifiee a l'aide d'une clee CPP, sinon utiliser le filtre classique" + + END SUBROUTINE fft_forward + + SUBROUTINE fft_backward(TF_vect,vect,nb_vect) + IMPLICIT NONE + INTEGER,INTENT(IN) :: nb_vect + REAL,INTENT(INOUT) :: vect(vsize+inc,nb_vect) + COMPLEX*16,INTENT(IN ) :: TF_vect(vsize/2+1,nb_vect) + + STOP "wrapper fft : une FFT doit etre specifiee a l'aide d'une clee CPP, sinon utiliser le filtre classique" + + END SUBROUTINE fft_backward + +END MODULE mod_fft_wrapper Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_filtre_fft.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_filtre_fft.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/mod_filtre_fft.F90 (revision 1280) @@ -0,0 +1,342 @@ +MODULE mod_filtre_fft + + LOGICAL,SAVE :: use_filtre_fft + REAL,SAVE,ALLOCATABLE :: Filtre_u(:,:) + REAL,SAVE,ALLOCATABLE :: Filtre_v(:,:) + REAL,SAVE,ALLOCATABLE :: Filtre_inv(:,:) + +CONTAINS + + SUBROUTINE Init_filtre_fft(coeffu,modfrstu,jfiltnu,jfiltsu,coeffv,modfrstv,jfiltnv,jfiltsv) + USE mod_fft + IMPLICIT NONE + include 'dimensions.h' + REAL, INTENT(IN) :: coeffu(iim,jjm) + INTEGER,INTENT(IN) :: modfrstu(jjm) + INTEGER,INTENT(IN) :: jfiltnu + INTEGER,INTENT(IN) :: jfiltsu + REAL, INTENT(IN) :: coeffv(iim,jjm) + INTEGER,INTENT(IN) :: modfrstv(jjm) + INTEGER,INTENT(IN) :: jfiltnv + INTEGER,INTENT(IN) :: jfiltsv + + INTEGER :: index_vp(iim) + INTEGER :: i,j + + index_vp(1)=1 + DO i=1,iim/2 + index_vp(i+1)=i*2 + ENDDO + + DO i=1,iim/2-1 + index_vp(iim/2+i+1)=iim-2*i+1 + ENDDO + + ALLOCATE(Filtre_u(iim,jjm)) + ALLOCATE(Filtre_v(iim,jjm)) + ALLOCATE(Filtre_inv(iim,jjm)) + + + DO j=2,jfiltnu + DO i=1,iim + IF (index_vp(i) < modfrstu(j)) THEN + Filtre_u(i,j)=0 + ELSE + Filtre_u(i,j)=coeffu(index_vp(i),j) + ENDIF + ENDDO + ENDDO + + DO j=jfiltsu,jjm + DO i=1,iim + IF (index_vp(i) < modfrstu(j)) THEN + Filtre_u(i,j)=0 + ELSE + Filtre_u(i,j)=coeffu(index_vp(i),j) + ENDIF + ENDDO + ENDDO + + DO j=1,jfiltnv + DO i=1,iim + IF (index_vp(i) < modfrstv(j)) THEN + Filtre_v(i,j)=0 + ELSE + Filtre_v(i,j)=coeffv(index_vp(i),j) + ENDIF + ENDDO + ENDDO + + DO j=jfiltsv,jjm + DO i=1,iim + IF (index_vp(i) < modfrstv(j)) THEN + Filtre_v(i,j)=0 + ELSE + Filtre_v(i,j)=coeffv(index_vp(i),j) + ENDIF + ENDDO + ENDDO + + DO j=2,jfiltnu + DO i=1,iim + IF (index_vp(i) < modfrstu(j)) THEN + Filtre_inv(i,j)=0 + ELSE + Filtre_inv(i,j)=coeffu(index_vp(i),j)/(1.+coeffu(index_vp(i),j)) + ENDIF + ENDDO + ENDDO + + DO j=jfiltsu,jjm + DO i=1,iim + IF (index_vp(i) < modfrstu(j)) THEN + Filtre_inv(i,j)=0 + ELSE + Filtre_inv(i,j)=coeffu(index_vp(i),j)/(1.+coeffu(index_vp(i),j)) + ENDIF + ENDDO + ENDDO + + + CALL Init_FFT(iim,(jjm+1)*(llm+1)) + + + END SUBROUTINE Init_filtre_fft + + SUBROUTINE Filtre_u_fft(vect_inout,nlat,jj_begin,jj_end,nbniv) + USE mod_fft +#ifdef CPP_PARA + USE parallel,ONLY : OMP_CHUNK +#endif + IMPLICIT NONE + include 'dimensions.h' + INTEGER,INTENT(IN) :: nlat + INTEGER,INTENT(IN) :: jj_begin + INTEGER,INTENT(IN) :: jj_end + INTEGER,INTENT(IN) :: nbniv + REAL,INTENT(INOUT) :: vect_inout(iim+1,nlat,nbniv) + + REAL :: vect(iim+inc,jj_end-jj_begin+1,nbniv) +! REAL :: vect_test(iim+inc,jj_end-jj_begin+1,nbniv) + COMPLEX*16 :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv) +! COMPLEX*16 :: TF_vect_test(iim/2+1,jj_end-jj_begin+1,nbniv) + INTEGER :: nb_vect + INTEGER :: i,j,l + INTEGER :: ll_nb +! REAL :: vect_tmp(iim+inc,jj_end-jj_begin+1,nbniv) + + ll_nb=0 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + ll_nb=ll_nb+1 + DO j=1,jj_end-jj_begin+1 + DO i=1,iim+1 + vect(i,j,ll_nb)=vect_inout(i,j+jj_begin-1,l) + ENDDO + ENDDO + ENDDO +!$OMP END DO NOWAIT + + nb_vect=(jj_end-jj_begin+1)*ll_nb + +! vect_tmp=vect + + CALL FFT_forward(vect,TF_vect,nb_vect) + +! CALL FFT_forward(vect,TF_vect_test,nb_vect) +! PRINT *,"XXXXXXXXXXXXX Filtre_u_FFT xxxxxxxxxxxx" +! DO j=1,jj_end-jj_begin+1 +! DO i=1,iim/2+1 +! PRINT *,"====",i,j,"----->",TF_vect_test(i,j,1) +! ENDDO +! ENDDO + + DO l=1,ll_nb + DO j=1,jj_end-jj_begin+1 + DO i=1,iim/2+1 + TF_vect(i,j,l)=TF_vect(i,j,l)*Filtre_u(i,jj_begin+j-1) + ENDDO + ENDDO + ENDDO + + CALL FFT_backward(TF_vect,vect,nb_vect) +! CALL FFT_backward(TF_vect_test,vect_test,nb_vect) + +! PRINT *,"XXXXXXXXXXXXX Filtre_u_FFT xxxxxxxxxxxx" +! DO j=1,jj_end-jj_begin+1 +! DO i=1,iim +! PRINT *,"====",i,j,"----->",vect_test(i,j,1) +! ENDDO +! ENDDO + + ll_nb=0 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + ll_nb=ll_nb+1 + DO j=1,jj_end-jj_begin+1 + DO i=1,iim+1 + vect_inout(i,j+jj_begin-1,l)=vect(i,j,ll_nb) + ENDDO + ENDDO + ENDDO +!$OMP END DO NOWAIT + + END SUBROUTINE Filtre_u_fft + + + SUBROUTINE Filtre_v_fft(vect_inout,nlat,jj_begin,jj_end,nbniv) + USE mod_fft +#ifdef CPP_PARA + USE parallel,ONLY : OMP_CHUNK +#endif + IMPLICIT NONE + INCLUDE 'dimensions.h' + INTEGER,INTENT(IN) :: nlat + INTEGER,INTENT(IN) :: jj_begin + INTEGER,INTENT(IN) :: jj_end + INTEGER,INTENT(IN) :: nbniv + REAL,INTENT(INOUT) :: vect_inout(iim+1,nlat,nbniv) + + REAL :: vect(iim+inc,jj_end-jj_begin+1,nbniv) + COMPLEX*16 :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv) + INTEGER :: nb_vect + INTEGER :: i,j,l + INTEGER :: ll_nb + + ll_nb=0 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + ll_nb=ll_nb+1 + DO j=1,jj_end-jj_begin+1 + DO i=1,iim+1 + vect(i,j,ll_nb)=vect_inout(i,j+jj_begin-1,l) + ENDDO + ENDDO + ENDDO +!$OMP END DO NOWAIT + + + nb_vect=(jj_end-jj_begin+1)*ll_nb + + CALL FFT_forward(vect,TF_vect,nb_vect) + + DO l=1,ll_nb + DO j=1,jj_end-jj_begin+1 + DO i=1,iim/2+1 + TF_vect(i,j,l)=TF_vect(i,j,l)*Filtre_v(i,jj_begin+j-1) + ENDDO + ENDDO + ENDDO + + CALL FFT_backward(TF_vect,vect,nb_vect) + + + ll_nb=0 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + ll_nb=ll_nb+1 + DO j=1,jj_end-jj_begin+1 + DO i=1,iim+1 + vect_inout(i,j+jj_begin-1,l)=vect(i,j,ll_nb) + ENDDO + ENDDO + ENDDO +!$OMP END DO NOWAIT + + END SUBROUTINE Filtre_v_fft + + + SUBROUTINE Filtre_inv_fft(vect_inout,nlat,jj_begin,jj_end,nbniv) + USE mod_fft +#ifdef CPP_PARA + USE parallel,ONLY : OMP_CHUNK +#endif + IMPLICIT NONE + INCLUDE 'dimensions.h' + INTEGER,INTENT(IN) :: nlat + INTEGER,INTENT(IN) :: jj_begin + INTEGER,INTENT(IN) :: jj_end + INTEGER,INTENT(IN) :: nbniv + REAL,INTENT(INOUT) :: vect_inout(iim+1,nlat,nbniv) + + REAL :: vect(iim+inc,jj_end-jj_begin+1,nbniv) + COMPLEX*16 :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv) + INTEGER :: nb_vect + INTEGER :: i,j,l + INTEGER :: ll_nb + + ll_nb=0 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + ll_nb=ll_nb+1 + DO j=1,jj_end-jj_begin+1 + DO i=1,iim+1 + vect(i,j,ll_nb)=vect_inout(i,j+jj_begin-1,l) + ENDDO + ENDDO + ENDDO +!$OMP END DO NOWAIT + + nb_vect=(jj_end-jj_begin+1)*ll_nb + + CALL FFT_forward(vect,TF_vect,nb_vect) + + DO l=1,ll_nb + DO j=1,jj_end-jj_begin+1 + DO i=1,iim/2+1 + TF_vect(i,j,l)=TF_vect(i,j,l)*Filtre_inv(i,jj_begin+j-1) + ENDDO + ENDDO + ENDDO + + CALL FFT_backward(TF_vect,vect,nb_vect) + + ll_nb=0 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + ll_nb=ll_nb+1 + DO j=1,jj_end-jj_begin+1 + DO i=1,iim+1 + vect_inout(i,j+jj_begin-1,l)=vect(i,j,ll_nb) + ENDDO + ENDDO + ENDDO +!$OMP END DO NOWAIT + + END SUBROUTINE Filtre_inv_fft + + +! SUBROUTINE get_ll_index(nbniv,ll_index,ll_nb) +! IMPLICIT NONE +! INTEGER,INTENT(IN) :: nbniv +! INTEGER,INTENT(OUT) :: ll_index(nbniv) +! INTEGER,INTENT(OUT) :: ll_nb +! +! INTEGER :: l,ll_begin, ll_end +! INTEGER :: omp_rank,omp_size +! INTEGER :: OMP_GET_NUM_THREADS +! INTEGER :: omp_chunk +! EXTERNAL OMP_GET_NUM_THREADS +! INTEGER :: OMP_GET_THREAD_NUM +! EXTERNAL OMP_GET_THREAD_NUM +! +! +! omp_size=OMP_GET_NUM_THREADS() +! omp_rank=OMP_GET_THREAD_NUM() +! omp_chunk=nbniv/omp_size+min(1,MOD(nbniv,omp_size)) +! +! ll_begin=omp_rank*OMP_CHUNK+1 +! ll_nb=0 +! DO WHILE (ll_begin<=nbniv) +! ll_end=min(ll_begin+OMP_CHUNK-1,nbniv) +! DO l=ll_begin,ll_end +! ll_nb=ll_nb+1 +! ll_index(ll_nb)=l +! ENDDO +! ll_begin=ll_begin+omp_size*OMP_CHUNK +! ENDDO +! +! END SUBROUTINE get_ll_index + +END MODULE mod_filtre_fft + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/parafilt.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/parafilt.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/parafilt.h (revision 1280) @@ -0,0 +1,4 @@ +! +! $Header$ +! + INTEGER nfilun, nfilus, nfilvn, nfilvs Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/parafilt.h_192x142x29 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/parafilt.h_192x142x29 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/parafilt.h_192x142x29 (revision 1280) @@ -0,0 +1,45 @@ +! +! $Header$ +! + INTEGER nfilun, nfilus, nfilvn, nfilvs +c +c 48 32 19 non-zoom: +c PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30) +c PARAMETER (nfilun=6, nfilus=5, nfilvn=5, nfilvs=5) +c PARAMETER (nfilun=15, nfilus=8, nfilvn=14, nfilvs=8) +c PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24) +cmaf -debug PARAMETER (nfilun=2, nfilus=1, nfilvn=2, nfilvs=2) +c +c +c 96 49 11 non-zoom: +ccc PARAMETER (nfilun=9, nfilus=8, nfilvn=8, nfilvs=8) +c +c +c 144 73 11 non-zoom: +ccc PARAMETER (nfilun=13, nfilus=12, nfilvn=12, nfilvs=12) +c +c 192 143 19 non-zoom: +c PARAMETER (nfilun=13, nfilus=12, nfilvn=13, nfilvs=13) +c PARAMETER (nfilun=15, nfilus=14, nfilvn=14, nfilvs=14) !!NO fxyhyper +c PARAMETER (nfilun=18, nfilus=17, nfilvn=17, nfilvs=17) !!NO fxyhyper +c PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30) + +c 96 72 19 non-zoom: +c PARAMETER (nfilun=12, nfilus=11, nfilvn=12, nfilvs=12) +c 192 142 29 non-zoom: + PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24) +c +c PARAMETER ( nfilun=20, nfilus=20, nfilvn=20, nfilvs=20 ) +c PARAMETER ( nfilun=8, nfilus=7, nfilvn=7, nfilvs=7 ) +c +c +c Ici , on a exagere les nombres de lignes de latitudes a filtrer . +c +c La premiere fois que le Gcm rentrera dans le Filtre , +c +c il indiquera les bonnes valeurs de nfilun , nflius, nfilvn et +c +c nfilvs a mettre . Il suffira alors de changer ces valeurs dans +c +c Parameter ci-dessus et de relancer le run . + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/parafilt.h_96x71x19 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/parafilt.h_96x71x19 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/parafilt.h_96x71x19 (revision 1280) @@ -0,0 +1,46 @@ +! +! $Header$ +! + INTEGER nfilun, nfilus, nfilvn, nfilvs +c +c 48 32 19 non-zoom: +c PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30) +c PARAMETER (nfilun=6, nfilus=5, nfilvn=5, nfilvs=5) +c PARAMETER (nfilun=15, nfilus=8, nfilvn=14, nfilvs=8) +c PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24) +cmaf -debug PARAMETER (nfilun=2, nfilus=1, nfilvn=2, nfilvs=2) +c +c +c 96 49 11 non-zoom: +ccc PARAMETER (nfilun=9, nfilus=8, nfilvn=8, nfilvs=8) +c +c +c 144 73 11 non-zoom: +ccc PARAMETER (nfilun=13, nfilus=12, nfilvn=12, nfilvs=12) +c +c 192 143 19 non-zoom: +c PARAMETER (nfilun=13, nfilus=12, nfilvn=13, nfilvs=13) +c PARAMETER (nfilun=15, nfilus=14, nfilvn=14, nfilvs=14) !!NO fxyhyper +c PARAMETER (nfilun=18, nfilus=17, nfilvn=17, nfilvs=17) !!NO fxyhyper +c PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30) + +cIM 96 72 19 non-zoom: +c 96 71 19 non-zoom: + PARAMETER (nfilun=12, nfilus=11, nfilvn=12, nfilvs=12) +c 192 142 29 non-zoom: +c PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24) +c +c PARAMETER ( nfilun=20, nfilus=20, nfilvn=20, nfilvs=20 ) +c PARAMETER ( nfilun=8, nfilus=7, nfilvn=7, nfilvs=7 ) +c +c +c Ici , on a exagere les nombres de lignes de latitudes a filtrer . +c +c La premiere fois que le Gcm rentrera dans le Filtre , +c +c il indiquera les bonnes valeurs de nfilun , nflius, nfilvn et +c +c nfilvs a mettre . Il suffira alors de changer ces valeurs dans +c +c Parameter ci-dessus et de relancer le run . + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/timer_filtre.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/timer_filtre.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/filtrez/timer_filtre.F90 (revision 1280) @@ -0,0 +1,33 @@ +MODULE timer_filtre +IMPLICIT NONE + PRIVATE + REAL :: time + REAL :: Last_time + PUBLIC :: Init_timer, start_timer, stop_timer, Print_filtre_timer +CONTAINS + + SUBROUTINE Init_timer + time=0 + Last_time=0 + END SUBROUTINE Init_timer + + SUBROUTINE Start_timer + + CALL cpu_time(last_time) + + END SUBROUTINE start_timer + + + SUBROUTINE stop_timer + REAL :: T + + CALL cpu_time(t) + Time=Time+t-last_time + + END SUBROUTINE stop_timer + + SUBROUTINE Print_filtre_timer + PRINT *,"Temps CPU passe dans le filtre :",Time + END SUBROUTINE Print_filtre_timer + +END MODULE timer_filtre Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/grid/dimension/makdim =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/grid/dimension/makdim (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/grid/dimension/makdim (revision 1280) @@ -0,0 +1,65 @@ +for i in $* ; do + list=$list.$i +done +fichdim=dimensions${list} + +if [ ! -f $fichdim ] ; then +# si le fichier de dimensions n'existe pas, on le cree + + if [ $# -ge 3 ] ; then + im=$1 + jm=$2 + lm=$3 + n2=$1 + ndm=1 + +# Le test suivant est commente car il est inutile avec le nouveau +# filtre filtrez. Attention avec le "vieux" filtre (F. Forget,11/1994) +# +# while [ "$n2" -gt 2 ]; do +# n2=`expr $n2 / 2` +# ndm=`expr $ndm + 1` +# echo $n2 +# done +# if [ "$n2" != 2 ] ; then +# echo le nombre de longitude doit etre une puissance de 2 +# exit +# fi + + + else if [ $# -ge 2 ] ; then + im=1 + jm=$1 + lm=$2 + ndm=1 + else if [ $# -ge 1 ] ; then + im=1 + jm=1 + lm=$1 + ndm=1 + else + echo il faut au moins une dimension + exit + fi +fi +fi + +cat << EOF > $fichdim +!----------------------------------------------------------------------- +! INCLUDE 'dimensions.h' +! +! dimensions.h contient les dimensions du modele +! ndm est tel que iim=2**ndm +!----------------------------------------------------------------------- + + INTEGER iim,jjm,llm,ndm + + PARAMETER (iim= $im,jjm=$jm,llm=$lm,ndm=$ndm) + +!----------------------------------------------------------------------- +EOF + +fi + +\rm ../dimensions.h +tar cf - $fichdim | ( cd .. ; tar xf - ; mv $fichdim dimensions.h ) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/grid/fxy_new.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/grid/fxy_new.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/grid/fxy_new.h (revision 1280) @@ -0,0 +1,27 @@ +! +! $Header$ +! +c-------------------------------------------------------------- + REAL ripx + REAL fx,fxprim,fy,fyprim,ri,rj,bigy +c +c....stretching in x... +c + ripx( ri )= (ri-1.0) *2.*pi/FLOAT(iim) + fx ( ri )= ripx(ri) + transx + + * alphax * SIN( ripx(ri)+transx-pxo ) - pi + fxprim(ri) = 2.*pi/FLOAT(iim) * + * ( 1.+ alphax * COS( ripx(ri)+transx-pxo ) ) + +c....stretching in y... +c + bigy(rj) = 2.* (FLOAT(jjp1)-rj ) *pi/jjm + fy(rj) = ( bigy(rj) + transy + + * alphay * SIN( bigy(rj)+transy-pyo ) ) /2. - pi/2. + fyprim(rj) = ( pi/jjm ) * ( 1.+ + * alphay * COS( bigy(rj)+transy-pyo ) ) + +c fy(rj)= pyo-pisjjm*(rj-transy)+coefalpha*SIN(depisjm*(rj- +c * transy )) +c fyprim(rj)= pisjjm-pisjjm*coefy2* COS(depisjm*(rj-transy)) +c-------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/grid/fxy_reg.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/grid/fxy_reg.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/grid/fxy_reg.h (revision 1280) @@ -0,0 +1,45 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c INCLUDE 'fxyprim.h' +c +c ................................................................ +c ................ Fonctions in line ........................... +c ................................................................ +c + REAL fy, fx, fxprim, fyprim + REAL ri, rj +c +c + fy ( rj ) = pi/FLOAT(jjm) * ( 0.5 * FLOAT(jjm) + 1. - rj ) + fyprim( rj ) = pi/FLOAT(jjm) + +c fy(rj)=ASIN(1.+2.*((1.-rj)/FLOAT(jjm))) +c fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj)) + + fx ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5* FLOAT(iim) - 1. ) +c fx ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5* ( FLOAT(iim) + 1.) ) + fxprim( ri ) = 2.*pi/FLOAT(iim) +c +c +c La valeur de pi est passee par le common/const/ou /const2/ . +c Sinon, il faut la calculer avant d'appeler ces fonctions . +c +c ---------------------------------------------------------------- +c Fonctions a changer eventuellement, selon x(x) et y(y) choisis . +c ----------------------------------------------------------------- +c +c ..... ici, on a l'application particuliere suivante ........ +c +c ************************************** +c ** x = 2. * pi/iim * X ** +c ** y = pi/jjm * Y ** +c ************************************** +c +c .................................................................. +c .................................................................. +c +c +c +c----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/grid/fxy_sin.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/grid/fxy_sin.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/grid/fxy_sin.h (revision 1280) @@ -0,0 +1,42 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c INCLUDE 'fxyprim.h' +c +c ................................................................ +c ................ Fonctions in line ........................... +c ................................................................ +c + REAL fy, fx, fxprim, fyprim + REAL ri, rj +c +c + fy(rj)=ASIN(1.+2.*((1.-rj)/FLOAT(jjm))) + fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj)) + + fx ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5* FLOAT(iim) - 1. ) +c fx ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5* ( FLOAT(iim) + 1.) ) + fxprim( ri ) = 2.*pi/FLOAT(iim) +c +c +c La valeur de pi est passee par le common/const/ou /const2/ . +c Sinon, il faut la calculer avant d'appeler ces fonctions . +c +c ---------------------------------------------------------------- +c Fonctions a changer eventuellement, selon x(x) et y(y) choisis . +c ----------------------------------------------------------------- +c +c ..... ici, on a l'application particuliere suivante ........ +c +c ************************************** +c ** x = 2. * pi/iim * X ** +c ** y = pi/jjm * Y ** +c ************************************** +c +c .................................................................. +c .................................................................. +c +c +c +c----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/grid/fxyprim.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/grid/fxyprim.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/grid/fxyprim.h (revision 1280) @@ -0,0 +1,45 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c INCLUDE 'fxyprim.h' +c +c ................................................................ +c ................ Fonctions in line ........................... +c ................................................................ +c + REAL fy, fx, fxprim, fyprim + REAL ri, rj +c +c + fy ( rj ) = pi/FLOAT(jjm) * ( 0.5 * FLOAT(jjm) + 1. - rj ) + fyprim( rj ) = pi/FLOAT(jjm) + +c fy(rj)=ASIN(1.+2.*((1.-rj)/FLOAT(jjm))) +c fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj)) + + fx ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5* FLOAT(iim) - 1. ) +c fx ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5* ( FLOAT(iim) + 1.) ) + fxprim( ri ) = 2.*pi/FLOAT(iim) +c +c +c La valeur de pi est passee par le common/const/ou /const2/ . +c Sinon, il faut la calculer avant d'appeler ces fonctions . +c +c ---------------------------------------------------------------- +c Fonctions a changer eventuellement, selon x(x) et y(y) choisis . +c ----------------------------------------------------------------- +c +c ..... ici, on a l'application particuliere suivante ........ +c +c ************************************** +c ** x = 2. * pi/iim * X ** +c ** y = pi/jjm * Y ** +c ************************************** +c +c .................................................................. +c .................................................................. +c +c +c +c----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/FCTTRE.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/FCTTRE.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/FCTTRE.h (revision 1280) @@ -0,0 +1,45 @@ +! +! $Header$ +! +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! ------------------------------------------------------------------ +! This COMDECK includes the Thermodynamical functions for the cy39 +! ECMWF Physics package. +! Consistent with YOMCST Basic physics constants, assuming the +! partial pressure of water vapour is given by a first order +! Taylor expansion of Qs(T) w.r.t. to Temperature, using constants +! in YOETHF +! ------------------------------------------------------------------ + REAL PTARG, PDELARG, P5ARG, PQSARG, PCOARG + REAL FOEEW, FOEDE, qsats, qsatl, dqsats, dqsatl + LOGICAL thermcep + PARAMETER (thermcep=.TRUE.) +! + FOEEW ( PTARG,PDELARG ) = EXP ( & + & (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT) & + & / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) ) +! + FOEDE ( PTARG,PDELARG,P5ARG,PQSARG,PCOARG ) = PQSARG*PCOARG*P5ARG & + & / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG))**2 +! + qsats(ptarg) = 100.0 * 0.622 * 10.0 & + & ** (2.07023 - 0.00320991 * ptarg & + & - 2484.896 / ptarg + 3.56654 * LOG10(ptarg)) + qsatl(ptarg) = 100.0 * 0.622 * 10.0 & + & ** (23.8319 - 2948.964 / ptarg & + & - 5.028 * LOG10(ptarg) & + & - 29810.16 * EXP( - 0.0699382 * ptarg) & + & + 25.21935 * EXP( - 2999.924 / ptarg)) +! + dqsats(ptarg,pqsarg) = RLVTT/RCPD*pqsarg * (3.56654/ptarg & + & +2484.896*LOG(10.)/ptarg**2 & + & -0.00320991*LOG(10.)) + dqsatl(ptarg,pqsarg) = RLVTT/RCPD*pqsarg*LOG(10.)* & + & (2948.964/ptarg**2-5.028/LOG(10.)/ptarg & + & +25.21935*2999.924/ptarg**2*EXP(-2999.924/ptarg) & + & +29810.16*0.0699382*EXP(-0.0699382*ptarg)) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/YOECUMF.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/YOECUMF.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/YOECUMF.h (revision 1280) @@ -0,0 +1,48 @@ +! +! $Id$ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! ---------------------------------------------------------------- +!* *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME +! ---------------------------------------------------------------- +! + COMMON /YOECUMF/ & + & LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV, & + & ENTRPEN,ENTRSCV,ENTRMID,ENTRDD,CMFCTOP, & + & CMFCMAX,CMFCMIN,CMFDEPS,RHCDD,CPRCON + + LOGICAL LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV + REAL ENTRPEN, ENTRSCV, ENTRMID, ENTRDD + REAL CMFCTOP, CMFCMAX, CMFCMIN, CMFDEPS, RHCDD, CPRCON +!$OMP THREADPRIVATE(/YOECUMF/) +! +!*if (DOC,declared) <> 'UNKNOWN' +!* *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME +! +! M.TIEDTKE E. C. M. W. F. 18/1/89 +! +! NAME TYPE PURPOSE +! ---- ---- ------- +! +! LMFPEN LOGICAL TRUE IF PENETRATIVE CONVECTION IS SWITCHED ON +! LMFSCV LOGICAL TRUE IF SHALLOW CONVECTION IS SWITCHED ON +! LMFMID LOGICAL TRUE IF MIDLEVEL CONVECTION IS SWITCHED ON +! LMFDD LOGICAL TRUE IF CUMULUS DOWNDRAFT IS SWITCHED ON +! LMFDUDV LOGICAL TRUE IF CUMULUS FRICTION IS SWITCHED ON +! ENTRPEN REAL ENTRAINMENT RATE FOR PENETRATIVE CONVECTION +! ENTRSCV REAL ENTRAINMENT RATE FOR SHALLOW CONVECTION +! ENTRMID REAL ENTRAINMENT RATE FOR MIDLEVEL CONVECTION +! ENTRDD REAL ENTRAINMENT RATE FOR CUMULUS DOWNDRAFTS +! CMFCTOP REAL RELAT. CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANC +! CMFCMAX REAL MAXIMUM MASSFLUX VALUE ALLOWED FOR +! CMFCMIN REAL MINIMUM MASSFLUX VALUE (FOR SAFETY) +! CMFDEPS REAL FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS +! RHCDD REAL RELATIVE SATURATION IN DOWNDRAFTS +! CPRCON REAL COEFFICIENTS FOR DETERMINING CONVERSION +! FROM CLOUD WATER TO RAIN +!*ifend +! ---------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/YOEGWD.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/YOEGWD.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/YOEGWD.h (revision 1280) @@ -0,0 +1,16 @@ +! +! $Header$ +! +C ----------------------------------------------------------------- +C* *COMMON* *YOEGWD* - PARAMETERS FOR GRAVITY WAVE DRAG CALCULATIONS +C ----------------------------------------------------------------- +C + integer NKTOPG,NSTRA + real GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT + real GHMAX,GRAHILO,GSIGCR,GSSEC,GTSEC,GVSEC + COMMON/YOEGWD/ GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT + * ,GHMAX,GRAHILO,GSIGCR,NKTOPG,NSTRA,GSSEC,GTSEC,GVSEC +c$OMP THREADPRIVATE(/YOEGWD/) +C + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/YOETHF.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/YOETHF.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/YOETHF.h (revision 1280) @@ -0,0 +1,21 @@ +! +! $Header$ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +!* COMMON *YOETHF* DERIVED CONSTANTS SPECIFIC TO ECMWF THERMODYNAMICS +! +! *R__ES* *CONSTANTS USED FOR COMPUTATION OF SATURATION +! MIXING RATIO OVER LIQUID WATER(*R_LES*) OR +! ICE(*R_IES*). +! *RVTMP2* *RVTMP2=RCPV/RCPD-1. +! *RHOH2O* *DENSITY OF LIQUID WATER. (RATM/100.) +! + REAL R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES + REAL RVTMP2, RHOH2O + COMMON /YOETHF/R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES, & + & RVTMP2, RHOH2O +!$OMP THREADPRIVATE(/YOETHF/) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/YOMCST.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/YOMCST.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/YOMCST.h (revision 1280) @@ -0,0 +1,44 @@ +! +! $Header$ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez à n'utiliser que des ! pour les commentaires +! et à bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! +! A1.0 Fundamental constants + REAL RPI,RCLUM,RHPLA,RKBOL,RNAVO +! A1.1 Astronomical constants + REAL RDAY,REA,REPSM,RSIYEA,RSIDAY,ROMEGA +! A1.1.bis Constantes concernant l'orbite de la Terre: + REAL R_ecc, R_peri, R_incl +! A1.2 Geoide + REAL RA,RG,R1SA +! A1.3 Radiation +! REAL RSIGMA,RI0 + REAL RSIGMA +! A1.4 Thermodynamic gas phase + REAL R,RMD,RMO3,RMV,RD,RV,RCPD,RCPV,RCVD,RCVV + REAL RKAPPA,RETV +! A1.5,6 Thermodynamic liquid,solid phases + REAL RCW,RCS +! A1.7 Thermodynamic transition of phase + REAL RLVTT,RLSTT,RLMLT,RTT,RATM +! A1.8 Curve of saturation + REAL RESTT,RALPW,RBETW,RGAMW,RALPS,RBETS,RGAMS + REAL RALPD,RBETD,RGAMD +! + COMMON/YOMCST/RPI ,RCLUM ,RHPLA ,RKBOL ,RNAVO & + & ,RDAY ,REA ,REPSM ,RSIYEA,RSIDAY,ROMEGA & + & ,R_ecc, R_peri, R_incl & + & ,RA ,RG ,R1SA & + & ,RSIGMA & + & ,R ,RMD ,RMO3 ,RMV ,RD ,RV ,RCPD & + & ,RCPV ,RCVD ,RCVV ,RKAPPA,RETV & + & ,RCW ,RCS & + & ,RLVTT ,RLSTT ,RLMLT ,RTT ,RATM & + & ,RESTT ,RALPW ,RBETW ,RGAMW ,RALPS ,RBETS ,RGAMS & + & ,RALPD ,RBETD ,RGAMD +! ------------------------------------------------------------------ +!$OMP THREADPRIVATE(/YOMCST/) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/YOMCST2.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/YOMCST2.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/YOMCST2.h (revision 1280) @@ -0,0 +1,13 @@ + + INTEGER choice, iflag_mix + REAL gammas, alphas, betas, Fmax, qqa1, qqa2, qqa3, scut + REAL Qcoef1max,Qcoef2max,Supcrit1,Supcrit2 +! + COMMON/YOMCST2/gammas, alphas, betas, Fmax, scut, & + & qqa1, qqa2, qqa3, & + & Qcoef1max,Qcoef2max, & + & Supcrit1, Supcrit2, & + & choice,iflag_mix +!$OMP THREADPRIVATE(/YOMCST2/) +! -------------------------------------------------------------------- + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/aaam_bud.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/aaam_bud.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/aaam_bud.F (revision 1280) @@ -0,0 +1,367 @@ +! +! $Header$ +! + subroutine aaam_bud (iam,nlon,nlev,rjour,rsec, + i rea,rg,ome, + i plat,plon,phis, + i dragu,liftu,phyu, + i dragv,liftv,phyv, + i p, u, v, + o aam, torsfc) +c + use dimphy + implicit none +c====================================================================== +c Auteur(s): F.Lott (LMD/CNRS) date: 20031020 +c Object: Compute different terms of the axial AAAM Budget. +C No outputs, every AAM quantities are written on the IAM +C File. +c +c Modif : I.Musat (LMD/CNRS) date : 20041020 +c Outputs : axial components of wind AAM "aam" and total surface torque "torsfc", +c but no write in the iam file. +c +C WARNING: Only valid for regular rectangular grids. +C REMARK: CALL DANS PHYSIQ AFTER lift_noro: +C CALL aaam_bud (27,klon,klev,rjourvrai,gmtime, +C C ra,rg,romega, +C C rlat,rlon,pphis, +C C zustrdr,zustrli,zustrph, +C C zvstrdr,zvstrli,zvstrph, +C C paprs,u,v) +C +C====================================================================== +c Explicit Arguments: +c ================== +c iam-----input-I-File number where AAMs and torques are written +c It is a formatted file that has been opened +c in physiq.F +c nlon----input-I-Total number of horizontal points that get into physics +c nlev----input-I-Number of vertical levels +c rjour -R-Jour compte depuis le debut de la simu (run.def) +c rsec -R-Seconde de la journee +c rea -R-Earth radius +c rg -R-gravity constant +c ome -R-Earth rotation rate +c plat ---input-R-Latitude en degres +c plon ---input-R-Longitude en degres +c phis ---input-R-Geopotential at the ground +c dragu---input-R-orodrag stress (zonal) +c liftu---input-R-orolift stress (zonal) +c phyu----input-R-Stress total de la physique (zonal) +c dragv---input-R-orodrag stress (Meridional) +c liftv---input-R-orolift stress (Meridional) +c phyv----input-R-Stress total de la physique (Meridional) +c p-------input-R-Pressure (Pa) at model half levels +c u-------input-R-Horizontal wind (m/s) +c v-------input-R-Meridional wind (m/s) +c aam-----output-R-Axial Wind AAM (=raam(3)) +c torsfc--output-R-Total surface torque (=tmou(3)+tsso(3)+tbls(3)) +c +c Implicit Arguments: +c =================== +c +c iim--common-I: Number of longitude intervals +c jjm--common-I: Number of latitude intervals +c klon-common-I: Number of points seen by the physics +c iim*(jjm-1)+2 for instance +c klev-common-I: Number of vertical layers +c====================================================================== +c Local Variables: +c ================ +c dlat-----R: Latitude increment (Radians) +c dlon-----R: Longitude increment (Radians) +c raam ---R: Wind AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale) +c oaam ---R: Mass AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale) +c tmou-----R: Resolved Mountain torque (3 components) +c tsso-----R: Parameterised Moutain drag torque (3 components) +c tbls-----R: Parameterised Boundary layer torque (3 components) +c +c LOCAL ARRAY: +c =========== +c zs ---R: Topographic height +c ps ---R: Surface Pressure +c ub ---R: Barotropic wind zonal +c vb ---R: Barotropic wind meridional +c zlat ---R: Latitude in radians +c zlon ---R: Longitude in radians +c====================================================================== + +#include "dimensions.h" +ccc#include "dimphy.h" +c +c ARGUMENTS +c + INTEGER iam,nlon,nlev + REAL, intent(in):: rjour,rsec,rea,rg,ome + REAL plat(nlon),plon(nlon),phis(nlon) + REAL dragu(nlon),liftu(nlon),phyu(nlon) + REAL dragv(nlon),liftv(nlon),phyv(nlon) + REAL p(nlon,nlev+1), u(nlon,nlev), v(nlon,nlev) +c +c Variables locales: +c + INTEGER i,j,k,l + REAL xpi,hadley,hadday + REAL dlat,dlon + REAL raam(3),oaam(3),tmou(3),tsso(3),tbls(3) + integer iax +cIM ajout aam, torsfc +c aam = composante axiale du Wind AAM raam +c torsfc = composante axiale de (tmou+tsso+tbls) + REAL aam, torsfc + + REAL ZS(801,401),PS(801,401) + REAL UB(801,401),VB(801,401) + REAL SSOU(801,401),SSOV(801,401) + REAL BLSU(801,401),BLSV(801,401) + REAL ZLON(801),ZLAT(401) +C +C PUT AAM QUANTITIES AT ZERO: +C + if(iim+1.gt.801.or.jjm+1.gt.401)then + print *,' Pb de dimension dans aaam_bud' + stop + endif + + xpi=acos(-1.) + hadley=1.e18 + hadday=1.e18*24.*3600. + dlat=xpi/float(jjm) + dlon=2.*xpi/float(iim) + + do iax=1,3 + oaam(iax)=0. + raam(iax)=0. + tmou(iax)=0. + tsso(iax)=0. + tbls(iax)=0. + enddo + +C MOUNTAIN HEIGHT, PRESSURE AND BAROTROPIC WIND: + +C North pole values (j=1): + + l=1 + + ub(1,1)=0. + vb(1,1)=0. + do k=1,nlev + ub(1,1)=ub(1,1)+u(l,k)*(p(l,k)-p(l,k+1))/rg + vb(1,1)=vb(1,1)+v(l,k)*(p(l,k)-p(l,k+1))/rg + enddo + + zlat(1)=plat(l)*xpi/180. + + do i=1,iim+1 + + zs(i,1)=phis(l)/rg + ps(i,1)=p(l,1) + ub(i,1)=ub(1,1) + vb(i,1)=vb(1,1) + ssou(i,1)=dragu(l)+liftu(l) + ssov(i,1)=dragv(l)+liftv(l) + blsu(i,1)=phyu(l)-dragu(l)-liftu(l) + blsv(i,1)=phyv(l)-dragv(l)-liftv(l) + + enddo + + + do j = 2,jjm + +C Values at Greenwich (Periodicity) + + zs(iim+1,j)=phis(l+1)/rg + ps(iim+1,j)=p(l+1,1) + ssou(iim+1,j)=dragu(l+1)+liftu(l+1) + ssov(iim+1,j)=dragv(l+1)+liftv(l+1) + blsu(iim+1,j)=phyu(l+1)-dragu(l+1)-liftu(l+1) + blsv(iim+1,j)=phyv(l+1)-dragv(l+1)-liftv(l+1) + zlon(iim+1)=-plon(l+1)*xpi/180. + zlat(j)=plat(l+1)*xpi/180. + + ub(iim+1,j)=0. + vb(iim+1,j)=0. + do k=1,nlev + ub(iim+1,j)=ub(iim+1,j)+u(l+1,k)*(p(l+1,k)-p(l+1,k+1))/rg + vb(iim+1,j)=vb(iim+1,j)+v(l+1,k)*(p(l+1,k)-p(l+1,k+1))/rg + enddo + + + do i=1,iim + + l=l+1 + zs(i,j)=phis(l)/rg + ps(i,j)=p(l,1) + ssou(i,j)=dragu(l)+liftu(l) + ssov(i,j)=dragv(l)+liftv(l) + blsu(i,j)=phyu(l)-dragu(l)-liftu(l) + blsv(i,j)=phyv(l)-dragv(l)-liftv(l) + zlon(i)=plon(l)*xpi/180. + + ub(i,j)=0. + vb(i,j)=0. + do k=1,nlev + ub(i,j)=ub(i,j)+u(l,k)*(p(l,k)-p(l,k+1))/rg + vb(i,j)=vb(i,j)+v(l,k)*(p(l,k)-p(l,k+1))/rg + enddo + + enddo + + enddo + + +C South Pole + + if (jjm.GT.1) then + l=l+1 + ub(1,jjm+1)=0. + vb(1,jjm+1)=0. + do k=1,nlev + ub(1,jjm+1)=ub(1,jjm+1)+u(l,k)*(p(l,k)-p(l,k+1))/rg + vb(1,jjm+1)=vb(1,jjm+1)+v(l,k)*(p(l,k)-p(l,k+1))/rg + enddo + zlat(jjm+1)=plat(l)*xpi/180. + + do i=1,iim+1 + zs(i,jjm+1)=phis(l)/rg + ps(i,jjm+1)=p(l,1) + ssou(i,jjm+1)=dragu(l)+liftu(l) + ssov(i,jjm+1)=dragv(l)+liftv(l) + blsu(i,jjm+1)=phyu(l)-dragu(l)-liftu(l) + blsv(i,jjm+1)=phyv(l)-dragv(l)-liftv(l) + ub(i,jjm+1)=ub(1,jjm+1) + vb(i,jjm+1)=vb(1,jjm+1) + enddo + endif + +C +C MOMENT ANGULAIRE +C + DO j=1,jjm + DO i=1,iim + + raam(1)=raam(1)-rea**3*dlon*dlat*0.5* + c (cos(zlon(i ))*sin(zlat(j ))*cos(zlat(j ))*ub(i ,j ) + c +cos(zlon(i ))*sin(zlat(j+1))*cos(zlat(j+1))*ub(i ,j+1)) + c +rea**3*dlon*dlat*0.5* + c (sin(zlon(i ))*cos(zlat(j ))*vb(i ,j ) + c +sin(zlon(i ))*cos(zlat(j+1))*vb(i ,j+1)) + + oaam(1)=oaam(1)-ome*rea**4*dlon*dlat/rg*0.5* + c (cos(zlon(i ))*cos(zlat(j ))**2*sin(zlat(j ))*ps(i ,j ) + c +cos(zlon(i ))*cos(zlat(j+1))**2*sin(zlat(j+1))*ps(i ,j+1)) + + raam(2)=raam(2)-rea**3*dlon*dlat*0.5* + c (sin(zlon(i ))*sin(zlat(j ))*cos(zlat(j ))*ub(i ,j ) + c +sin(zlon(i ))*sin(zlat(j+1))*cos(zlat(j+1))*ub(i ,j+1)) + c -rea**3*dlon*dlat*0.5* + c (cos(zlon(i ))*cos(zlat(j ))*vb(i ,j ) + c +cos(zlon(i ))*cos(zlat(j+1))*vb(i ,j+1)) + + oaam(2)=oaam(2)-ome*rea**4*dlon*dlat/rg*0.5* + c (sin(zlon(i ))*cos(zlat(j ))**2*sin(zlat(j ))*ps(i ,j ) + c +sin(zlon(i ))*cos(zlat(j+1))**2*sin(zlat(j+1))*ps(i ,j+1)) + + raam(3)=raam(3)+rea**3*dlon*dlat*0.5* + c (cos(zlat(j))**2*ub(i,j)+cos(zlat(j+1))**2*ub(i,j+1)) + + oaam(3)=oaam(3)+ome*rea**4*dlon*dlat/rg*0.5* + c (cos(zlat(j))**3*ps(i,j)+cos(zlat(j+1))**3*ps(i,j+1)) + + ENDDO + ENDDO + +C +C COUPLE DES MONTAGNES: +C + + DO j=1,jjm + DO i=1,iim + tmou(1)=tmou(1)-rea**2*dlon*0.5*sin(zlon(i)) + c *(zs(i,j)-zs(i,j+1)) + c *(cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j)) + tmou(2)=tmou(2)+rea**2*dlon*0.5*cos(zlon(i)) + c *(zs(i,j)-zs(i,j+1)) + c *(cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j)) + ENDDO + ENDDO + + DO j=2,jjm + DO i=1,iim + tmou(1)=tmou(1)+rea**2*dlat*0.5*sin(zlat(j)) + c *(zs(i+1,j)-zs(i,j)) + c *(cos(zlon(i+1))*ps(i+1,j)+cos(zlon(i))*ps(i,j)) + tmou(2)=tmou(2)+rea**2*dlat*0.5*sin(zlat(j)) + c *(zs(i+1,j)-zs(i,j)) + c *(sin(zlon(i+1))*ps(i+1,j)+sin(zlon(i))*ps(i,j)) + tmou(3)=tmou(3)-rea**2*dlat*0.5* + c cos(zlat(j))*(zs(i+1,j)-zs(i,j))*(ps(i+1,j)+ps(i,j)) + ENDDO + ENDDO + +C +C COUPLES DES DIFFERENTES FRICTION AU SOL: +C + l=1 + DO j=2,jjm + DO i=1,iim + l=l+1 + tsso(1)=tsso(1)-rea**3*cos(zlat(j))*dlon*dlat* + c ssou(i,j) *sin(zlat(j))*cos(zlon(i)) + c +rea**3*cos(zlat(j))*dlon*dlat* + c ssov(i,j) *sin(zlon(i)) + + tsso(2)=tsso(2)-rea**3*cos(zlat(j))*dlon*dlat* + c ssou(i,j) *sin(zlat(j))*sin(zlon(i)) + c -rea**3*cos(zlat(j))*dlon*dlat* + c ssov(i,j) *cos(zlon(i)) + + tsso(3)=tsso(3)+rea**3*cos(zlat(j))*dlon*dlat* + c ssou(i,j) *cos(zlat(j)) + + tbls(1)=tbls(1)-rea**3*cos(zlat(j))*dlon*dlat* + c blsu(i,j) *sin(zlat(j))*cos(zlon(i)) + c +rea**3*cos(zlat(j))*dlon*dlat* + c blsv(i,j) *sin(zlon(i)) + + tbls(2)=tbls(2)-rea**3*cos(zlat(j))*dlon*dlat* + c blsu(i,j) *sin(zlat(j))*sin(zlon(i)) + c -rea**3*cos(zlat(j))*dlon*dlat* + c blsv(i,j) *cos(zlon(i)) + + tbls(3)=tbls(3)+rea**3*cos(zlat(j))*dlon*dlat* + c blsu(i,j) *cos(zlat(j)) + + ENDDO + ENDDO + + +c write(*,*) 'AAM',rsec, +c write(*,*) 'AAM',rjour+rsec/86400., +c c raam(3)/hadday,oaam(3)/hadday, +c c tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley + +c write(iam,100)rjour+rsec/86400., +c c raam(1)/hadday,oaam(1)/hadday, +c c tmou(1)/hadley,tsso(1)/hadley,tbls(1)/hadley, +c c raam(2)/hadday,oaam(2)/hadday, +c c tmou(2)/hadley,tsso(2)/hadley,tbls(2)/hadley, +c c raam(3)/hadday,oaam(3)/hadday, +c c tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley +100 format(F12.5,15(1x,F12.5)) + +c write(iam+1,*)((zs(i,j),i=1,iim),j=1,jjm+1) +c write(iam+1,*)((ps(i,j),i=1,iim),j=1,jjm+1) +c write(iam+1,*)((ub(i,j),i=1,iim),j=1,jjm+1) +c write(iam+1,*)((vb(i,j),i=1,iim),j=1,jjm+1) +c write(iam+1,*)((ssou(i,j),i=1,iim),j=1,jjm+1) +c write(iam+1,*)((ssov(i,j),i=1,iim),j=1,jjm+1) +c write(iam+1,*)((blsu(i,j),i=1,iim),j=1,jjm+1) +c write(iam+1,*)((blsv(i,j),i=1,iim),j=1,jjm+1) +c + aam=raam(3) + torsfc= tmou(3)+tsso(3)+tbls(3) +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/add_phys_tend.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/add_phys_tend.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/add_phys_tend.F90 (revision 1280) @@ -0,0 +1,193 @@ +! +! $Id$ +! +SUBROUTINE add_phys_tend (zdu,zdv,zdt,zdq,zdql,text) +!====================================================================== +! Ajoute les tendances des variables physiques aux variables +! d'etat de la dynamique t_seri, q_seri ... +! On en profite pour faire des tests sur les tendances en question. +!====================================================================== + + +!====================================================================== +! Declarations +!====================================================================== + +use dimphy +use phys_local_var_mod +use phys_state_var_mod +IMPLICIT none +#include "iniprint.h" + +! Arguments : +!------------ +REAL zdu(klon,klev),zdv(klon,klev) +REAL zdt(klon,klev),zdq(klon,klev),zdql(klon,klev) +CHARACTER*(*) text + +! Local : +!-------- +REAL zt,zq + +INTEGER i, k,j +INTEGER jadrs(klon*klev), jbad +INTEGER jqadrs(klon*klev), jqbad +INTEGER kadrs(klon*klev) +INTEGER kqadrs(klon*klev) + +integer debug_level +logical, save :: first=.true. +!$OMP THREADPRIVATE(first) +INTEGER, SAVE :: itap +!$OMP THREADPRIVATE(itap) +!====================================================================== +! Initialisations + +debug_level=10 + if (first) then + itap=0 + first=.false. + endif +! Incrementer le compteur de la physique + itap = itap + 1 +!====================================================================== +! Ajout des tendances sur le vent et l'eau liquide +!====================================================================== + + u_seri(:,:)=u_seri(:,:)+zdu(:,:) + v_seri(:,:)=v_seri(:,:)+zdv(:,:) + ql_seri(:,:)=ql_seri(:,:)+zdql(:,:) + +!====================================================================== +! On ajoute les tendances de la temperature et de la vapeur d'eau +! en verifiant que ca ne part pas dans les choux +!====================================================================== + + jbad=0 + jqbad=0 + DO k = 1, klev + DO i = 1, klon + zt=t_seri(i,k)+zdt(i,k) + zq=q_seri(i,k)+zdq(i,k) + IF ( zt>370. .or. zt<130. .or. abs(zdt(i,k))>50. ) then + jbad = jbad + 1 + jadrs(jbad) = i + kadrs(jbad) = k + ENDIF + IF ( zq<0. .or. zq>0.1 .or. abs(zdq(i,k))>1.e-2 ) then + jqbad = jqbad + 1 + jqadrs(jqbad) = i + kqadrs(jqbad) = k + ENDIF + t_seri(i,k)=zt + q_seri(i,k)=zq + ENDDO + ENDDO + +!===================================================================================== +! Impression et stop en cas de probleme important +!===================================================================================== + +IF (jbad .GT. 0) THEN + DO j = 1, jbad + i=jadrs(j) + if(prt_level.ge.debug_level) THEN + print*,'PLANTAGE POUR LE POINT i rlon rlat =',i,rlon(i),rlat(i),text + print*,'l T dT Q dQ ' + DO k = 1, klev + write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k) + ENDDO + call print_debug_phys(i,debug_level,text) + endif + ENDDO +ENDIF +! +!===================================================================================== +! Impression, warning et correction en cas de probleme moins important +!===================================================================================== +IF (jqbad .GT. 0) THEN + DO j = 1, jqbad + i=jqadrs(j) + if(prt_level.ge.debug_level) THEN + print*,'WARNING : EAU POUR LE POINT i rlon rlat =',i,rlon(i),rlat(i),text + print*,'l T dT Q dQ ' + endif + DO k = 1, klev + zq=q_seri(i,k)+zdq(i,k) + if (zq.lt.1.e-15) then + if (q_seri(i,k).lt.1.e-15) then + if(prt_level.ge.debug_level) THEN + print*,' cas q_seri<1.e-15 i k q_seri zq zdq :',i,k,q_seri(i,k),zq,zdq(i,k) + endif + q_seri(i,k)=1.e-15 + zdq(i,k)=(1.e-15-q_seri(i,k)) + endif + endif +! zq=q_seri(i,k)+zdq(i,k) +! if (zq.lt.1.e-15) then +! zdq(i,k)=(1.e-15-q_seri(i,k)) +! endif + ENDDO + ENDDO +ENDIF +! + +!IM ajout memes tests pour reverifier les jbad, jqbad beg + jbad=0 + jqbad=0 + DO k = 1, klev + DO i = 1, klon + IF ( t_seri(i,k)>370. .or. t_seri(i,k)<130. .or. abs(zdt(i,k))>50. ) then + jbad = jbad + 1 + jadrs(jbad) = i +! if(prt_level.ge.debug_level) THEN +! print*,'cas2 i k t_seri zdt',i,k,t_seri(i,k),zdt(i,k) +! endif + ENDIF + IF ( q_seri(i,k)<0. .or. q_seri(i,k)>0.1 .or. abs(zdq(i,k))>1.e-2 ) then + jqbad = jqbad + 1 + jqadrs(jqbad) = i + kqadrs(jqbad) = k +! if(prt_level.ge.debug_level) THEN +! print*,'cas2 i k q_seri zdq',i,k,q_seri(i,k),zdq(i,k) +! endif + ENDIF + ENDDO + ENDDO +IF (jbad .GT. 0) THEN + DO j = 1, jbad + i=jadrs(j) + k=kadrs(j) + if(prt_level.ge.debug_level) THEN + print*,'PLANTAGE2 POUR LE POINT i itap rlon rlat txt jbad zdt t',i,itap,rlon(i),rlat(i),text,jbad, & + & zdt(i,k),t_seri(i,k)-zdt(i,k) +!!! if(prt_level.ge.10.and.itap.GE.229.and.i.EQ.3027) THEN + print*,'l T dT Q dQ ' + DO k = 1, klev + write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k) + ENDDO + call print_debug_phys(i,debug_level,text) + endif + ENDDO +ENDIF +! +IF (jqbad .GT. 0) THEN + DO j = 1, jqbad + i=jqadrs(j) + k=kqadrs(j) + if(prt_level.ge.debug_level) THEN + print*,'WARNING : EAU2 POUR LE POINT i itap rlon rlat txt jqbad zdq q zdql ql',i,itap,rlon(i),rlat(i),text,jqbad,& + & zdq(i,k), q_seri(i,k)-zdq(i,k), zdql(i,k), ql_seri(i,k)-zdql(i,k) +!!! if(prt_level.ge.10.and.itap.GE.229.and.i.EQ.3027) THEN + print*,'l T dT Q dQ ' + DO k = 1, klev + write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k) + ENDDO + call print_debug_phys(i,debug_level,text) + endif + ENDDO +ENDIF + + CALL hgardfou(t_seri,ftsol,text) + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/aero_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/aero_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/aero_mod.F90 (revision 1280) @@ -0,0 +1,68 @@ +! $Id$ +! +MODULE aero_mod + ! Declaration des indices pour les aerosols + + ! Total number of aerosols + INTEGER, PARAMETER :: naero_tot = 10 + + ! Identification number used in aeropt_2bands and aeropt_5wv + ! corresponding to naero_tot + INTEGER, PARAMETER :: id_ASBCM = 1 + INTEGER, PARAMETER :: id_ASPOMM = 2 + INTEGER, PARAMETER :: id_ASSO4M = 3 + INTEGER, PARAMETER :: id_CSSO4M = 4 + INTEGER, PARAMETER :: id_SSSSM = 5 + INTEGER, PARAMETER :: id_CSSSM = 6 + INTEGER, PARAMETER :: id_ASSSM = 7 + INTEGER, PARAMETER :: id_CIDUSTM = 8 + INTEGER, PARAMETER :: id_AIBCM = 9 + INTEGER, PARAMETER :: id_AIPOMM = 10 + + ! Total number of aerosols actually used in LMDZ + ! 1 = ASBCM + ! 2 = ASPOMM + ! 3 = ASSO4M ( = SO4) + ! 4 = CSSO4M + ! 5 = SSSSM + ! 6 = CSSSM + ! 7 = ASSSM + ! 8 = CIDUSTM + ! 9 = AIBCM + !10 = AIPOMM + INTEGER, PARAMETER :: naero_spc = 10 + + ! Corresponding names for the aerosols + CHARACTER(len=7),DIMENSION(naero_spc) :: name_aero=(/& + "ASBCM ", & + "ASPOMM ", & + "SO4 ", & + "CSSO4M ", & + "SSSSM ", & + "CSSSM ", & + "ASSSM ", & + "CIDUSTM", & + "AIBCM ", & + "AIPOMM " /) + + + ! Number of aerosol groups + ! 1 = ZERO + ! 2 = AER total + ! 3 = NAT + ! 4 = BC + ! 5 = SO4 + ! 6 = POM + ! 7 = DUST + ! 8 = SS + ! 9 = NO3 + INTEGER, PARAMETER :: naero_grp = 9 + + ! Number of wavelengths + INTEGER, PARAMETER :: nwave = 5 + + ! Number of modes spectral bands + INTEGER, parameter :: nbands = 2 + + +END MODULE aero_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/aeropt.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/aeropt.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/aeropt.F (revision 1280) @@ -0,0 +1,134 @@ +! +! $Header$ +! + SUBROUTINE aeropt(pplay, paprs, t_seri, msulfate, RHcl, + . tau_ae, piz_ae, cg_ae, ai ) +c + USE dimphy + IMPLICIT none +c +c +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c Arguments: +c + REAL, INTENT(in) :: paprs(klon,klev+1) + REAL, INTENT(in) :: pplay(klon,klev), t_seri(klon,klev) + REAL, INTENT(in) :: msulfate(klon,klev) ! masse sulfate ug SO4/m3 [ug/m^3] + REAL, INTENT(in) :: RHcl(klon,klev) ! humidite relative ciel clair + REAL, INTENT(out) :: tau_ae(klon,klev,2) ! epaisseur optique aerosol + REAL, INTENT(out) :: piz_ae(klon,klev,2) ! single scattering albedo aerosol + REAL, INTENT(out) :: cg_ae(klon,klev,2) ! asymmetry parameter aerosol + REAL, INTENT(out) :: ai(klon) ! POLDER aerosol index +c +c Local +c + INTEGER i, k, inu + INTEGER RH_num, nbre_RH + PARAMETER (nbre_RH=12) + REAL RH_tab(nbre_RH) + REAL RH_MAX, DELTA, rh + PARAMETER (RH_MAX=95.) + DATA RH_tab/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./ + REAL zrho, zdz + REAL taue670(klon) ! epaisseur optique aerosol absorption 550 nm + REAL taue865(klon) ! epaisseur optique aerosol extinction 865 nm + REAL alpha_aer_sulfate(nbre_RH,5) !--unit m2/g SO4 + REAL alphasulfate +c +c Proprietes optiques +c + REAL alpha_aer(nbre_RH,2) !--unit m2/g SO4 + REAL cg_aer(nbre_RH,2) + DATA alpha_aer/.500130E+01, .500130E+01, .500130E+01, + . .500130E+01, .500130E+01, .616710E+01, + . .826850E+01, .107687E+02, .136976E+02, + . .162972E+02, .211690E+02, .354833E+02, + . .139460E+01, .139460E+01, .139460E+01, + . .139460E+01, .139460E+01, .173910E+01, + . .244380E+01, .332320E+01, .440120E+01, + . .539570E+01, .734580E+01, .136038E+02 / + DATA cg_aer/.619800E+00, .619800E+00, .619800E+00, + . .619800E+00, .619800E+00, .662700E+00, + . .682100E+00, .698500E+00, .712500E+00, + . .721800E+00, .734600E+00, .755800E+00, + . .545600E+00, .545600E+00, .545600E+00, + . .545600E+00, .545600E+00, .583700E+00, + . .607100E+00, .627700E+00, .645800E+00, + . .658400E+00, .676500E+00, .708500E+00 / + DATA alpha_aer_sulfate/ + . 4.910,4.910,4.910,4.910,6.547,7.373, + . 8.373,9.788,12.167,14.256,17.924,28.433, + . 1.453,1.453,1.453,1.453,2.003,2.321, + . 2.711,3.282,4.287,5.210,6.914,12.305, + . 4.308,4.308,4.308,4.308,5.753,6.521, + . 7.449,8.772,11.014,12.999,16.518,26.772, + . 3.265,3.265,3.265,3.265,4.388,5.016, + . 5.775,6.868,8.745,10.429,13.457,22.538, + . 2.116,2.116,2.116,2.116,2.882,3.330, + . 3.876,4.670,6.059,7.327,9.650,16.883/ +c + DO i=1, klon + taue670(i)=0.0 + taue865(i)=0.0 + ENDDO +c + DO k=1, klev + DO i=1, klon + if (t_seri(i,k).eq.0) write (*,*) 'aeropt T ',i,k,t_seri(i,k) + if (pplay(i,k).eq.0) write (*,*) 'aeropt p ',i,k,pplay(i,k) + zrho=pplay(i,k)/t_seri(i,k)/RD ! kg/m3 + zdz=(paprs(i,k)-paprs(i,k+1))/zrho/RG ! m + rh=MIN(RHcl(i,k)*100.,RH_MAX) + RH_num = INT( rh/10. + 1.) + IF (rh.LT.0.) STOP 'aeropt: RH < 0 not possible' + IF (rh.gt.85.) RH_num=10 + IF (rh.gt.90.) RH_num=11 + DELTA=(rh-RH_tab(RH_num))/(RH_tab(RH_num+1)-RH_tab(RH_num)) +c + inu=1 + tau_ae(i,k,inu)=alpha_aer(RH_num,inu) + + . DELTA*(alpha_aer(RH_num+1,inu)-alpha_aer(RH_num,inu)) + tau_ae(i,k,inu)=tau_ae(i,k,inu)*msulfate(i,k)*zdz*1.e-6 + piz_ae(i,k,inu)=1.0 + cg_ae(i,k,inu)=cg_aer(RH_num,inu) + + . DELTA*(cg_aer(RH_num+1,inu)-cg_aer(RH_num,inu)) +c + inu=2 + tau_ae(i,k,inu)=alpha_aer(RH_num,inu) + + . DELTA*(alpha_aer(RH_num+1,inu)-alpha_aer(RH_num,inu)) + tau_ae(i,k,inu)=tau_ae(i,k,inu)*msulfate(i,k)*zdz*1.e-6 + piz_ae(i,k,inu)=1.0 + cg_ae(i,k,inu)=cg_aer(RH_num,inu) + + . DELTA*(cg_aer(RH_num+1,inu)-cg_aer(RH_num,inu)) +cjq +cjq for aerosol index +c + alphasulfate=alpha_aer_sulfate(RH_num,4) + + . DELTA*(alpha_aer_sulfate(RH_num+1,4)- + . alpha_aer_sulfate(RH_num,4)) !--m2/g +c + taue670(i)=taue670(i)+ + . alphasulfate*msulfate(i,k)*zdz*1.e-6 +c + alphasulfate=alpha_aer_sulfate(RH_num,5) + + . DELTA*(alpha_aer_sulfate(RH_num+1,5)- + . alpha_aer_sulfate(RH_num,5)) !--m2/g +c + taue865(i)=taue865(i)+ + . alphasulfate*msulfate(i,k)*zdz*1.e-6 + + ENDDO + ENDDO +c + DO i=1, klon + ai(i)=(-log(MAX(taue670(i),0.0001)/ + . MAX(taue865(i),0.0001))/log(670./865.)) * + . taue865(i) + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/aeropt_2bands.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/aeropt_2bands.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/aeropt_2bands.F90 (revision 1280) @@ -0,0 +1,1124 @@ +! +! $Id$ +! +SUBROUTINE AEROPT_2BANDS( & + pdel, m_allaer, delt, RHcl, & + tau_allaer, piz_allaer, & + cg_allaer, m_allaer_pi, & + flag_aerosol, pplay, t_seri, presnivs) + + USE dimphy + USE aero_mod + + ! Yves Balkanski le 12 avril 2006 + ! Celine Deandreis + ! Anne Cozic Avril 2009 + ! a partir d'une sous-routine de Johannes Quaas pour les sulfates + ! + IMPLICIT NONE + + INCLUDE "YOMCST.h" + INCLUDE "iniprint.h" + + ! + ! Input arguments: + ! + REAL, DIMENSION(klon,klev), INTENT(in) :: pdel + REAL, INTENT(in) :: delt + REAL, DIMENSION(klon,klev,naero_spc), INTENT(in) :: m_allaer +!RAF + REAL, DIMENSION(klon,klev,naero_spc), INTENT(in) :: m_allaer_pi + REAL, DIMENSION(klon,klev), INTENT(in) :: RHcl ! humidite relative ciel clair +!RAF REAL, DIMENSION(klon,naero_tot),INTENT(in) :: fractnat_allaer + INTEGER, INTENT(in) :: flag_aerosol + REAL, DIMENSION(klon,klev), INTENT(in) :: pplay + REAL, DIMENSION(klon,klev), INTENT(in) :: t_seri + REAL, DIMENSION(klev), INTENT(in) :: presnivs + ! + ! Output arguments: + ! + REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(out) :: tau_allaer ! epaisseur optique aerosol + REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(out) :: piz_allaer ! single scattering albedo aerosol + REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(out) :: cg_allaer ! asymmetry parameter aerosol + + ! + ! Local + ! + REAL, DIMENSION(klon,klev,naero_tot,nbands) :: tau_ae +!RAF + REAL, DIMENSION(klon,klev,naero_tot,nbands) :: tau_ae_pi + REAL, DIMENSION(klon,klev,naero_tot,nbands) :: piz_ae + REAL, DIMENSION(klon,klev,naero_tot,nbands) :: cg_ae + LOGICAL :: soluble + INTEGER :: i, k,n, ierr, inu, m, mrfspecies + INTEGER :: spsol, spinsol, spss + INTEGER :: RH_num(klon,klev) + INTEGER, PARAMETER :: nb_level=19 ! number of vertical levels in DATA + + INTEGER, PARAMETER :: nbre_RH=12 + INTEGER, PARAMETER :: naero_soluble=7 ! 1- BC soluble; 2- POM soluble; 3- SO4. acc. 4- SO4 coarse + ! 5- seasalt super coarse 6- seasalt coarse 7- seasalt acc. + INTEGER, PARAMETER :: naero_insoluble=3 ! 1- Dust; 2- BC insoluble; 3- POM insoluble + LOGICAL, SAVE :: firstcall=.TRUE. +!$OMP THREADPRIVATE(firstcall) + +! Coefficient optiques sur 19 niveaux + REAL, SAVE, DIMENSION(nb_level) :: presnivs_19 ! Pression milieux couche pour 19 niveaux (nb_level) +!$OMP THREADPRIVATE(presnivs_19) + + REAL, SAVE, DIMENSION(nb_level) :: A1_ASSSM_b1_19, A2_ASSSM_b1_19, A3_ASSSM_b1_19,& + B1_ASSSM_b1_19, B2_ASSSM_b1_19, C1_ASSSM_b1_19, C2_ASSSM_b1_19,& + A1_CSSSM_b1_19, A2_CSSSM_b1_19, A3_CSSSM_b1_19,& + B1_CSSSM_b1_19, B2_CSSSM_b1_19, C1_CSSSM_b1_19, C2_CSSSM_b1_19,& + A1_SSSSM_b1_19, A2_SSSSM_b1_19, A3_SSSSM_b1_19,& + B1_SSSSM_b1_19, B2_SSSSM_b1_19, C1_SSSSM_b1_19, C2_SSSSM_b1_19,& + A1_ASSSM_b2_19, A2_ASSSM_b2_19, A3_ASSSM_b2_19,& + B1_ASSSM_b2_19, B2_ASSSM_b2_19, C1_ASSSM_b2_19, C2_ASSSM_b2_19,& + A1_CSSSM_b2_19, A2_CSSSM_b2_19, A3_CSSSM_b2_19,& + B1_CSSSM_b2_19, B2_CSSSM_b2_19, C1_CSSSM_b2_19, C2_CSSSM_b2_19,& + A1_SSSSM_b2_19, A2_SSSSM_b2_19, A3_SSSSM_b2_19,& + B1_SSSSM_b2_19, B2_SSSSM_b2_19, C1_SSSSM_b2_19, C2_SSSSM_b2_19 +!$OMP THREADPRIVATE(A1_ASSSM_b1_19, A2_ASSSM_b1_19, A3_ASSSM_b1_19) +!$OMP THREADPRIVATE(B1_ASSSM_b1_19, B2_ASSSM_b1_19, C1_ASSSM_b1_19, C2_ASSSM_b1_19) +!$OMP THREADPRIVATE(A1_CSSSM_b1_19, A2_CSSSM_b1_19, A3_CSSSM_b1_19) +!$OMP THREADPRIVATE(B1_CSSSM_b1_19, B2_CSSSM_b1_19, C1_CSSSM_b1_19, C2_CSSSM_b1_19) +!$OMP THREADPRIVATE(A1_SSSSM_b1_19, A2_SSSSM_b1_19, A3_SSSSM_b1_19) +!$OMP THREADPRIVATE(B1_SSSSM_b1_19, B2_SSSSM_b1_19, C1_SSSSM_b1_19, C2_SSSSM_b1_19) +!$OMP THREADPRIVATE(A1_ASSSM_b2_19, A2_ASSSM_b2_19, A3_ASSSM_b2_19) +!$OMP THREADPRIVATE(B1_ASSSM_b2_19, B2_ASSSM_b2_19, C1_ASSSM_b2_19, C2_ASSSM_b2_19) +!$OMP THREADPRIVATE(A1_CSSSM_b2_19, A2_CSSSM_b2_19, A3_CSSSM_b2_19) +!$OMP THREADPRIVATE(B1_CSSSM_b2_19, B2_CSSSM_b2_19, C1_CSSSM_b2_19, C2_CSSSM_b2_19) +!$OMP THREADPRIVATE(A1_SSSSM_b2_19, A2_SSSSM_b2_19, A3_SSSSM_b2_19) +!$OMP THREADPRIVATE(B1_SSSSM_b2_19, B2_SSSSM_b2_19, C1_SSSSM_b2_19, C2_SSSSM_b2_19) + + +! Coefficient optiques interpole sur le nombre de niveau du modele + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: & + A1_ASSSM_b1, A2_ASSSM_b1, A3_ASSSM_b1,& + B1_ASSSM_b1, B2_ASSSM_b1, C1_ASSSM_b1, C2_ASSSM_b1,& + A1_CSSSM_b1, A2_CSSSM_b1, A3_CSSSM_b1,& + B1_CSSSM_b1, B2_CSSSM_b1, C1_CSSSM_b1, C2_CSSSM_b1,& + A1_SSSSM_b1, A2_SSSSM_b1, A3_SSSSM_b1,& + B1_SSSSM_b1, B2_SSSSM_b1, C1_SSSSM_b1, C2_SSSSM_b1,& + A1_ASSSM_b2, A2_ASSSM_b2, A3_ASSSM_b2,& + B1_ASSSM_b2, B2_ASSSM_b2, C1_ASSSM_b2, C2_ASSSM_b2,& + A1_CSSSM_b2, A2_CSSSM_b2, A3_CSSSM_b2,& + B1_CSSSM_b2, B2_CSSSM_b2, C1_CSSSM_b2, C2_CSSSM_b2,& + A1_SSSSM_b2, A2_SSSSM_b2, A3_SSSSM_b2,& + B1_SSSSM_b2, B2_SSSSM_b2, C1_SSSSM_b2, C2_SSSSM_b2 +!$OMP THREADPRIVATE(A1_ASSSM_b1, A2_ASSSM_b1, A3_ASSSM_b1) +!$OMP THREADPRIVATE(B1_ASSSM_b1, B2_ASSSM_b1, C1_ASSSM_b1, C2_ASSSM_b1) +!$OMP THREADPRIVATE(A1_CSSSM_b1, A2_CSSSM_b1, A3_CSSSM_b1) +!$OMP THREADPRIVATE(B1_CSSSM_b1, B2_CSSSM_b1, C1_CSSSM_b1, C2_CSSSM_b1) +!$OMP THREADPRIVATE(A1_SSSSM_b1, A2_SSSSM_b1, A3_SSSSM_b1) +!$OMP THREADPRIVATE(B1_SSSSM_b1, B2_SSSSM_b1, C1_SSSSM_b1, C2_SSSSM_b1) +!$OMP THREADPRIVATE(A1_ASSSM_b2, A2_ASSSM_b2, A3_ASSSM_b2) +!$OMP THREADPRIVATE(B1_ASSSM_b2, B2_ASSSM_b2, C1_ASSSM_b2, C2_ASSSM_b2) +!$OMP THREADPRIVATE(A1_CSSSM_b2, A2_CSSSM_b2, A3_CSSSM_b2) +!$OMP THREADPRIVATE(B1_CSSSM_b2, B2_CSSSM_b2, C1_CSSSM_b2, C2_CSSSM_b2) +!$OMP THREADPRIVATE(A1_SSSSM_b2, A2_SSSSM_b2, A3_SSSSM_b2) +!$OMP THREADPRIVATE(B1_SSSSM_b2, B2_SSSSM_b2, C1_SSSSM_b2, C2_SSSSM_b2) + + REAL,PARAMETER :: RH_tab(nbre_RH)=(/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./) + REAL, PARAMETER :: RH_MAX=95. + REAL:: DELTA(klon,klev), rh(klon,klev), H + REAL:: tau_ae2b_int ! Intermediate computation of epaisseur optique aerosol + REAL:: piz_ae2b_int ! Intermediate computation of Single scattering albedo + REAL:: cg_ae2b_int ! Intermediate computation of Assymetry parameter + REAL :: Fact_RH(nbre_RH) + REAL :: zrho + REAL :: fac + REAL :: zdp1(klon,klev) + REAL, PARAMETER :: gravit = 9.80616 ! m2/s + INTEGER, ALLOCATABLE, DIMENSION(:) :: aerosol_name + INTEGER :: nb_aer + REAL, DIMENSION(klon,klev,naero_spc) :: mass_temp +!RAF + REAL, DIMENSION(klon,klev,naero_spc) :: mass_temp_pi + + ! + ! Proprietes optiques + ! + REAL:: alpha_aers_2bands(nbre_RH,nbands,naero_soluble) !--unit m2/g SO4 + REAL:: alpha_aeri_2bands(nbands,naero_insoluble) + REAL:: cg_aers_2bands(nbre_RH,nbands,naero_soluble) !--unit + REAL:: cg_aeri_2bands(nbands,naero_insoluble) + REAL:: piz_aers_2bands(nbre_RH,nbands,naero_soluble) !-- unit + REAL:: piz_aeri_2bands(nbands,naero_insoluble) !-- unit + + INTEGER :: id + LOGICAL :: used_aer(naero_tot) + REAL :: tmp_var, tmp_var_pi + + DATA presnivs_19/& + 100426.5, 98327.6, 95346.5, 90966.8, 84776.9, & + 76536.5, 66292.2, 54559.3, 42501.8, 31806, & + 23787.5, 18252.7, 13996, 10320.8, 7191.1, & + 4661.7, 2732.9, 1345.6, 388.2/ + + +!***********************BAND 1*********************************** +!ACCUMULATION MODE + DATA A1_ASSSM_b1_19/ 4.373E+00, 4.361E+00, 4.331E+00, & + 4.278E+00, 4.223E+00, 4.162E+00, & + 4.103E+00, 4.035E+00, 3.962E+00, & + 3.904E+00, 3.871E+00, 3.847E+00, & + 3.824E+00, 3.780E+00, 3.646E+00, & + 3.448E+00, 3.179E+00, 2.855E+00, 2.630E+00/ + DATA A2_ASSSM_b1_19/ 2.496E+00, 2.489E+00, 2.472E+00, & + 2.442E+00, 2.411E+00, 2.376E+00, & + 2.342E+00, 2.303E+00, 2.261E+00, & + 2.228E+00, 2.210E+00, 2.196E+00, & + 2.183E+00, 2.158E+00, 2.081E+00, & + 1.968E+00, 1.814E+00, 1.630E+00, 1.501E+00/ + DATA A3_ASSSM_b1_19/-4.688E-02, -4.676E-02, -4.644E-02, & + -4.587E-02, -4.528E-02, -4.463E-02, & + -4.399E-02, -4.326E-02, -4.248E-02, & + -4.186E-02, -4.151E-02, -4.125E-02, & + -4.100E-02, -4.053E-02, -3.910E-02, & + -3.697E-02, -3.408E-02, -3.061E-02, -2.819E-02/ + DATA B1_ASSSM_b1_19/ 1.165E-08, 1.145E-08, 1.097E-08, & + 1.012E-08, 9.233E-09, 8.261E-09, & + 7.297E-09, 6.201E-09, 5.026E-09, & + 4.098E-09, 3.567E-09, 3.187E-09, & + 2.807E-09, 2.291E-09, 2.075E-09, & + 1.756E-09, 1.322E-09, 8.011E-10, 4.379E-10/ + DATA B2_ASSSM_b1_19/ 2.193E-08, 2.192E-08, 2.187E-08, & + 2.179E-08, 2.171E-08, 2.162E-08, & + 2.153E-08, 2.143E-08, 2.132E-08, & + 2.124E-08, 2.119E-08, 2.115E-08, & + 2.112E-08, 2.106E-08, 2.100E-08, & + 2.090E-08, 2.077E-08, 2.061E-08, 2.049E-08/ + DATA C1_ASSSM_b1_19/ 7.365E-01, 7.365E-01, 7.365E-01, & + 7.364E-01, 7.363E-01, 7.362E-01, & + 7.361E-01, 7.359E-01, 7.358E-01, & + 7.357E-01, 7.356E-01, 7.356E-01, & + 7.356E-01, 7.355E-01, 7.354E-01, & + 7.352E-01, 7.350E-01, 7.347E-01, 7.345E-01/ + DATA C2_ASSSM_b1_19/ 5.833E-02, 5.835E-02, 5.841E-02, & + 5.850E-02, 5.859E-02, 5.870E-02, & + 5.880E-02, 5.891E-02, 5.904E-02, & + 5.914E-02, 5.920E-02, 5.924E-02, & + 5.928E-02, 5.934E-02, 5.944E-02, & + 5.959E-02, 5.979E-02, 6.003E-02, 6.020E-02/ +!COARSE MODE + DATA A1_CSSSM_b1_19/ 7.403E-01, 7.422E-01, 7.626E-01, & + 8.019E-01, 8.270E-01, 8.527E-01, & + 8.702E-01, 8.806E-01, 8.937E-01, & + 9.489E-01, 1.030E+00, 1.105E+00, & + 1.199E+00, 1.357E+00, 1.660E+00, & + 2.540E+00, 4.421E+00, 2.151E+00, 9.518E-01/ + DATA A2_CSSSM_b1_19/ 4.522E-01, 4.532E-01, 4.644E-01, & + 4.859E-01, 4.996E-01, 5.137E-01, & + 5.233E-01, 5.290E-01, 5.361E-01, & + 5.655E-01, 6.085E-01, 6.483E-01, & + 6.979E-01, 7.819E-01, 9.488E-01, & + 1.450E+00, 2.523E+00, 1.228E+00, 5.433E-01/ + DATA A3_CSSSM_b1_19/-8.516E-03, -8.535E-03, -8.744E-03, & + -9.148E-03, -9.406E-03, -9.668E-03, & + -9.848E-03, -9.955E-03, -1.009E-02, & + -1.064E-02, -1.145E-02, -1.219E-02, & + -1.312E-02, -1.470E-02, -1.783E-02, & + -2.724E-02, -4.740E-02, -2.306E-02, -1.021E-02/ + DATA B1_CSSSM_b1_19/ 2.535E-07, 2.530E-07, 2.479E-07, & + 2.380E-07, 2.317E-07, 2.252E-07, & + 2.208E-07, 2.182E-07, 2.149E-07, & + 2.051E-07, 1.912E-07, 1.784E-07, & + 1.624E-07, 1.353E-07, 1.012E-07, & + 6.016E-08, 2.102E-08, 0.000E+00, 0.000E+00/ + DATA B2_CSSSM_b1_19/ 1.221E-07, 1.217E-07, 1.179E-07, & + 1.104E-07, 1.056E-07, 1.008E-07, & + 9.744E-08, 9.546E-08, 9.299E-08, & + 8.807E-08, 8.150E-08, 7.544E-08, & + 6.786E-08, 5.504E-08, 4.080E-08, & + 2.960E-08, 2.300E-08, 2.030E-08, 1.997E-08/ + DATA C1_CSSSM_b1_19/ 7.659E-01, 7.658E-01, 7.652E-01, & + 7.639E-01, 7.631E-01, 7.623E-01, & + 7.618E-01, 7.614E-01, 7.610E-01, & + 7.598E-01, 7.581E-01, 7.566E-01, & + 7.546E-01, 7.513E-01, 7.472E-01, & + 7.423E-01, 7.376E-01, 7.342E-01, 7.334E-01/ + DATA C2_CSSSM_b1_19/ 3.691E-02, 3.694E-02, 3.729E-02, & + 3.796E-02, 3.839E-02, 3.883E-02, & + 3.913E-02, 3.931E-02, 3.953E-02, & + 4.035E-02, 4.153E-02, 4.263E-02, & + 4.400E-02, 4.631E-02, 4.933E-02, & + 5.331E-02, 5.734E-02, 6.053E-02, 6.128E-02/ +!SUPER COARSE MODE + DATA A1_SSSSM_b1_19/ 2.836E-01, 2.876E-01, 2.563E-01, & + 2.414E-01, 2.541E-01, 2.546E-01, & + 2.572E-01, 2.638E-01, 2.781E-01, & + 3.167E-01, 4.209E-01, 5.286E-01, & + 6.959E-01, 9.233E-01, 1.282E+00, & + 1.836E+00, 2.981E+00, 4.355E+00, 4.059E+00/ + DATA A2_SSSSM_b1_19/ 1.608E-01, 1.651E-01, 1.577E-01, & + 1.587E-01, 1.686E-01, 1.690E-01, & + 1.711E-01, 1.762E-01, 1.874E-01, & + 2.138E-01, 2.751E-01, 3.363E-01, & + 4.279E-01, 5.519E-01, 7.421E-01, & + 1.048E+00, 1.702E+00, 2.485E+00, 2.317E+00/ + DATA A3_SSSSM_b1_19/-3.025E-03, -3.111E-03, -2.981E-03, & + -3.005E-03, -3.193E-03, -3.200E-03, & + -3.239E-03, -3.336E-03, -3.548E-03, & + -4.047E-03, -5.196E-03, -6.345E-03, & + -8.061E-03, -1.038E-02, -1.395E-02, & + -1.970E-02, -3.197E-02, -4.669E-02, -4.352E-02/ + DATA B1_SSSSM_b1_19/ 6.759E-07, 6.246E-07, 5.542E-07, & + 4.953E-07, 4.746E-07, 4.738E-07, & + 4.695E-07, 4.588E-07, 4.354E-07, & + 3.947E-07, 3.461E-07, 3.067E-07, & + 2.646E-07, 2.095E-07, 1.481E-07, & + 9.024E-08, 5.747E-08, 2.384E-08, 6.599E-09/ + DATA B2_SSSSM_b1_19/ 5.977E-07, 5.390E-07, 4.468E-07, & + 3.696E-07, 3.443E-07, 3.433E-07, & + 3.380E-07, 3.249E-07, 2.962E-07, & + 2.483E-07, 1.989E-07, 1.623E-07, & + 1.305E-07, 9.015E-08, 6.111E-08, & + 3.761E-08, 2.903E-08, 2.337E-08, 2.147E-08/ + DATA C1_SSSSM_b1_19/ 8.120E-01, 8.084E-01, 8.016E-01, & + 7.953E-01, 7.929E-01, 7.928E-01, & + 7.923E-01, 7.910E-01, 7.882E-01, & + 7.834E-01, 7.774E-01, 7.725E-01, & + 7.673E-01, 7.604E-01, 7.529E-01, & + 7.458E-01, 7.419E-01, 7.379E-01, 7.360E-01/ + DATA C2_SSSSM_b1_19/ 2.388E-02, 2.392E-02, 2.457E-02, 2.552E-02, & + 2.615E-02, 2.618E-02, 2.631E-02, 2.663E-02, & + 2.735E-02, 2.875E-02, 3.113E-02, 3.330E-02, & + 3.615E-02, 3.997E-02, 4.521E-02, 5.038E-02, & + 5.358E-02, 5.705E-02, 5.887E-02/ +!*********************BAND 2************************************************ +!ACCUMULATION MODE + DATA A1_ASSSM_b2_19/1.256E+00, 1.246E+00, 1.226E+00, 1.187E+00, 1.148E+00, & + 1.105E+00, 1.062E+00, 1.014E+00, 9.616E-01, 9.205E-01, & + 8.970E-01, 8.800E-01, 8.632E-01, 8.371E-01, 7.943E-01, & + 7.308E-01, 6.448E-01, 5.414E-01, 4.693E-01/ + DATA A2_ASSSM_b2_19/5.321E-01, 5.284E-01, 5.196E-01, 5.036E-01, 4.872E-01, & + 4.691E-01, 4.512E-01, 4.308E-01, 4.089E-01, 3.917E-01, & + 3.818E-01, 3.747E-01, 3.676E-01, 3.567E-01, 3.385E-01, & + 3.116E-01, 2.751E-01, 2.312E-01, 2.006E-01/ + DATA A3_ASSSM_b2_19/-1.053E-02, -1.046E-02, -1.028E-02, -9.964E-03, -9.637E-03, & + -9.279E-03, -8.923E-03, -8.518E-03, -8.084E-03, -7.741E-03, & + -7.545E-03, -7.405E-03, -7.265E-03, -7.048E-03, -6.687E-03, & + -6.156E-03, -5.433E-03, -4.565E-03, -3.961E-03/ + DATA B1_ASSSM_b2_19/1.560E-02, 1.560E-02, 1.561E-02, 1.565E-02, 1.568E-02, & + 1.572E-02, 1.576E-02, 1.580E-02, 1.584E-02, 1.588E-02, & + 1.590E-02, 1.592E-02, 1.593E-02, 1.595E-02, 1.599E-02, & + 1.605E-02, 1.612E-02, 1.621E-02, 1.627E-02/ + DATA B2_ASSSM_b2_19/1.073E-02, 1.074E-02, 1.076E-02, 1.079E-02, 1.082E-02, & + 1.085E-02, 1.089E-02, 1.093E-02, 1.097E-02, 1.100E-02, & + 1.102E-02, 1.103E-02, 1.105E-02, 1.107E-02, 1.110E-02, & + 1.115E-02, 1.122E-02, 1.130E-02, 1.136E-02/ + DATA C1_ASSSM_b2_19/7.429E-01, 7.429E-01, 7.429E-01, 7.427E-01, 7.427E-01, & + 7.424E-01, 7.423E-01, 7.422E-01, 7.421E-01, 7.420E-01, & + 7.419E-01, 7.419E-01, 7.418E-01, 7.417E-01, 7.416E-01, & + 7.415E-01, 7.413E-01, 7.409E-01, 7.408E-01/ + DATA C2_ASSSM_b2_19/3.031E-02, 3.028E-02, 3.022E-02, 3.011E-02, 2.999E-02, & + 2.986E-02, 2.973E-02, 2.959E-02, 2.943E-02, 2.931E-02, & + 2.924E-02, 2.919E-02, 2.913E-02, 2.905E-02, 2.893E-02, & + 2.874E-02, 2.847E-02, 2.817E-02, 2.795E-02/ +!COARSE MODE + DATA A1_CSSSM_b2_19/7.061E-01, 7.074E-01, 7.211E-01, 7.476E-01, 7.647E-01, & + 7.817E-01, 7.937E-01, 8.007E-01, 8.095E-01, 8.436E-01, & + 8.932E-01, 9.390E-01, 9.963E-01, 1.093E+00, 1.256E+00, & + 1.668E+00, 1.581E+00, 3.457E-01, 1.331E-01/ + DATA A2_CSSSM_b2_19/3.617E-01, 3.621E-01, 3.662E-01, 3.739E-01, 3.789E-01, & + 3.840E-01, 3.874E-01, 3.895E-01, 3.921E-01, 4.001E-01, & + 4.117E-01, 4.223E-01, 4.356E-01, 4.581E-01, 5.099E-01, & + 6.831E-01, 6.663E-01, 1.481E-01, 5.703E-02/ + DATA A3_CSSSM_b2_19/-6.953E-03, -6.961E-03, -7.048E-03, -7.216E-03, -7.322E-03, & + -7.431E-03, -7.506E-03, -7.551E-03, -7.606E-03, -7.791E-03, & + -8.059E-03, -8.305E-03, -8.613E-03, -9.134E-03, -1.023E-02, & + -1.365E-02, -1.320E-02, -2.922E-03, -1.125E-03/ + DATA B1_CSSSM_b2_19/1.007E-02, 1.008E-02, 1.012E-02, 1.019E-02, 1.024E-02, & + 1.029E-02, 1.033E-02, 1.035E-02, 1.038E-02, 1.056E-02, & + 1.083E-02, 1.109E-02, 1.140E-02, 1.194E-02, 1.270E-02, & + 1.390E-02, 1.524E-02, 1.639E-02, 1.667E-02/ + DATA B2_CSSSM_b2_19/4.675E-03, 4.682E-03, 4.760E-03, 4.908E-03, 5.004E-03, & + 5.102E-03, 5.168E-03, 5.207E-03, 5.256E-03, 5.474E-03, & + 5.793E-03, 6.089E-03, 6.457E-03, 7.081E-03, 7.923E-03, & + 9.127E-03, 1.041E-02, 1.147E-02, 1.173E-02/ + DATA C1_CSSSM_b2_19/7.571E-01, 7.571E-01, 7.570E-01, 7.568E-01, 7.565E-01, & + 7.564E-01, 7.563E-01, 7.562E-01, 7.562E-01, 7.557E-01, & + 7.552E-01, 7.545E-01, 7.539E-01, 7.527E-01, 7.509E-01, & + 7.478E-01, 7.440E-01, 7.404E-01, 7.394E-01/ + DATA C2_CSSSM_b2_19/4.464E-02, 4.465E-02, 4.468E-02, 4.474E-02, 4.477E-02, & + 4.480E-02, 4.482E-02, 4.484E-02, 4.486E-02, 4.448E-02, & + 4.389E-02, 4.334E-02, 4.264E-02, 4.148E-02, 3.957E-02, & + 3.588E-02, 3.149E-02, 2.751E-02, 2.650E-02/ +!SUPER COARSE MODE + DATA A1_SSSSM_b2_19/2.357E-01, 2.490E-01, 2.666E-01, 2.920E-01, 3.120E-01, & + 3.128E-01, 3.169E-01, 3.272E-01, 3.498E-01, 3.960E-01, & + 4.822E-01, 5.634E-01, 6.763E-01, 8.278E-01, 1.047E+00, & + 1.340E+00, 1.927E+00, 1.648E+00, 1.031E+00/ + DATA A2_SSSSM_b2_19/1.219E-01, 1.337E-01, 1.633E-01, 1.929E-01, 2.057E-01, & + 2.062E-01, 2.089E-01, 2.155E-01, 2.300E-01, 2.560E-01, & + 2.908E-01, 3.199E-01, 3.530E-01, 3.965E-01, 4.475E-01, & + 5.443E-01, 7.943E-01, 6.928E-01, 4.381E-01/ + DATA A3_SSSSM_b2_19/-2.387E-03, -2.599E-03, -3.092E-03, -3.599E-03, -3.832E-03, & + -3.842E-03, -3.890E-03, -4.012E-03, -4.276E-03, -4.763E-03, & + -5.455E-03, -6.051E-03, -6.763E-03, -7.708E-03, -8.887E-03, & + -1.091E-02, -1.585E-02, -1.373E-02, -8.665E-03/ + DATA B1_SSSSM_b2_19/1.260E-02, 1.211E-02, 1.126E-02, 1.056E-02, 1.038E-02, & + 1.037E-02, 1.033E-02, 1.023E-02, 1.002E-02, 9.717E-03, & + 9.613E-03, 9.652E-03, 9.983E-03, 1.047E-02, 1.168E-02, & + 1.301E-02, 1.399E-02, 1.514E-02, 1.578E-02/ + DATA B2_SSSSM_b2_19/2.336E-03, 2.419E-03, 2.506E-03, 2.610E-03, 2.690E-03, & + 2.694E-03, 2.711E-03, 2.752E-03, 2.844E-03, 3.043E-03, & + 3.455E-03, 3.871E-03, 4.507E-03, 5.373E-03, 6.786E-03, & + 8.238E-03, 9.208E-03, 1.032E-02, 1.091E-02/ + DATA C1_SSSSM_b2_19/7.832E-01, 7.787E-01, 7.721E-01, 7.670E-01, 7.657E-01, & + 7.657E-01, 7.654E-01, 7.648E-01, 7.634E-01, 7.613E-01, & + 7.596E-01, 7.585E-01, 7.574E-01, 7.560E-01, 7.533E-01, & + 7.502E-01, 7.476E-01, 7.443E-01, 7.423E-01/ + DATA C2_SSSSM_b2_19/3.144E-02, 3.268E-02, 3.515E-02, 3.748E-02, 3.837E-02, & + 3.840E-02, 3.860E-02, 3.906E-02, 4.006E-02, 4.173E-02, & + 4.338E-02, 4.435E-02, 4.459E-02, 4.467E-02, 4.202E-02, & + 3.864E-02, 3.559E-02, 3.183E-02, 2.964E-02/ +!*************************************************************************** + + spsol = 0 + spinsol = 0 + spss = 0 + + DATA alpha_aers_2bands/ & + ! bc soluble + 7.675,7.675,7.675,7.675,7.675,7.675, & + 7.675,7.675,10.433,11.984,13.767,15.567,& + 4.720,4.720,4.720,4.720,4.720,4.720, & + 4.720,4.720,6.081,6.793,7.567,9.344, & + ! pom soluble + 5.503,5.503,5.503,5.503,5.588,5.957, & + 6.404,7.340,8.545,10.319,13.595,20.398, & + 1.402,1.402,1.402,1.402,1.431,1.562, & + 1.715,2.032,2.425,2.991,4.193,7.133, & + ! sulfate + 4.681,5.062,5.460,5.798,6.224,6.733, & + 7.556,8.613,10.687,12.265,16.32,21.692, & + 1.107,1.239,1.381,1.490,1.635,1.8030, & + 2.071,2.407,3.126,3.940,5.539,7.921, & + ! sulfate coarse + 4.681,5.062,5.460,5.798,6.224,6.733, & + 7.556,8.613,10.687,12.265,16.32,21.692, & + 1.107,1.239,1.381,1.490,1.635,1.8030, & + 2.071,2.407,3.126,3.940,5.539,7.921, & + ! seasalt Super Coarse Soluble (SS) + 0.5090,0.6554,0.7129,0.7767,0.8529,1.2728, & + 1.3820,1.5792,1.9173,2.2002,2.7173,4.1487, & + 0.5167,0.6613,0.7221,0.7868,0.8622,1.3027, & + 1.4227,1.6317,1.9887,2.2883,2.8356,4.3453, & + ! seasalt Coarse Soluble (CS) + 0.5090,0.6554,0.7129,0.7767,0.8529,1.2728, & + 1.3820,1.5792,1.9173,2.2002,2.7173,4.1487, & + 0.5167,0.6613,0.7221,0.7868,0.8622,1.3027, & + 1.4227,1.6317,1.9887,2.2883,2.8356,4.3453, & + ! seasalt Accumulation Soluble (AS) + 4.125, 4.674, 5.005, 5.434, 5.985, 10.006, & + 11.175,13.376,17.264,20.540,26.604, 42.349,& + 4.187, 3.939, 3.919, 3.937, 3.995, 5.078, & + 5.511, 6.434, 8.317,10.152,14.024, 26.537/ + + DATA alpha_aeri_2bands/ & + ! dust insoluble + 0.7661,0.7123,& + ! bc insoluble + 10.360,4.437, & + ! pom insoluble + 3.741,0.606/ + + DATA cg_aers_2bands/ & + ! bc soluble + .612, .612, .612, .612, .612, .612, & + .612, .612, .702, .734, .760, .796, & + .433, .433, .433, .433, .433, .433, & + .433, .433, .534, .575, .613, .669, & + ! pom soluble + .663, .663, .663, .663, .666, .674, & + .685, .702, .718, .737, .757, .777, & + .544, .544, .544, .544, .547, .554, & + .565, .583, .604, .631, .661, .698, & + ! sulfate + .658, .669, .680, .688, .698, .707, & + .719, .733, .752, .760, .773, .786, & + .544, .555, .565, .573, .583, .593, & + .610, .628, .655, .666, .692, .719, & + ! sulfate coarse + .658, .669, .680, .688, .698, .707, & + .719, .733, .752, .760, .773, .786, & + .544, .555, .565, .573, .583, .593, & + .610, .628, .655, .666, .692, .719, & + ! seasalt Super Coarse soluble (SS) + .727, .747, .755, .761, .770, .788, & + .792, .799, .805, .809, .815, .826, & + .717, .738, .745, .752, .761, .779, & + .781, .786, .793, .797, .803, .813, & + ! seasalt Coarse soluble (CS) + .727, .747, .755, .761, .770, .788, & + .792, .799, .805, .809, .815, .826, & + .717, .738, .745, .752, .761, .779, & + .781, .786, .793, .797, .803, .813, & + ! Sesalt Accumulation Soluble (AS) + .727, .741, .748, .754, .761, .782, & + .787, .792, .797, .799, .801, .799, & + .606, .645, .658, .669, .681, .726, & + .734, .746, .761, .770, .782, .798/ + + DATA cg_aeri_2bands/ & + ! dust insoluble + .701, .670, & + ! bc insoluble + .471, .297, & + ! pom insoluble + .568, .365/ + + DATA piz_aers_2bands/& + ! bc soluble + .445, .445, .445, .445, .445, .445, & + .445, .445, .461, .480, .505, .528, & + .362, .362, .362, .362, .362, .362, & + .362, .362, .381, .405, .437, .483, & + ! pom soluble + .972, .972, .972, .972, .972, .974, & + .976, .979, .982, .986, .989, .992, & + .924, .924, .924, .924, .925, .927, & + .932, .938, .945, .952, .961, .970, & + ! sulfate + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + .992, .988, .988, .987, .986, .985, & + .985, .985, .984, .984, .984, .984, & + ! sulfate coarse + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + .992, .988, .988, .987, .986, .985, & + .985, .985, .984, .984, .984, .984, & + ! seasalt Super Coarse Soluble (SS) + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 0.992,0.989,0.987,0.986,0.986,0.980, & + 0.980,0.978,0.976,0.976,0.974,0.971, & + ! seasalt Coarse soluble (CS) + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 0.992,0.989,0.987,0.986,0.986,0.980, & + 0.980,0.978,0.976,0.976,0.974,0.971, & + ! seasalt Accumulation Soluble (AS) + 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, & + 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, & + 0.970, 0.975, 0.976, 0.977, 0.978, 0.982, & + 0.982, 0.983, 0.984, 0.984, 0.985, 0.985/ + + DATA piz_aeri_2bands/ & + ! dust insoluble + .963, .987, & + ! bc insoluble + .395, .264, & + ! pom insoluble + .966, .859/ + +! Interpolation des coefficients optiques de 19 niveaux vers le nombre des niveaux du model + IF (firstcall) THEN + firstcall=.FALSE. + + IF (.NOT. ALLOCATED(A1_ASSSM_b1)) THEN + ALLOCATE(A1_ASSSM_b1(klev),A2_ASSSM_b1(klev), A3_ASSSM_b1(klev),& + B1_ASSSM_b1(klev), B2_ASSSM_b1(klev), C1_ASSSM_b1(klev), C2_ASSSM_b1(klev),& + A1_CSSSM_b1(klev), A2_CSSSM_b1(klev), A3_CSSSM_b1(klev),& + B1_CSSSM_b1(klev), B2_CSSSM_b1(klev), C1_CSSSM_b1(klev), C2_CSSSM_b1(klev),& + A1_SSSSM_b1(klev), A2_SSSSM_b1(klev), A3_SSSSM_b1(klev),& + B1_SSSSM_b1(klev), B2_SSSSM_b1(klev), C1_SSSSM_b1(klev), C2_SSSSM_b1(klev),& + A1_ASSSM_b2(klev), A2_ASSSM_b2(klev), A3_ASSSM_b2(klev),& + B1_ASSSM_b2(klev), B2_ASSSM_b2(klev), C1_ASSSM_b2(klev), C2_ASSSM_b2(klev),& + A1_CSSSM_b2(klev), A2_CSSSM_b2(klev), A3_CSSSM_b2(klev),& + B1_CSSSM_b2(klev), B2_CSSSM_b2(klev), C1_CSSSM_b2(klev), C2_CSSSM_b2(klev),& + A1_SSSSM_b2(klev), A2_SSSSM_b2(klev), A3_SSSSM_b2(klev),& + B1_SSSSM_b2(klev), B2_SSSSM_b2(klev), C1_SSSSM_b2(klev), C2_SSSSM_b2(klev), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('aeropt_2bands', 'pb in allocation 1',1) + END IF + +! bande 1 + CALL pres2lev(A1_ASSSM_b1_19, A1_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_ASSSM_b1_19, A2_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_ASSSM_b1_19, A3_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_ASSSM_b1_19, B1_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_ASSSM_b1_19, B2_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_ASSSM_b1_19, C1_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_ASSSM_b1_19, C2_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + + CALL pres2lev(A1_CSSSM_b1_19, A1_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_CSSSM_b1_19, A2_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_CSSSM_b1_19, A3_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_CSSSM_b1_19, B1_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_CSSSM_b1_19, B2_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_CSSSM_b1_19, C1_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_CSSSM_b1_19, C2_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + + CALL pres2lev(A1_SSSSM_b1_19, A1_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_SSSSM_b1_19, A2_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_SSSSM_b1_19, A3_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_SSSSM_b1_19, B1_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_SSSSM_b1_19, B2_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_SSSSM_b1_19, C1_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_SSSSM_b1_19, C2_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + +! bande 2 + CALL pres2lev(A1_ASSSM_b2_19, A1_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_ASSSM_b2_19, A2_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_ASSSM_b2_19, A3_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_ASSSM_b2_19, B1_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_ASSSM_b2_19, B2_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_ASSSM_b2_19, C1_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_ASSSM_b2_19, C2_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + + CALL pres2lev(A1_CSSSM_b2_19, A1_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_CSSSM_b2_19, A2_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_CSSSM_b2_19, A3_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_CSSSM_b2_19, B1_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_CSSSM_b2_19, B2_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_CSSSM_b2_19, C1_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_CSSSM_b2_19, C2_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + + CALL pres2lev(A1_SSSSM_b2_19, A1_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_SSSSM_b2_19, A2_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_SSSSM_b2_19, A3_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_SSSSM_b2_19, B1_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_SSSSM_b2_19, B2_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_SSSSM_b2_19, C1_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_SSSSM_b2_19, C2_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + + END IF ! firstcall + + + DO k=1, klev + DO i=1, klon + zrho=pplay(i,k)/t_seri(i,k)/RD ! kg/m3 +!CDIR UNROLL=naero_spc + mass_temp(i,k,:) = m_allaer(i,k,:) / zrho / 1.e+9 +!RAF zrho +!CDIR UNROLL=naero_spc + mass_temp_pi(i,k,:) = m_allaer_pi(i,k,:) / zrho / 1.e+9 + zdp1(i,k)=pdel(i,k)/(gravit*delt) ! air mass auxiliary variable --> zdp1 [kg/(m^2 *s)] + ENDDO + ENDDO + + IF (flag_aerosol .EQ. 1) THEN + nb_aer = 2 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_ASSO4M + aerosol_name(2) = id_CSSO4M + ELSEIF (flag_aerosol .EQ. 2) THEN + nb_aer = 2 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_ASBCM + aerosol_name(2) = id_AIBCM + ELSEIF (flag_aerosol .EQ. 3) THEN + nb_aer = 2 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_ASPOMM + aerosol_name(2) = id_AIPOMM + ELSEIF (flag_aerosol .EQ. 4) THEN + nb_aer = 3 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_CSSSM + aerosol_name(2) = id_SSSSM + aerosol_name(3) = id_ASSSM + ELSEIF (flag_aerosol .EQ. 5) THEN + nb_aer = 1 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_CIDUSTM + ELSEIF (flag_aerosol .EQ. 6) THEN + nb_aer = 10 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_ASSO4M + aerosol_name(2) = id_ASBCM + aerosol_name(3) = id_AIBCM + aerosol_name(4) = id_ASPOMM + aerosol_name(5) = id_AIPOMM + aerosol_name(6) = id_CSSSM + aerosol_name(7) = id_SSSSM + aerosol_name(8) = id_ASSSM + aerosol_name(9) = id_CIDUSTM + aerosol_name(10)= id_CSSO4M + ENDIF + + + ! + ! loop over modes, use of precalculated nmd and corresponding sigma + ! loop over wavelengths + ! for each mass species in mode + ! interpolate from Sext to retrieve Sext_at_gridpoint_per_species + ! compute optical_thickness_at_gridpoint_per_species + + + +!!CDIR ON_ADB(RH_tab) +!CDIR ON_ADB(fact_RH) +!CDIR SHORTLOOP + DO n=1,nbre_RH-1 + fact_RH(n)=1./(RH_tab(n+1)-RH_tab(n)) + ENDDO + + DO k=1, KLEV +!!CDIR ON_ADB(RH_tab) +!CDIR ON_ADB(fact_RH) + DO i=1, KLON + rh(i,k)=MIN(RHcl(i,k)*100.,RH_MAX) + RH_num(i,k) = INT( rh(i,k)/10. + 1.) + IF (rh(i,k).GT.85.) RH_num(i,k)=10 + IF (rh(i,k).GT.90.) RH_num(i,k)=11 + + DELTA(i,k)=(rh(i,k)-RH_tab(RH_num(i,k)))*fact_RH(RH_num(i,k)) + ENDDO + ENDDO + + used_aer(:)=.FALSE. + + DO m=1,nb_aer ! tau is only computed for each mass + fac=1.0 + IF (aerosol_name(m).EQ.id_ASBCM) THEN + soluble=.TRUE. + spsol=1 + spss=0 + ELSEIF (aerosol_name(m).EQ.id_ASPOMM) THEN + soluble=.TRUE. + spsol=2 + spss=0 + ELSEIF (aerosol_name(m).EQ.id_ASSO4M) THEN + soluble=.TRUE. + spsol=3 + spss=0 + fac=1.375 ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD + ELSEIF (aerosol_name(m).EQ.id_CSSO4M) THEN + soluble=.TRUE. + spsol=4 + spss=0 + fac=1.375 ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD + ELSEIF (aerosol_name(m).EQ.id_SSSSM) THEN + soluble=.TRUE. + spsol=5 + spss=3 + ELSEIF (aerosol_name(m).EQ.id_CSSSM) THEN + soluble=.TRUE. + spsol=6 + spss=2 + ELSEIF (aerosol_name(m).EQ.id_ASSSM) THEN + soluble=.TRUE. + spsol=7 + spss=1 + ELSEIF (aerosol_name(m).EQ.id_CIDUSTM) THEN + soluble=.FALSE. + spinsol=1 + spss=0 + ELSEIF (aerosol_name(m).EQ.id_AIBCM) THEN + soluble=.FALSE. + spinsol=2 + spss=0 + ELSEIF (aerosol_name(m).EQ.id_AIPOMM) THEN + soluble=.FALSE. + spinsol=3 + spss=0 + ELSE + CYCLE + ENDIF + + id=aerosol_name(m) + used_aer(id)=.TRUE. + + + IF (soluble) THEN + + IF (spss.NE.0) THEN + + IF (spss.EQ.1) THEN !accumulation mode + DO k=1, KLEV +!CDIR ON_ADB(A1_ASSSM_b1) +!CDIR ON_ADB(A2_ASSSM_b1) +!CDIR ON_ADB(A3_ASSSM_b1) +!CDIR ON_ADB(B1_ASSSM_b1) +!CDIR ON_ADB(B2_ASSSM_b1) +!CDIR ON_ADB(C1_ASSSM_b1) +!CDIR ON_ADB(C2_ASSSM_b2) +!CDIR ON_ADB(A1_ASSSM_b2) +!CDIR ON_ADB(A2_ASSSM_b2) +!CDIR ON_ADB(A3_ASSSM_b2) +!CDIR ON_ADB(B1_ASSSM_b2) +!CDIR ON_ADB(B2_ASSSM_b2) +!CDIR ON_ADB(C1_ASSSM_b2) +!CDIR ON_ADB(C2_ASSSM_b2) + DO i=1, KLON + H=rh(i,k)/100 + tmp_var=mass_temp(i,k,spsol)*1000.*zdp1(i,k)*delt*fac + tmp_var_pi=mass_temp_pi(i,k,spsol)*1000.*zdp1(i,k)*delt*fac + + ! band 1 + tau_ae2b_int=A1_ASSSM_b1(k)+A2_ASSSM_b1(k)*H+A3_ASSSM_b1(k)/(H-1.05) + piz_ae2b_int=1-B1_ASSSM_b1(k)-B2_ASSSM_b1(k)*H + cg_ae2b_int=C1_ASSSM_b1(k)+C2_ASSSM_b1(k)*H + + tau_ae(i,k,id,1) = tmp_var*tau_ae2b_int + tau_ae_pi(i,k,id,1) = tmp_var_pi* tau_ae2b_int + piz_ae(i,k,id,1) = piz_ae2b_int + cg_ae(i,k,id,1)= cg_ae2b_int + + !band 2 + tau_ae2b_int=A1_ASSSM_b2(k)+A2_ASSSM_b2(k)*H+A3_ASSSM_b2(k)/(H-1.05) + piz_ae2b_int=1-B1_ASSSM_b2(k)-B2_ASSSM_b2(k)*H + cg_ae2b_int=C1_ASSSM_b2(k)+C2_ASSSM_b2(k)*H + + tau_ae(i,k,id,2) = tmp_var*tau_ae2b_int + tau_ae_pi(i,k,id,2) = tmp_var_pi* tau_ae2b_int + piz_ae(i,k,id,2) = piz_ae2b_int + cg_ae(i,k,id,2)= cg_ae2b_int + + ENDDO + ENDDO + ENDIF + + IF (spss.EQ.2) THEN !coarse mode + DO k=1, KLEV +!CDIR ON_ADB(A1_CSSSM_b1) +!CDIR ON_ADB(A2_CSSSM_b1) +!CDIR ON_ADB(A3_CSSSM_b1) +!CDIR ON_ADB(B1_CSSSM_b1) +!CDIR ON_ADB(B2_CSSSM_b1) +!CDIR ON_ADB(C1_CSSSM_b1) +!CDIR ON_ADB(C2_CSSSM_b2) +!CDIR ON_ADB(A1_CSSSM_b2) +!CDIR ON_ADB(A2_CSSSM_b2) +!CDIR ON_ADB(A3_CSSSM_b2) +!CDIR ON_ADB(B1_CSSSM_b2) +!CDIR ON_ADB(B2_CSSSM_b2) +!CDIR ON_ADB(C1_CSSSM_b2) +!CDIR ON_ADB(C2_CSSSM_b2) + DO i=1, KLON + H=rh(i,k)/100 + tmp_var=mass_temp(i,k,spsol)*1000.*zdp1(i,k)*delt*fac + tmp_var_pi=mass_temp_pi(i,k,spsol)*1000.*zdp1(i,k)*delt*fac + ! band 1 + tau_ae2b_int=A1_CSSSM_b1(k)+A2_CSSSM_b1(k)*H+A3_CSSSM_b1(k)/(H-1.05) + piz_ae2b_int=1-B1_CSSSM_b1(k)-B2_CSSSM_b1(k)*H + cg_ae2b_int=C1_CSSSM_b1(k)+C2_CSSSM_b1(k)*H + + tau_ae(i,k,id,1) = tmp_var*tau_ae2b_int + tau_ae_pi(i,k,id,1) = tmp_var_pi* tau_ae2b_int + piz_ae(i,k,id,1) = piz_ae2b_int + cg_ae(i,k,id,1)= cg_ae2b_int + + ! band 2 + tau_ae2b_int=A1_CSSSM_b2(k)+A2_CSSSM_b2(k)*H+A3_CSSSM_b2(k)/(H-1.05) + piz_ae2b_int=1-B1_CSSSM_b2(k)-B2_CSSSM_b2(k)*H + cg_ae2b_int=C1_CSSSM_b2(k)+C2_CSSSM_b2(k)*H + + tau_ae(i,k,id,2) = tmp_var*tau_ae2b_int + tau_ae_pi(i,k,id,2) = tmp_var_pi* tau_ae2b_int + piz_ae(i,k,id,2) = piz_ae2b_int + cg_ae(i,k,id,2)= cg_ae2b_int + + ENDDO + ENDDO + ENDIF + + IF (spss.EQ.3) THEN !super coarse mode + DO k=1, KLEV +!CDIR ON_ADB(A1_SSSSM_b1) +!CDIR ON_ADB(A2_SSSSM_b1) +!CDIR ON_ADB(A3_SSSSM_b1) +!CDIR ON_ADB(B1_SSSSM_b1) +!CDIR ON_ADB(B2_SSSSM_b1) +!CDIR ON_ADB(C1_SSSSM_b1) +!CDIR ON_ADB(C2_SSSSM_b2) +!CDIR ON_ADB(A1_SSSSM_b2) +!CDIR ON_ADB(A2_SSSSM_b2) +!CDIR ON_ADB(A3_SSSSM_b2) +!CDIR ON_ADB(B1_SSSSM_b2) +!CDIR ON_ADB(B2_SSSSM_b2) +!CDIR ON_ADB(C1_SSSSM_b2) +!CDIR ON_ADB(C2_SSSSM_b2) + DO i=1, KLON + H=rh(i,k)/100 + tmp_var=mass_temp(i,k,spsol)*1000.*zdp1(i,k)*delt*fac + tmp_var_pi=mass_temp_pi(i,k,spsol)*1000.*zdp1(i,k)*delt*fac + + ! band 1 + tau_ae2b_int=A1_SSSSM_b1(k)+A2_SSSSM_b1(k)*H+A3_SSSSM_b1(k)/(H-1.05) + piz_ae2b_int=1-B1_SSSSM_b1(k)-B2_SSSSM_b1(k)*H + cg_ae2b_int=C1_SSSSM_b1(k)+C2_SSSSM_b1(k)*H + + tau_ae(i,k,id,1) = tmp_var*tau_ae2b_int + tau_ae_pi(i,k,id,1) = tmp_var_pi* tau_ae2b_int + piz_ae(i,k,id,1) = piz_ae2b_int + cg_ae(i,k,id,1)= cg_ae2b_int + + ! band 2 + tau_ae2b_int=A1_SSSSM_b2(k)+A2_SSSSM_b2(k)*H+A3_SSSSM_b2(k)/(H-1.05) + piz_ae2b_int=1-B1_SSSSM_b2(k)-B2_SSSSM_b2(k)*H + cg_ae2b_int=C1_SSSSM_b2(k)+C2_SSSSM_b2(k)*H + + tau_ae(i,k,id,2) = tmp_var*tau_ae2b_int + tau_ae_pi(i,k,id,2) = tmp_var_pi* tau_ae2b_int + piz_ae(i,k,id,2) = piz_ae2b_int + cg_ae(i,k,id,2)= cg_ae2b_int + + ENDDO + ENDDO + ENDIF + + ELSE + +!CDIR ON_ADB(alpha_aers_2bands) +!CDIR ON_ADB(piz_aers_2bands) +!CDIR ON_ADB(cg_aers_2bands) + DO k=1, KLEV + DO i=1, KLON + tmp_var=mass_temp(i,k,spsol)*1000.*zdp1(i,k)*delt*fac + tmp_var_pi=mass_temp_pi(i,k,spsol)*1000.*zdp1(i,k)*delt*fac +!CDIR UNROLL=nbands + DO inu=1,nbands + + tau_ae2b_int= alpha_aers_2bands(RH_num(i,k),inu,spsol)+ & + DELTA(i,k)* (alpha_aers_2bands(RH_num(i,k)+1,inu,spsol) - & + alpha_aers_2bands(RH_num(i,k),inu,spsol)) + + piz_ae2b_int = piz_aers_2bands(RH_num(i,k),inu,spsol) + & + DELTA(i,k)* (piz_aers_2bands(RH_num(i,k)+1,inu,spsol) - & + piz_aers_2bands(RH_num(i,k),inu,spsol)) + + cg_ae2b_int = cg_aers_2bands(RH_num(i,k),inu,spsol) + & + DELTA(i,k)* (cg_aers_2bands(RH_num(i,k)+1,inu,spsol) - & + cg_aers_2bands(RH_num(i,k),inu,spsol)) + + tau_ae(i,k,id,inu) = tmp_var*tau_ae2b_int + tau_ae_pi(i,k,id,inu) = tmp_var_pi* tau_ae2b_int + piz_ae(i,k,id,inu) = piz_ae2b_int + cg_ae(i,k,id,inu)= cg_ae2b_int + + ENDDO + ENDDO + ENDDO + + ENDIF + + ELSE ! For all aerosol insoluble components + +!CDIR ON_ADB(alpha_aers_2bands) +!CDIR ON_ADB(piz_aers_2bands) +!CDIR ON_ADB(cg_aers_2bands) + DO k=1, KLEV + DO i=1, KLON + tmp_var=mass_temp(i,k,naero_soluble+ spinsol)*1000.*zdp1(i,k)*delt*fac + tmp_var_pi=mass_temp_pi(i,k,naero_soluble+spinsol)*1000.*zdp1(i,k)*delt*fac +!CDIR UNROLL=nbands + DO inu=1,nbands + tau_ae2b_int = alpha_aeri_2bands(inu,spinsol) + piz_ae2b_int = piz_aeri_2bands(inu,spinsol) + cg_ae2b_int = cg_aeri_2bands(inu,spinsol) + + tau_ae(i,k,id,inu) = tmp_var*tau_ae2b_int + tau_ae_pi(i,k,id,inu) = tmp_var_pi*tau_ae2b_int + piz_ae(i,k,id,inu) = piz_ae2b_int + cg_ae(i,k,id,inu)= cg_ae2b_int + ENDDO + ENDDO + ENDDO + + ENDIF ! soluble + + ENDDO ! nb_aer + + DO m=1,nb_aer + IF (.NOT. used_aer(m)) THEN + tau_ae(:,:,:,:)=0. + tau_ae_pi(:,:,:,:)=0. + piz_ae(:,:,:,:)=0. + cg_ae(:,:,:,:)=0. + ENDIF + ENDDO + + DO inu=1, nbands + DO mrfspecies=1,naero_grp + IF (mrfspecies .EQ. 2) THEN ! = total aerosol AER + DO k=1, KLEV + DO i=1, KLON + tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASSO4M,inu)+tau_ae(i,k,id_CSSO4M,inu)+ & + tau_ae(i,k,id_ASBCM,inu)+tau_ae(i,k,id_AIBCM,inu)+ & + tau_ae(i,k,id_ASPOMM,inu)+tau_ae(i,k,id_AIPOMM,inu)+ & + tau_ae(i,k,id_ASSSM,inu)+tau_ae(i,k,id_CSSSM,inu)+ & + tau_ae(i,k,id_SSSSM,inu)+ tau_ae(i,k,id_CIDUSTM,inu) + tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5) + + piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu)+ & + tau_ae(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu)+ & + tau_ae(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu)+ & + tau_ae(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu)+ & + tau_ae(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu)+ & + tau_ae(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu)+ & + tau_ae(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu)+ & + tau_ae(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu)+ & + tau_ae(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu)+ & + tau_ae(i,k,id_CIDUSTM,inu)*piz_ae(i,k,id_CIDUSTM,inu)) & + /tau_allaer(i,k,mrfspecies,inu) + piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1) + + cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu)*cg_ae(i,k,id_ASSO4M,inu)+ & + tau_ae(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu)*cg_ae(i,k,id_CSSO4M,inu)+ & + tau_ae(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu)*cg_ae(i,k,id_ASBCM,inu)+ & + tau_ae(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu)*cg_ae(i,k,id_AIBCM,inu)+ & + tau_ae(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu)*cg_ae(i,k,id_ASPOMM,inu)+ & + tau_ae(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu)*cg_ae(i,k,id_AIPOMM,inu)+ & + tau_ae(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu)*cg_ae(i,k,id_ASSSM,inu)+ & + tau_ae(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu)*cg_ae(i,k,id_CSSSM,inu)+ & + tau_ae(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu)*cg_ae(i,k,id_SSSSM,inu)+ & + tau_ae(i,k,id_CIDUSTM,inu)*piz_ae(i,k,id_CIDUSTM,inu)*cg_ae(i,k,id_CIDUSTM,inu))/ & + (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu)) + ENDDO + ENDDO + + ELSEIF (mrfspecies .EQ. 3) THEN ! = natural aerosol NAT + + DO k=1, KLEV + DO i=1, KLON +!RAF + tau_allaer(i,k,mrfspecies,inu)=tau_ae_pi(i,k,id_ASSO4M,inu)+ & + tau_ae_pi(i,k,id_CSSO4M,inu)+ & + tau_ae_pi(i,k,id_ASBCM,inu)+ & + tau_ae_pi(i,k,id_AIBCM,inu)+ & + tau_ae_pi(i,k,id_ASPOMM,inu)+ & + tau_ae_pi(i,k,id_AIPOMM,inu)+ & + tau_ae_pi(i,k,id_ASSSM,inu)+ & + tau_ae_pi(i,k,id_CSSSM,inu)+ & + tau_ae_pi(i,k,id_SSSSM,inu)+ & + tau_ae_pi(i,k,id_CIDUSTM,inu) + tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5) + + piz_allaer(i,k,mrfspecies,inu)=(tau_ae_pi(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu)+ & + tau_ae_pi(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu)+ & + tau_ae_pi(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu)+ & + tau_ae_pi(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu)+ & + tau_ae_pi(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu)+ & + tau_ae_pi(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu)+ & + tau_ae_pi(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu)+ & + tau_ae_pi(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu)+ & + tau_ae_pi(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu)+ & + tau_ae_pi(i,k,id_CIDUSTM,inu)*piz_ae(i,k,id_CIDUSTM,inu)) & + /tau_allaer(i,k,mrfspecies,inu) + piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1) + + cg_allaer(i,k,mrfspecies,inu)=(& + tau_ae_pi(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu)*cg_ae(i,k,id_ASSO4M,inu)+ & + tau_ae_pi(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu)*cg_ae(i,k,id_CSSO4M,inu)+ & + tau_ae_pi(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu)*cg_ae(i,k,id_ASBCM,inu)+ & + tau_ae_pi(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu)*cg_ae(i,k,id_AIBCM,inu)+ & + tau_ae_pi(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu)*cg_ae(i,k,id_ASPOMM,inu)+ & + tau_ae_pi(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu)*cg_ae(i,k,id_AIPOMM,inu)+ & + tau_ae_pi(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu)*cg_ae(i,k,id_ASSSM,inu)+ & + tau_ae_pi(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu)*cg_ae(i,k,id_CSSSM,inu)+ & + tau_ae_pi(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu)*cg_ae(i,k,id_SSSSM,inu)+ & + tau_ae_pi(i,k,id_CIDUSTM,inu)*piz_ae(i,k,id_CIDUSTM,inu)*& + cg_ae(i,k,id_CIDUSTM,inu))/ & + (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu)) + ENDDO + ENDDO + + ELSEIF (mrfspecies .EQ. 4) THEN ! = BC + DO k=1, KLEV + DO i=1, KLON + tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASBCM,inu)+tau_ae(i,k,id_AIBCM,inu) + tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5) + piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu) & + +tau_ae(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu))/ & + tau_allaer(i,k,mrfspecies,inu) + piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1) + cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu) *cg_ae(i,k,id_ASBCM,inu)& + +tau_ae(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu)*cg_ae(i,k,id_AIBCM,inu))/ & + (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu)) + ENDDO + ENDDO + + ELSEIF (mrfspecies .EQ. 5) THEN ! = SO4 + + DO k=1, KLEV + DO i=1, KLON + tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASSO4M,inu)+tau_ae(i,k,id_CSSO4M,inu) + tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5) + piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu) & + +tau_ae(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu))/ & + tau_allaer(i,k,mrfspecies,inu) + piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1) + cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu) *cg_ae(i,k,id_CSSO4M,inu)& + +tau_ae(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu)*cg_ae(i,k,id_ASSO4M,inu))/ & + (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu)) + ENDDO + ENDDO + + ELSEIF (mrfspecies .EQ. 6) THEN ! = POM + + DO k=1, KLEV + DO i=1, KLON + tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASPOMM,inu)+tau_ae(i,k,id_AIPOMM,inu) + tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5) + piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu) & + +tau_ae(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu))/ & + tau_allaer(i,k,mrfspecies,inu) + piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1) + cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu) *cg_ae(i,k,id_ASPOMM,inu)& + +tau_ae(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu)*cg_ae(i,k,id_AIPOMM,inu))/ & + (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu)) + ENDDO + ENDDO + + ELSEIF (mrfspecies .EQ. 7) THEN ! = DUST + + DO k=1, KLEV + DO i=1, KLON + tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_CIDUSTM,inu) + tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5) + piz_allaer(i,k,mrfspecies,inu)=piz_ae(i,k,id_CIDUSTM,inu) + cg_allaer(i,k,mrfspecies,inu)=cg_ae(i,k,id_CIDUSTM,inu) + ENDDO + ENDDO + + ELSEIF (mrfspecies .EQ. 8) THEN ! = SS + + DO k=1, KLEV + DO i=1, KLON + tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASSSM,inu)+tau_ae(i,k,id_CSSSM,inu)+tau_ae(i,k,id_SSSSM,inu) + tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5) + piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu) & + +tau_ae(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu) & + +tau_ae(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu))/ & + tau_allaer(i,k,mrfspecies,inu) + piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1) + cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu) *cg_ae(i,k,id_ASSSM,inu)& + +tau_ae(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu)*cg_ae(i,k,id_CSSSM,inu) & + +tau_ae(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu)*cg_ae(i,k,id_SSSSM,inu))/ & + (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu)) + ENDDO + ENDDO + + ELSEIF (mrfspecies .EQ. 9) THEN ! = NO3 + + DO k=1, KLEV + DO i=1, KLON + tau_allaer(i,k,mrfspecies,inu)=0. ! preliminary + piz_allaer(i,k,mrfspecies,inu)=0. + cg_allaer(i,k,mrfspecies,inu)=0. + ENDDO + ENDDO + + ELSE + + DO k=1, KLEV + DO i=1, KLON + tau_allaer(i,k,mrfspecies,inu)=0. + piz_allaer(i,k,mrfspecies,inu)=0. + cg_allaer(i,k,mrfspecies,inu)=0. + ENDDO + ENDDO + + ENDIF + + ENDDO + ENDDO + + DEALLOCATE(aerosol_name) + +END SUBROUTINE AEROPT_2BANDS Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/aeropt_5wv.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/aeropt_5wv.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/aeropt_5wv.F90 (revision 1280) @@ -0,0 +1,852 @@ +! +! $Id$ +! + +SUBROUTINE AEROPT_5WV(& + pdel, m_allaer, delt, & + RHcl, ai, flag_aerosol, & + pplay, t_seri, & + tausum, tau, presnivs) + + USE DIMPHY + USE aero_mod + + ! + ! Yves Balkanski le 12 avril 2006 + ! Celine Deandreis + ! Anne Cozic Avril 2009 + ! a partir d'une sous-routine de Johannes Quaas pour les sulfates + ! + ! + ! Refractive indices for seasalt come from Shettle and Fenn (1979) + ! + ! Refractive indices from water come from Hale and Querry (1973) + ! + ! Refractive indices from Ammonium Sulfate Toon and Pollack (1976) + ! + ! Refractive indices for Dust, internal mixture of minerals coated with 1.5% hematite + ! by Volume (Balkanski et al., 2006) + ! + ! Refractive indices for POM: Kinne (pers. Communication + ! + ! Refractive index for BC from Shettle and Fenn (1979) + ! + ! Shettle, E. P., & Fenn, R. W. (1979), Models for the aerosols of the lower atmosphere and + ! the effects of humidity variations on their optical properties, U.S. Air Force Geophysics + ! Laboratory Rept. AFGL-TR-79-0214, Hanscomb Air Force Base, MA. + ! + ! Hale, G. M. and M. R. Querry, Optical constants of water in the 200-nm to 200-m + ! wavelength region, Appl. Opt., 12, 555-563, 1973. + ! + ! Toon, O. B. and J. B. Pollack, The optical constants of several atmospheric aerosol species: + ! Ammonium sulfate, aluminum oxide, and sodium chloride, J. Geohys. Res., 81, 5733-5748, + ! 1976. + ! + ! Balkanski, Y., M. Schulz, T. Claquin And O. Boucher, Reevaluation of mineral aerosol + ! radiative forcings suggests a better agreement with satellite and AERONET data, Atmospheric + ! Chemistry and Physics Discussions., 6, pp 8383-8419, 2006. + ! + IMPLICIT NONE + INCLUDE "YOMCST.h" + ! + ! Input arguments: + ! + REAL, DIMENSION(klon,klev), INTENT(in) :: pdel + REAL, INTENT(in) :: delt + REAL, DIMENSION(klon,klev,naero_spc), INTENT(in) :: m_allaer + REAL, DIMENSION(klon,klev), INTENT(in) :: RHcl ! humidite relative ciel clair + INTEGER,INTENT(in) :: flag_aerosol + REAL, DIMENSION(klon,klev), INTENT(in) :: pplay + REAL, DIMENSION(klon,klev), INTENT(in) :: t_seri + REAL, DIMENSION(klev), INTENT(in) :: presnivs + ! + ! Output arguments: + ! + REAL, DIMENSION(klon), INTENT(out) :: ai ! POLDER aerosol index + REAL, DIMENSION(klon,nwave,naero_spc), INTENT(out) :: tausum + REAL, DIMENSION(klon,klev,nwave,naero_spc), INTENT(out) :: tau + + + ! + ! Local + ! + INTEGER, PARAMETER :: las = nwave + LOGICAL :: soluble + + INTEGER :: i, k, ierr, m + INTEGER :: spsol, spinsol, spss, la + INTEGER :: RH_num(klon,klev) + INTEGER, PARAMETER :: la443 = 1 + INTEGER, PARAMETER :: la550 = 2 + INTEGER, PARAMETER :: la670 = 3 + INTEGER, PARAMETER :: la765 = 4 + INTEGER, PARAMETER :: la865 = 5 + INTEGER, PARAMETER :: nbre_RH=12 + INTEGER, PARAMETER :: naero_soluble=7 ! 1- BC soluble; 2- POM soluble; 3- SO4 acc. + ! 4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc. + INTEGER, PARAMETER :: naero_insoluble=3 ! 1- Dust; 2- BC insoluble; 3- POM insoluble + INTEGER, PARAMETER :: nb_level = 19 ! number of vertical levels + LOGICAL, SAVE :: firstcall=.TRUE. +!$OMP THREADPRIVATE(firstcall) + + REAL :: zrho + + ! Coefficient optiques sur 19 niveaux + REAL, SAVE, DIMENSION(nb_level) :: presnivs_19 ! Pression milieux couche pour 19 niveaux (nb_level) +!$OMP THREADPRIVATE(presnivs_19) + + REAL, SAVE, DIMENSION(nb_level) :: A1_ASSSM_19, A2_ASSSM_19, A3_ASSSM_19,& + B1_ASSSM_19, B2_ASSSM_19, C1_ASSSM_19, C2_ASSSM_19,& + A1_CSSSM_19, A2_CSSSM_19, A3_CSSSM_19,& + B1_CSSSM_19, B2_CSSSM_19, C1_CSSSM_19, C2_CSSSM_19, & + A1_SSSSM_19, A2_SSSSM_19, A3_SSSSM_19,& + B1_SSSSM_19, B2_SSSSM_19, C1_SSSSM_19, C2_SSSSM_19 +!$OMP THREADPRIVATE(A1_ASSSM_19, A2_ASSSM_19, A3_ASSSM_19) +!$OMP THREADPRIVATE(B1_ASSSM_19, B2_ASSSM_19, C1_ASSSM_19, C2_ASSSM_19) +!$OMP THREADPRIVATE(A1_CSSSM_19, A2_CSSSM_19, A3_CSSSM_19) +!$OMP THREADPRIVATE(B1_CSSSM_19, B2_CSSSM_19, C1_CSSSM_19, C2_CSSSM_19) +!$OMP THREADPRIVATE(A1_SSSSM_19, A2_SSSSM_19, A3_SSSSM_19) +!$OMP THREADPRIVATE(B1_SSSSM_19, B2_SSSSM_19, C1_SSSSM_19, C2_SSSSM_19) + + ! Coefficient optiques interpole sur le nombre de niveau du modele + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: & + A1_ASSSM, A2_ASSSM, A3_ASSSM,& + B1_ASSSM, B2_ASSSM, C1_ASSSM, C2_ASSSM,& + A1_CSSSM, A2_CSSSM, A3_CSSSM,& + B1_CSSSM, B2_CSSSM, C1_CSSSM, C2_CSSSM, & + A1_SSSSM, A2_SSSSM, A3_SSSSM,& + B1_SSSSM, B2_SSSSM, C1_SSSSM, C2_SSSSM +!$OMP THREADPRIVATE(A1_ASSSM, A2_ASSSM, A3_ASSSM) +!$OMP THREADPRIVATE(B1_ASSSM, B2_ASSSM, C1_ASSSM, C2_ASSSM) +!$OMP THREADPRIVATE(A1_CSSSM, A2_CSSSM, A3_CSSSM) +!$OMP THREADPRIVATE(B1_CSSSM, B2_CSSSM, C1_CSSSM, C2_CSSSM) +!$OMP THREADPRIVATE(A1_SSSSM, A2_SSSSM, A3_SSSSM) +!$OMP THREADPRIVATE(B1_SSSSM, B2_SSSSM, C1_SSSSM, C2_SSSSM) + + + REAL,PARAMETER :: RH_tab(nbre_RH)=(/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./) + REAL :: DELTA(klon,klev), rh(klon,klev), H + REAL :: tau_ae5wv_int ! Intermediate computation of epaisseur optique aerosol + REAL :: piz_ae5wv_int ! Intermediate single scattering albedo aerosol + REAL :: cg_ae5wv_int ! Intermediate asymmetry parameter aerosol + REAL, PARAMETER :: RH_MAX=95. + REAL :: taue670(KLON) ! epaisseur optique aerosol absorption 550 nm + REAL :: taue865(KLON) ! epaisseur optique aerosol extinction 865 nm + REAL :: fac + REAL :: zdp1(klon,klev) + REAL, PARAMETER :: gravit = 9.80616 ! m2/s + INTEGER, ALLOCATABLE, DIMENSION(:) :: aerosol_name + INTEGER :: nb_aer + + REAL :: tau3d(KLON,KLEV), piz3d(KLON,KLEV), cg3d(KLON,KLEV) + REAL :: abs3d(KLON,KLEV) ! epaisseur optique d'absorption + + + REAL :: alpha_aers_5wv(nbre_RH,las,naero_soluble) ! ext. coeff. Soluble comp. units *** m2/g + ! 1- BC soluble; 2- POM soluble; 3- SO4 acc.; 4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc. + REAL :: alpha_aeri_5wv(las,naero_insoluble) ! ext. coeff. Insoluble comp. 1- Dust: 2- BC; 3- POM + REAL :: cg_aers_5wv(nbre_RH,las,naero_soluble) ! Asym. param. soluble comp. + ! 1- BC soluble; 2- POM soluble; 3- SO4 acc.; 4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc. + REAL :: cg_aeri_5wv(las,naero_insoluble) ! Asym. param. insoluble comp. 1- Dust: 2- BC; 3- POM + REAL :: piz_aers_5wv(nbre_RH,las,naero_soluble) + ! 1- BC soluble; 2- POM soluble; 3- SO4 acc.; 4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc. + REAL :: piz_aeri_5wv(las,naero_insoluble) ! Insoluble comp. 1- Dust: 2- BC; 3- POM + + REAL, DIMENSION(klon,klev,naero_spc) :: mass_temp + + ! + ! Proprietes optiques + ! + REAL :: radry = 287.054 + REAL :: tau_tmp ! dry air mass constant + REAL :: fact_RH(nbre_RH) + LOGICAL :: used_tau(naero_spc) + INTEGER :: n + + DATA presnivs_19/& + 100426.5, 98327.6, 95346.5, 90966.8, 84776.9, & + 76536.5, 66292.2, 54559.3, 42501.8, 31806, & + 23787.5, 18252.7, 13996, 10320.8, 7191.1, & + 4661.7, 2732.9, 1345.6, 388.2/ + +!!ACCUMULATION MODE + DATA A1_ASSSM_19/ 4.373E+00, 4.361E+00, 4.331E+00, & + 4.278E+00, 4.223E+00, 4.162E+00, & + 4.103E+00, 4.035E+00, 3.962E+00, & + 3.904E+00, 3.871E+00, 3.847E+00, & + 3.824E+00, 3.780E+00, 3.646E+00, & + 3.448E+00, 3.179E+00, 2.855E+00, 2.630E+00/ + DATA A2_ASSSM_19/ 2.496E+00, 2.489E+00, 2.472E+00, & + 2.442E+00, 2.411E+00, 2.376E+00, & + 2.342E+00, 2.303E+00, 2.261E+00, & + 2.228E+00, 2.210E+00, 2.196E+00, & + 2.183E+00, 2.158E+00, 2.081E+00, & + 1.968E+00, 1.814E+00, 1.630E+00, 1.501E+00/ + DATA A3_ASSSM_19/-4.688E-02, -4.676E-02, -4.644E-02, & + -4.587E-02, -4.528E-02, -4.463E-02, & + -4.399E-02, -4.326E-02, -4.248E-02, & + -4.186E-02, -4.151E-02, -4.125E-02, & + -4.100E-02, -4.053E-02, -3.910E-02, & + -3.697E-02, -3.408E-02, -3.061E-02, -2.819E-02/ + DATA B1_ASSSM_19/ 1.165E-08, 1.145E-08, 1.097E-08, & + 1.012E-08, 9.233E-09, 8.261E-09, & + 7.297E-09, 6.201E-09, 5.026E-09, & + 4.098E-09, 3.567E-09, 3.187E-09, & + 2.807E-09, 2.291E-09, 2.075E-09, & + 1.756E-09, 1.322E-09, 8.011E-10, 4.379E-10/ + DATA B2_ASSSM_19/ 2.193E-08, 2.192E-08, 2.187E-08, & + 2.179E-08, 2.171E-08, 2.162E-08, & + 2.153E-08, 2.143E-08, 2.132E-08, & + 2.124E-08, 2.119E-08, 2.115E-08, & + 2.112E-08, 2.106E-08, 2.100E-08, & + 2.090E-08, 2.077E-08, 2.061E-08, 2.049E-08/ + DATA C1_ASSSM_19/ 7.365E-01, 7.365E-01, 7.365E-01, & + 7.364E-01, 7.363E-01, 7.362E-01, & + 7.361E-01, 7.359E-01, 7.358E-01, & + 7.357E-01, 7.356E-01, 7.356E-01, & + 7.356E-01, 7.355E-01, 7.354E-01, & + 7.352E-01, 7.350E-01, 7.347E-01, 7.345E-01/ + DATA C2_ASSSM_19/ 5.833E-02, 5.835E-02, 5.841E-02, & + 5.850E-02, 5.859E-02, 5.870E-02, & + 5.880E-02, 5.891E-02, 5.904E-02, & + 5.914E-02, 5.920E-02, 5.924E-02, & + 5.928E-02, 5.934E-02, 5.944E-02, & + 5.959E-02, 5.979E-02, 6.003E-02, 6.020E-02/ +!COARSE MODE + DATA A1_CSSSM_19/ 7.403E-01, 7.422E-01, 7.626E-01, & + 8.019E-01, 8.270E-01, 8.527E-01, & + 8.702E-01, 8.806E-01, 8.937E-01, & + 9.489E-01, 1.030E+00, 1.105E+00, & + 1.199E+00, 1.357E+00, 1.660E+00, & + 2.540E+00, 4.421E+00, 2.151E+00, 9.518E-01/ + DATA A2_CSSSM_19/ 4.522E-01, 4.532E-01, 4.644E-01, & + 4.859E-01, 4.996E-01, 5.137E-01, & + 5.233E-01, 5.290E-01, 5.361E-01, & + 5.655E-01, 6.085E-01, 6.483E-01, & + 6.979E-01, 7.819E-01, 9.488E-01, & + 1.450E+00, 2.523E+00, 1.228E+00, 5.433E-01/ + DATA A3_CSSSM_19/-8.516E-03, -8.535E-03, -8.744E-03, & + -9.148E-03, -9.406E-03, -9.668E-03, & + -9.848E-03, -9.955E-03, -1.009E-02, & + -1.064E-02, -1.145E-02, -1.219E-02, & + -1.312E-02, -1.470E-02, -1.783E-02, & + -2.724E-02, -4.740E-02, -2.306E-02, -1.021E-02/ + DATA B1_CSSSM_19/ 2.535E-07, 2.530E-07, 2.479E-07, & + 2.380E-07, 2.317E-07, 2.252E-07, & + 2.208E-07, 2.182E-07, 2.149E-07, & + 2.051E-07, 1.912E-07, 1.784E-07, & + 1.624E-07, 1.353E-07, 1.012E-07, & + 6.016E-08, 2.102E-08, 0.000E+00, 0.000E+00/ + DATA B2_CSSSM_19/ 1.221E-07, 1.217E-07, 1.179E-07, & + 1.104E-07, 1.056E-07, 1.008E-07, & + 9.744E-08, 9.546E-08, 9.299E-08, & + 8.807E-08, 8.150E-08, 7.544E-08, & + 6.786E-08, 5.504E-08, 4.080E-08, & + 2.960E-08, 2.300E-08, 2.030E-08, 1.997E-08/ + DATA C1_CSSSM_19/ 7.659E-01, 7.658E-01, 7.652E-01, & + 7.639E-01, 7.631E-01, 7.623E-01, & + 7.618E-01, 7.614E-01, 7.610E-01, & + 7.598E-01, 7.581E-01, 7.566E-01, & + 7.546E-01, 7.513E-01, 7.472E-01, & + 7.423E-01, 7.376E-01, 7.342E-01, 7.334E-01/ + DATA C2_CSSSM_19/ 3.691E-02, 3.694E-02, 3.729E-02, & + 3.796E-02, 3.839E-02, 3.883E-02, & + 3.913E-02, 3.931E-02, 3.953E-02, & + 4.035E-02, 4.153E-02, 4.263E-02, & + 4.400E-02, 4.631E-02, 4.933E-02, & + 5.331E-02, 5.734E-02, 6.053E-02, 6.128E-02/ +!SUPER COARSE MODE + DATA A1_SSSSM_19/ 2.836E-01, 2.876E-01, 2.563E-01, & + 2.414E-01, 2.541E-01, 2.546E-01, & + 2.572E-01, 2.638E-01, 2.781E-01, & + 3.167E-01, 4.209E-01, 5.286E-01, & + 6.959E-01, 9.233E-01, 1.282E+00, & + 1.836E+00, 2.981E+00, 4.355E+00, 4.059E+00/ + DATA A2_SSSSM_19/ 1.608E-01, 1.651E-01, 1.577E-01, & + 1.587E-01, 1.686E-01, 1.690E-01, & + 1.711E-01, 1.762E-01, 1.874E-01, & + 2.138E-01, 2.751E-01, 3.363E-01, & + 4.279E-01, 5.519E-01, 7.421E-01, & + 1.048E+00, 1.702E+00, 2.485E+00, 2.317E+00/ + DATA A3_SSSSM_19/-3.025E-03, -3.111E-03, -2.981E-03, & + -3.005E-03, -3.193E-03, -3.200E-03, & + -3.239E-03, -3.336E-03, -3.548E-03, & + -4.047E-03, -5.196E-03, -6.345E-03, & + -8.061E-03, -1.038E-02, -1.395E-02, & + -1.970E-02, -3.197E-02, -4.669E-02, -4.352E-02/ + DATA B1_SSSSM_19/ 6.759E-07, 6.246E-07, 5.542E-07, & + 4.953E-07, 4.746E-07, 4.738E-07, & + 4.695E-07, 4.588E-07, 4.354E-07, & + 3.947E-07, 3.461E-07, 3.067E-07, & + 2.646E-07, 2.095E-07, 1.481E-07, & + 9.024E-08, 5.747E-08, 2.384E-08, 6.599E-09/ + DATA B2_SSSSM_19/ 5.977E-07, 5.390E-07, 4.468E-07, & + 3.696E-07, 3.443E-07, 3.433E-07, & + 3.380E-07, 3.249E-07, 2.962E-07, & + 2.483E-07, 1.989E-07, 1.623E-07, & + 1.305E-07, 9.015E-08, 6.111E-08, & + 3.761E-08, 2.903E-08, 2.337E-08, 2.147E-08/ + DATA C1_SSSSM_19/ 8.120E-01, 8.084E-01, 8.016E-01, & + 7.953E-01, 7.929E-01, 7.928E-01, & + 7.923E-01, 7.910E-01, 7.882E-01, & + 7.834E-01, 7.774E-01, 7.725E-01, & + 7.673E-01, 7.604E-01, 7.529E-01, & + 7.458E-01, 7.419E-01, 7.379E-01, 7.360E-01/ + DATA C2_SSSSM_19/ 2.388E-02, 2.392E-02, 2.457E-02, 2.552E-02, & + 2.615E-02, 2.618E-02, 2.631E-02, 2.663E-02, & + 2.735E-02, 2.875E-02, 3.113E-02, 3.330E-02, & + 3.615E-02, 3.997E-02, 4.521E-02, 5.038E-02, & + 5.358E-02, 5.705E-02, 5.887E-02/ +!********************************************************************* +! +! +! +! +! +! +! From here on we look at the optical parameters at 5 wavelengths: +! 443nm, 550, 670, 765 and 865 nm +! le 12 AVRIL 2006 +! + DATA alpha_aers_5wv/ & + ! bc soluble + 7.930,7.930,7.930,7.930,7.930,7.930, & + 7.930,7.930,10.893,12.618,14.550,16.613, & + 7.658,7.658,7.658,7.658,7.658,7.658, & + 7.658,7.658,10.351,11.879,13.642,15.510, & + 7.195,7.195,7.195,7.195,7.195,7.195, & + 7.195,7.195,9.551,10.847,12.381,13.994, & + 6.736,6.736,6.736,6.736,6.736,6.736, & + 6.736,6.736,8.818,9.938,11.283,12.687, & + 6.277,6.277,6.277,6.277,6.277,6.277, & + 6.277,6.277,8.123,9.094,10.275,11.501, & + ! pom soluble + 6.676,6.676,6.676,6.676,6.710,6.934, & + 7.141,7.569,8.034,8.529,9.456,10.511, & + 5.109,5.109,5.109,5.109,5.189,5.535, & + 5.960,6.852,8.008,9.712,12.897,19.676, & + 3.718,3.718,3.718,3.718,3.779,4.042, & + 4.364,5.052,5.956,7.314,9.896,15.688, & + 2.849,2.849,2.849,2.849,2.897,3.107, & + 3.365,3.916,4.649,5.760,7.900,12.863, & + 2.229,2.229,2.229,2.229,2.268,2.437, & + 2.645,3.095,3.692,4.608,6.391,10.633, & + ! Sulfate (Accumulation) + 5.751,6.215,6.690,7.024,7.599,8.195, & + 9.156,10.355,12.660,14.823,18.908,24.508, & + 4.320,4.675,5.052,5.375,5.787,6.274, & + 7.066,8.083,10.088,12.003,15.697,21.133, & + 3.079,3.351,3.639,3.886,4.205,4.584, & + 5.206,6.019,7.648,9.234,12.391,17.220, & + 2.336,2.552,2.781,2.979,3.236,3.540, & + 4.046,4.711,6.056,7.388,10.093,14.313, & + 1.777,1.949,2.134,2.292,2.503,2.751, & + 3.166,3.712,4.828,5.949,8.264,11.922, & + ! Sulfate (Coarse) + 5.751,6.215,6.690,7.024,7.599,8.195, & + 9.156,10.355,12.660,14.823,18.908,24.508, & + 4.320,4.675,5.052,5.375,5.787,6.274, & + 7.066,8.083,10.088,12.003,15.697,21.133, & + 3.079,3.351,3.639,3.886,4.205,4.584, & + 5.206,6.019,7.648,9.234,12.391,17.220, & + 2.336,2.552,2.781,2.979,3.236,3.540, & + 4.046,4.711,6.056,7.388,10.093,14.313, & + 1.777,1.949,2.134,2.292,2.503,2.751, & + 3.166,3.712,4.828,5.949,8.264,11.922, & + ! Seasalt soluble super_coarse (computed below for 550nm) + 0.50,0.90,1.05,1.21,1.40,2.41, & + 2.66,3.11,3.88,4.52,5.69,8.84, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.52,0.93,1.08,1.24,1.43,2.47, & + 2.73,3.20,3.99,4.64,5.84,9.04, & + 0.52,0.93,1.09,1.25,1.44,2.50, & + 2.76,3.23,4.03,4.68,5.89,9.14, & + 0.52,0.94,1.09,1.26,1.45,2.51, & + 2.78,3.25,4.06,4.72,5.94,9.22, & + ! seasalt soluble coarse (computed below for 550nm) + 0.50,0.90,1.05,1.21,1.40,2.41, & + 2.66,3.11,3.88,4.52,5.69,8.84, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.52,0.93,1.08,1.24,1.43,2.47, & + 2.73,3.20,3.99,4.64,5.84,9.04, & + 0.52,0.93,1.09,1.25,1.44,2.50, & + 2.76,3.23,4.03,4.68,5.89,9.14, & + 0.52,0.94,1.09,1.26,1.45,2.51, & + 2.78,3.25,4.06,4.72,5.94,9.22, & + ! seasalt soluble accumulation (computed below for 550nm) + 4.28, 7.17, 8.44, 9.85,11.60,22.44, & + 25.34,30.54,39.38,46.52,59.33,91.77, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 2.48, 4.22, 5.02, 5.94, 7.11,15.29, & + 17.70,22.31,30.73,38.06,52.15,90.59, & + 1.90, 3.29, 3.94, 4.69, 5.65, 12.58, & + 14.68,18.77,26.41,33.25,46.77,85.50, & + 1.47, 2.59, 3.12, 3.74, 4.54, 10.42, & + 12.24,15.82,22.66,28.91,41.54,79.33/ + + DATA alpha_aeri_5wv/ & + ! dust insoluble + 0.759, 0.770, 0.775, 0.775, 0.772, & + !!jb bc insoluble + 11.536,10.033, 8.422, 7.234, 6.270, & + ! pom insoluble + 5.042, 3.101, 1.890, 1.294, 0.934/ + ! + DATA cg_aers_5wv/ & + ! bc soluble + .651, .651, .651, .651, .651, .651, & + .651, .651, .738, .764, .785, .800, & + .597, .597, .597, .597, .597, .597, & + .597, .597, .695, .725, .751, .770, & + .543, .543, .543, .543, .543, .543, & + .543, .543, .650, .684, .714, .736, & + .504, .504, .504, .504, .504, .504, & + .504, .504, .614, .651, .683, .708, & + .469, .469, .469, .469, .469, .469, & + .469, .469, .582, .620, .655, .681, & + ! pom soluble + .679, .679, .679, .679, .683, .691, & + .703, .720, .736, .751, .766, .784, & + .656, .656, .656, .656, .659, .669, & + .681, .699, .717, .735, .750, .779, & + .623, .623, .623, .623, .627, .637, & + .649, .668, .688, .709, .734, .762, & + .592, .592, .592, .592, .595, .605, & + .618, .639, .660, .682, .711, .743, & + .561, .561, .561, .561, .565, .575, & + .588, .609, .632, .656, .688, .724, & + ! Accumulation sulfate + .671, .684, .697, .704, .714, .723, & + .734, .746, .762, .771, .781, .789, & + .653, .666, .678, .687, .697, .707, & + .719, .732, .751, .762, .775, .789, & + .622, .635, .648, .657, .667, .678, & + .691, .705, .728, .741, .758, .777, & + .591, .604, .617, .627, .638, .650, & + .664, .679, .704, .719, .739, .761, & + .560, .574, .587, .597, .609, .621, & + .637, .653, .680, .697, .719, .745, & + ! Coarse sulfate + .671, .684, .697, .704, .714, .723, & + .734, .746, .762, .771, .781, .789, & + .653, .666, .678, .687, .697, .707, & + .719, .732, .751, .762, .775, .789, & + .622, .635, .648, .657, .667, .678, & + .691, .705, .728, .741, .758, .777, & + .591, .604, .617, .627, .638, .650, & + .664, .679, .704, .719, .739, .761, & + .560, .574, .587, .597, .609, .621, & + .637, .653, .680, .697, .719, .745, & + ! For super coarse seasalt (computed below for 550nm!) + 0.730,0.753,0.760,0.766,0.772,0.793, & + 0.797,0.802,0.809,0.813,0.820,0.830, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.721,0.744,0.750,0.756,0.762,0.784, & + 0.787,0.793,0.800,0.804,0.811,0.822, & + 0.717,0.741,0.747,0.753,0.759,0.780, & + 0.784,0.789,0.795,0.800,0.806,0.817, & + 0.715,0.739,0.745,0.751,0.757,0.777, & + 0.781,0.786,0.793,0.797,0.803,0.814, & + ! For coarse-soluble seasalt (computed below for 550nm!) + 0.730,0.753,0.760,0.766,0.772,0.793, & + 0.797,0.802,0.809,0.813,0.820,0.830, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.721,0.744,0.750,0.756,0.762,0.784, & + 0.787,0.793,0.800,0.804,0.811,0.822, & + 0.717,0.741,0.747,0.753,0.759,0.780, & + 0.784,0.789,0.795,0.800,0.806,0.817, & + 0.715,0.739,0.745,0.751,0.757,0.777, & + 0.781,0.786,0.793,0.797,0.803,0.814, & + ! accumulation-seasalt soluble (computed below for 550nm!) + 0.698,0.722,0.729,0.736,0.743,0.765, & + 0.768,0.773,0.777,0.779,0.781,0.779, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.658,0.691,0.701,0.710,0.720,0.756, & + 0.763,0.771,0.782,0.788,0.795,0.801, & + 0.632,0.668,0.679,0.690,0.701,0.743, & + 0.750,0.762,0.775,0.783,0.792,0.804, & + 0.605,0.644,0.656,0.669,0.681,0.729, & + 0.737,0.750,0.765,0.775,0.787,0.803/ + ! + + DATA cg_aeri_5wv/& + ! dust insoluble + 0.714, 0.697, 0.688, 0.683, 0.679, & + ! bc insoluble + 0.511, 0.445, 0.384, 0.342, 0.307, & + !c pom insoluble + 0.596, 0.536, 0.466, 0.409, 0.359/ + ! + DATA piz_aers_5wv/& + ! bc soluble + .445, .445, .445, .445, .445, .445, & + .445, .445, .470, .487, .508, .531, & + .442, .442, .442, .442, .442, .442, & + .442, .442, .462, .481, .506, .533, & + .427, .427, .427, .427, .427, .427, & + .427, .427, .449, .470, .497, .526, & + .413, .413, .413, .413, .413, .413, & + .413, .413, .437, .458, .486, .516, & + .399, .399, .399, .399, .399, .399, & + .399, .399, .423, .445, .473, .506, & + ! pom soluble + .975, .975, .975, .975, .975, .977, & + .979, .982, .984, .987, .990, .994, & + .972, .972, .972, .972, .973, .974, & + .977, .980, .983, .986, .989, .993, & + .963, .963, .963, .963, .964, .966, & + .969, .974, .977, .982, .986, .991, & + .955, .955, .955, .955, .955, .958, & + .962, .967, .972, .977, .983, .989, & + .944, .944, .944, .944, .944, .948, & + .952, .959, .962, .972, .979, .987, & + ! sulfate soluble accumulation + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + ! sulfate soluble coarse + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + ! seasalt super coarse (computed below for 550nm) + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + ! seasalt coarse (computed below for 550nm) + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + ! seasalt soluble accumulation (computed below for 550nm) + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000/ + + ! + DATA piz_aeri_5wv/& + ! dust insoluble + 0.944, 0.970, 0.977, 0.982, 0.987, & + ! bc insoluble + 0.415, 0.387, 0.355, 0.328, 0.301, & + ! pom insoluble + 0.972, 0.963, 0.943, 0.923, 0.897/ + +! Interpolation des coefficients optiques de 19 niveaux vers le nombre des niveaux du model + IF (firstcall) THEN + firstcall=.FALSE. +! Allocation + IF (.NOT. ALLOCATED(A1_ASSSM)) THEN + ALLOCATE(A1_ASSSM(klev),A2_ASSSM(klev), A3_ASSSM(klev),& + B1_ASSSM(klev), B2_ASSSM(klev), C1_ASSSM(klev), C2_ASSSM(klev),& + A1_CSSSM(klev), A2_CSSSM(klev), A3_CSSSM(klev),& + B1_CSSSM(klev), B2_CSSSM(klev), C1_CSSSM(klev), C2_CSSSM(klev),& + A1_SSSSM(klev), A2_SSSSM(klev), A3_SSSSM(klev),& + B1_SSSSM(klev), B2_SSSSM(klev), C1_SSSSM(klev), C2_SSSSM(klev), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('aeropt_5mw', 'pb in allocation 1',1) + END IF + +!Accumulation mode + CALL pres2lev(A1_ASSSM_19, A1_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_ASSSM_19, A2_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_ASSSM_19, A3_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_ASSSM_19, B1_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_ASSSM_19, B2_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_ASSSM_19, C1_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_ASSSM_19, C2_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) +!Coarse mode + CALL pres2lev(A1_CSSSM_19, A1_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_CSSSM_19, A2_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_CSSSM_19, A3_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_CSSSM_19, B1_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_CSSSM_19, B2_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_CSSSM_19, C1_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_CSSSM_19, C2_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) +!Super coarse mode + CALL pres2lev(A1_SSSSM_19, A1_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_SSSSM_19, A2_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_SSSSM_19, A3_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_SSSSM_19, B1_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_SSSSM_19, B2_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_SSSSM_19, C1_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_SSSSM_19, C2_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + + END IF ! firstcall + + + ! Initialisations + ai(:) = 0. + tausum(:,:,:) = 0. + + + DO k=1, klev + DO i=1, klon +! IF (t_seri(i,k).EQ.0) stop 'stop aeropt_5wv T ' +! IF (pplay(i,k).EQ.0) stop 'stop aeropt_5wv p ' + zrho=pplay(i,k)/t_seri(i,k)/RD ! kg/m3 +!CDIR UNROLL=naero_spc + mass_temp(i,k,:) = m_allaer(i,k,:) / zrho / 1.e+9 + zdp1(i,k)=pdel(i,k)/(gravit*delt) ! air mass auxiliary variable --> zdp1 [kg/(m^2 *s)] + + ENDDO + ENDDO + + + IF (flag_aerosol .EQ. 1) THEN + nb_aer = 2 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_ASSO4M + aerosol_name(2) = id_CSSO4M + ELSEIF (flag_aerosol .EQ. 2) THEN + nb_aer = 2 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_ASBCM + aerosol_name(2) = id_AIBCM + ELSEIF (flag_aerosol .EQ. 3) THEN + nb_aer = 2 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_ASPOMM + aerosol_name(2) = id_AIPOMM + ELSEIF (flag_aerosol .EQ. 4) THEN + nb_aer = 3 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_CSSSM + aerosol_name(2) = id_SSSSM + aerosol_name(3) = id_ASSSM + ELSEIF (flag_aerosol .EQ. 5) THEN + nb_aer = 1 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_CIDUSTM + ELSEIF (flag_aerosol .EQ. 6) THEN + nb_aer = 10 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_ASSO4M + aerosol_name(2) = id_ASBCM + aerosol_name(3) = id_AIBCM + aerosol_name(4) = id_ASPOMM + aerosol_name(5) = id_AIPOMM + aerosol_name(6) = id_CSSSM + aerosol_name(7) = id_SSSSM + aerosol_name(8) = id_ASSSM + aerosol_name(9) = id_CIDUSTM + aerosol_name(10) = id_CSSO4M + ENDIF + + ! + ! loop over modes, use of precalculated nmd and corresponding sigma + ! loop over wavelengths + ! for each mass species in mode + ! interpolate from Sext to retrieve Sext_at_gridpoint_per_species + ! compute optical_thickness_at_gridpoint_per_species + + + ! + ! Calculations that need to be done since we are not in the subroutines INCA + ! + +!CDIR ON_ADB(RH_tab) +!CDIR ON_ADB(fact_RH) +!CDIR NOVECTOR + DO n=1,nbre_RH-1 + fact_RH(n)=1./(RH_tab(n+1)-RH_tab(n)) + ENDDO + + DO k=1, KLEV +!CDIR ON_ADB(RH_tab) +!CDIR ON_ADB(fact_RH) + DO i=1, KLON + rh(i,k)=MIN(RHcl(i,k)*100.,RH_MAX) + RH_num(i,k) = INT( rh(i,k)/10. + 1.) + IF (rh(i,k).GT.85.) RH_num(i,k)=10 + IF (rh(i,k).GT.90.) RH_num(i,k)=11 + DELTA(i,k)=(rh(i,k)-RH_tab(RH_num(i,k)))*fact_RH(RH_num(i,k)) + ENDDO + ENDDO + +!CDIR SHORTLOOP + used_tau(:)=.FALSE. + + DO m=1,nb_aer ! tau is only computed for each mass + fac=1.0 + IF (aerosol_name(m).EQ.id_ASBCM) THEN + soluble=.TRUE. + spsol=1 + spss=0 + ELSEIF (aerosol_name(m).EQ.id_ASPOMM) THEN + soluble=.TRUE. + spsol=2 + spss=0 + ELSEIF (aerosol_name(m).EQ.id_ASSO4M) THEN + soluble=.TRUE. + spsol=3 + spss=0 + fac=1.375 ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD + ELSEIF (aerosol_name(m).EQ.id_CSSO4M) THEN + soluble=.TRUE. + spsol=4 + spss=0 + fac=1.375 ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD + ELSEIF (aerosol_name(m).EQ.id_SSSSM) THEN + soluble=.TRUE. + spsol=5 + spss=3 + ELSEIF (aerosol_name(m).EQ.id_CSSSM) THEN + soluble=.TRUE. + spsol=6 + spss=2 + ELSEIF (aerosol_name(m).EQ.id_ASSSM) THEN + soluble=.TRUE. + spsol=7 + spss=1 + ELSEIF (aerosol_name(m).EQ.id_CIDUSTM) THEN + soluble=.FALSE. + spinsol=1 + spss=0 + ELSEIF (aerosol_name(m).EQ.id_AIBCM) THEN + soluble=.FALSE. + spinsol=2 + spss=0 + ELSEIF (aerosol_name(m).EQ.id_AIPOMM) THEN + soluble=.FALSE. + spinsol=3 + spss=0 + ELSE + CYCLE + ENDIF + + used_tau(spsol)=.TRUE. + DO la=1,las + + IF (soluble) THEN + + IF((la.EQ.2).AND.(spss.NE.0)) THEN !la=2 corresponds to 550 nm + IF (spss.EQ.1) THEN !accumulation mode + DO k=1, KLEV +!CDIR ON_ADB(A1_ASSSM) +!CDIR ON_ADB(A2_ASSSM) +!CDIR ON_ADB(A3_ASSSM) + DO i=1, KLON + H=rh(i,k)/100 + tau_ae5wv_int=A1_ASSSM(k)+A2_ASSSM(k)*H+A3_ASSSM(k)/(H-1.05) + tau(i,k,la,spsol) = mass_temp(i,k,spsol)*1000.*zdp1(i,k) & + *tau_ae5wv_int*delt*fac + tausum(i,la,spsol)=tausum(i,la,spsol)+tau(i,k,la,spsol) + ENDDO + ENDDO + ENDIF + + IF (spss.EQ.2) THEN !coarse mode + DO k=1, KLEV +!CDIR ON_ADB(A1_CSSSM) +!CDIR ON_ADB(A2_CSSSM) +!CDIR ON_ADB(A3_CSSSM) + DO i=1, KLON + H=rh(i,k)/100 + tau_ae5wv_int=A1_CSSSM(k)+A2_CSSSM(k)*H+A3_CSSSM(k)/(H-1.05) + tau(i,k,la,spsol) = mass_temp(i,k,spsol)*1000.*zdp1(i,k) & + *tau_ae5wv_int*delt*fac + tausum(i,la,spsol) = tausum(i,la,spsol)+tau(i,k,la,spsol) + ENDDO + ENDDO + ENDIF + + IF (spss.EQ.3) THEN !super coarse mode + DO k=1, KLEV +!CDIR ON_ADB(A1_SSSSM) +!CDIR ON_ADB(A2_SSSSM) +!CDIR ON_ADB(A3_SSSSM) + DO i=1, KLON + H=rh(i,k)/100 + tau_ae5wv_int=A1_SSSSM(k)+A2_SSSSM(k)*H+A3_SSSSM(k)/(H-1.05) + tau(i,k,la,spsol) = mass_temp(i,k,spsol)*1000.*zdp1(i,k) & + *tau_ae5wv_int*delt*fac + tausum(i,la,spsol)=tausum(i,la,spsol)+tau(i,k,la,spsol) + ENDDO + ENDDO + ENDIF + + ELSE + DO k=1, KLEV +!CDIR ON_ADB(alpha_aers_5wv) + DO i=1, KLON + tau_ae5wv_int = alpha_aers_5wv(RH_num(i,k),la,spsol)+DELTA(i,k)* & + (alpha_aers_5wv(RH_num(i,k)+1,la,spsol) - & + alpha_aers_5wv(RH_num(i,k),la,spsol)) + + tau(i,k,la,spsol) = mass_temp(i,k,spsol)*1000.*zdp1(i,k) & + *tau_ae5wv_int*delt*fac + tausum(i,la,spsol)=tausum(i,la,spsol)+tau(i,k,la,spsol) + ENDDO + ENDDO + ENDIF + + ELSE ! For insoluble aerosol + DO k=1, KLEV +!CDIR ON_ADB(alpha_aeri_5wv) + DO i=1, KLON + tau_ae5wv_int = alpha_aeri_5wv(la,spinsol) + tau(i,k,la,naero_soluble+spinsol) = mass_temp(i,k,naero_soluble+spinsol)*1000.*zdp1(i,k)* & + tau_ae5wv_int*delt*fac + tausum(i,la,naero_soluble+spinsol)= tausum(i,la,naero_soluble+spinsol) & + +tau(i,k,la,naero_soluble+spinsol) + ENDDO + ENDDO + ENDIF + ENDDO ! boucle sur les longueurs d'onde + ENDDO ! Boucle sur les masses de traceurs + + DO m=1,naero_spc + IF (.NOT.used_tau(m)) tau(:,:,:,m)=0. + ENDDO +! +! +! taue670(:) = SUM(tausum(:,la670,:),dim=2) +! taue865(:) = SUM(tausum(:,la865,:),dim=2) +! +! DO i=1, klon +! ai(i)=-LOG(MAX(taue670(i),0.0001)/ & +! MAX(taue865(i),0.0001))/LOG(670./865.) +! ENDDO + + DEALLOCATE(aerosol_name) + +END SUBROUTINE AEROPT_5WV Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ajsec.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ajsec.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ajsec.F (revision 1280) @@ -0,0 +1,403 @@ +! +! $Header$ +! + SUBROUTINE ajsec(paprs, pplay, t,q,limbas,d_t,d_q) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: ajustement sec (adaptation du GCM du LMD) +c====================================================================== +c Arguments: +c t-------input-R- Temperature +c +c d_t-----output-R-Incrementation de la temperature +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" + REAL paprs(klon,klev+1), pplay(klon,klev) + REAL t(klon,klev), q(klon,klev) + REAL d_t(klon,klev), d_q(klon,klev) +c + INTEGER limbas(klon), limhau ! les couches a ajuster +c + LOGICAL mixq +ccc PARAMETER (mixq=.TRUE.) + PARAMETER (mixq=.FALSE.) +c + REAL zh(klon,klev) + REAL zho(klon,klev) + REAL zq(klon,klev) + REAL zpk(klon,klev) + REAL zpkdp(klon,klev) + REAL hm, sm, qm + LOGICAL modif(klon), down + INTEGER i, k, k1, k2 +c +c Initialisation: +c +cym + limhau=klev + + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + ENDDO + ENDDO +c------------------------------------- detection des profils a modifier + DO k = 1, limhau + DO i = 1, klon + zpk(i,k) = pplay(i,k)**RKAPPA + zh(i,k) = RCPD * t(i,k)/ zpk(i,k) + zho(i,k) = zh(i,k) + zq(i,k) = q(i,k) + ENDDO + ENDDO +c + DO k = 1, limhau + DO i = 1, klon + zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1)) + ENDDO + ENDDO +c + DO i = 1, klon + modif(i) = .FALSE. + ENDDO + DO k = 2, limhau + DO i = 1, klon + IF (.NOT.modif(i).and.k-1>limbas(i)) THEN + IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE. + ENDIF + ENDDO + ENDDO +c------------------------------------- correction des profils instables + DO 1080 i = 1, klon + IF (modif(i)) THEN + k2 = limbas(i) + 8000 CONTINUE + k2 = k2 + 1 + IF (k2 .GT. limhau) goto 8001 + IF (zh(i,k2) .LT. zh(i,k2-1)) THEN + k1 = k2 - 1 + k = k1 + sm = zpkdp(i,k2) + hm = zh(i,k2) + qm = zq(i,k2) + 8020 CONTINUE + sm = sm +zpkdp(i,k) + hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm + qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm + down = .FALSE. + IF (k1 .ne. limbas(i)) THEN + IF (hm .LT. zh(i,k1-1)) down = .TRUE. + ENDIF + IF (down) THEN + k1 = k1 - 1 + k = k1 + ELSE + IF ((k2 .EQ. limhau)) GOTO 8021 + IF ((zh(i,k2+1).GE.hm)) GOTO 8021 + k2 = k2 + 1 + k = k2 + ENDIF + GOTO 8020 + 8021 CONTINUE +c------------ nouveau profil : constant (valeur moyenne) + DO k = k1, k2 + zh(i,k) = hm + zq(i,k) = qm + ENDDO + k2 = k2 + 1 + ENDIF + GOTO 8000 + 8001 CONTINUE + ENDIF + 1080 CONTINUE +c + DO k = 1, limhau + DO i = 1, klon + d_t(i,k) = (zh(i,k)-zho(i,k))*zpk(i,k)/RCPD + d_q(i,k) = zq(i,k) - q(i,k) + ENDDO + ENDDO +c +! FH : les d_q et d_t sont maintenant calcules de facon a valoir +! effectivement 0. si on ne fait rien. +! +! IF (limbas.GT.1) THEN +! DO k = 1, limbas-1 +! DO i = 1, klon +! d_t(i,k) = 0.0 +! d_q(i,k) = 0.0 +! ENDDO +! ENDDO +! ENDIF +c +! IF (limhau.LT.klev) THEN +! DO k = limhau+1, klev +! DO i = 1, klon +! d_t(i,k) = 0.0 +! d_q(i,k) = 0.0 +! ENDDO +! ENDDO +! ENDIF +c + IF (.NOT.mixq) THEN + DO k = 1, klev + DO i = 1, klon + d_q(i,k) = 0.0 + ENDDO + ENDDO + ENDIF +c + RETURN + END + + SUBROUTINE ajsec_convV2(paprs, pplay, t,q, d_t,d_q) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: ajustement sec (adaptation du GCM du LMD) +c====================================================================== +c Arguments: +c t-------input-R- Temperature +c +c d_t-----output-R-Incrementation de la temperature +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" + REAL paprs(klon,klev+1), pplay(klon,klev) + REAL t(klon,klev), q(klon,klev) + REAL d_t(klon,klev), d_q(klon,klev) +c + INTEGER limbas, limhau ! les couches a ajuster +ccc PARAMETER (limbas=klev-3, limhau=klev) +cym PARAMETER (limbas=1, limhau=klev) +c + LOGICAL mixq +ccc PARAMETER (mixq=.TRUE.) + PARAMETER (mixq=.FALSE.) +c + REAL zh(klon,klev) + REAL zq(klon,klev) + REAL zpk(klon,klev) + REAL zpkdp(klon,klev) + REAL hm, sm, qm + LOGICAL modif(klon), down + INTEGER i, k, k1, k2 +c +c Initialisation: +c +cym + limbas=1 + limhau=klev + + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + ENDDO + ENDDO +c------------------------------------- detection des profils a modifier + DO k = limbas, limhau + DO i = 1, klon + zpk(i,k) = pplay(i,k)**RKAPPA + zh(i,k) = RCPD * t(i,k)/ zpk(i,k) + zq(i,k) = q(i,k) + ENDDO + ENDDO +c + DO k = limbas, limhau + DO i = 1, klon + zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1)) + ENDDO + ENDDO +c + DO i = 1, klon + modif(i) = .FALSE. + ENDDO + DO k = limbas+1, limhau + DO i = 1, klon + IF (.NOT.modif(i)) THEN + IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE. + ENDIF + ENDDO + ENDDO +c------------------------------------- correction des profils instables + DO 1080 i = 1, klon + IF (modif(i)) THEN + k2 = limbas + 8000 CONTINUE + k2 = k2 + 1 + IF (k2 .GT. limhau) goto 8001 + IF (zh(i,k2) .LT. zh(i,k2-1)) THEN + k1 = k2 - 1 + k = k1 + sm = zpkdp(i,k2) + hm = zh(i,k2) + qm = zq(i,k2) + 8020 CONTINUE + sm = sm +zpkdp(i,k) + hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm + qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm + down = .FALSE. + IF (k1 .ne. limbas) THEN + IF (hm .LT. zh(i,k1-1)) down = .TRUE. + ENDIF + IF (down) THEN + k1 = k1 - 1 + k = k1 + ELSE + IF ((k2 .EQ. limhau)) GOTO 8021 + IF ((zh(i,k2+1).GE.hm)) GOTO 8021 + k2 = k2 + 1 + k = k2 + ENDIF + GOTO 8020 + 8021 CONTINUE +c------------ nouveau profil : constant (valeur moyenne) + DO k = k1, k2 + zh(i,k) = hm + zq(i,k) = qm + ENDDO + k2 = k2 + 1 + ENDIF + GOTO 8000 + 8001 CONTINUE + ENDIF + 1080 CONTINUE +c + DO k = limbas, limhau + DO i = 1, klon + d_t(i,k) = zh(i,k)*zpk(i,k)/RCPD - t(i,k) + d_q(i,k) = zq(i,k) - q(i,k) + ENDDO + ENDDO +c + IF (limbas.GT.1) THEN + DO k = 1, limbas-1 + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + ENDDO + ENDDO + ENDIF +c + IF (limhau.LT.klev) THEN + DO k = limhau+1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + ENDDO + ENDDO + ENDIF +c + IF (.NOT.mixq) THEN + DO k = 1, klev + DO i = 1, klon + d_q(i,k) = 0.0 + ENDDO + ENDDO + ENDIF +c + RETURN + END + SUBROUTINE ajsec_old(paprs, pplay, t, d_t) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: ajustement sec (adaptation du GCM du LMD) +c====================================================================== +c Arguments: +c t-------input-R- Temperature +c +c d_t-----output-R-Incrementation de la temperature +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" + REAL paprs(klon,klev+1), pplay(klon,klev) + REAL t(klon,klev) + REAL d_t(klon,klev) +c + REAL local_h(klon,klev) + REAL hm, sm + LOGICAL modif(klon), down + INTEGER i, l, l1, l2 +c------------------------------------- detection des profils a modifier + DO i = 1, klon + modif(i) = .false. + ENDDO +c + DO l = 1, klev + DO i = 1, klon + local_h(i,l) = RCPD * t(i,l)/ (pplay(i,l)**RKAPPA) + ENDDO + ENDDO +c + DO l = 2, klev + DO i = 1, klon + IF ( local_h(i,l).lt.local_h(i,l-1) ) THEN + modif(i) = .true. + ELSE + modif(i) = modif(i) + ENDIF + ENDDO + ENDDO +c------------------------------------- correction des profils instables + do 1080 i = 1, klon + if (modif(i)) then + l2 = 1 + 8000 continue + l2 = l2 + 1 + if (l2 .gt. klev) goto 8001 + if (local_h(i, l2) .lt. local_h(i, l2-1)) then + l1 = l2 - 1 + l = l1 + sm = pplay(i,l2)**rkappa * (paprs(i,l2)-paprs(i,l2+1)) + hm = local_h(i, l2) + 8020 continue + sm = sm +pplay(i,l)**rkappa*(paprs(i,l)-paprs(i,l+1)) + hm = hm +pplay(i,l)**rkappa*(paprs(i,l)-paprs(i,l+1)) + . * (local_h(i, l) - hm) / sm + down = .false. + if (l1 .ne. 1) then + if (hm .lt. local_h(i, l1-1)) then + down = .true. + end if + end if + if (down) then + l1 = l1 - 1 + l = l1 + else + if ((l2 .eq. klev)) GOTO 8021 + IF ((local_h(i, l2+1).ge.hm)) goto 8021 + l2 = l2 + 1 + l = l2 + end if + go to 8020 + 8021 continue +c------------ nouveau profil : constant (valeur moyenne) + do 1100 l = l1, l2 + local_h(i, l) = hm + 1100 continue + l2 = l2 + 1 + end if + go to 8000 + 8001 continue + end if + 1080 continue +c + DO l = 1, klev + DO i = 1, klon + d_t(i,l) = local_h(i,l)*(pplay(i,l)**rkappa)/RCPD - t(i,l) + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/albedo.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/albedo.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/albedo.F (revision 1280) @@ -0,0 +1,191 @@ +! +! $Header$ +! +c +c + SUBROUTINE alboc(rjour,rlat,albedo) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM du LMD) +c Date: le 16 mars 1995 +c Objet: Calculer l'albedo sur l'ocean +c Methode: Integrer numeriquement l'albedo pendant une journee +c +c Arguments; +c rjour (in,R) : jour dans l'annee (a compter du 1 janvier) +c rlat (in,R) : latitude en degre +c albedo (out,R): albedo obtenu (de 0 a 1) +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "clesphys.h" +c +c fmagic -> clesphys.h/.inc +c REAL fmagic ! un facteur magique pour regler l'albedo +ccc PARAMETER (fmagic=0.7) +cccIM => a remplacer +c PARAMETER (fmagic=1.32) +c PARAMETER (fmagic=1.0) +c PARAMETER (fmagic=0.7) + INTEGER npts ! il controle la precision de l'integration + PARAMETER (npts=120) ! 120 correspond a l'interval 6 minutes +c + REAL rlat(klon), rjour, albedo(klon) + REAL zdist, zlonsun, zpi, zdeclin + REAL rmu,alb, srmu, salb, fauxo, aa, bb + INTEGER i, k +cccIM + LOGICAL ancien_albedo + PARAMETER(ancien_albedo=.FALSE.) +c SAVE albedo +c + IF ( ancien_albedo ) THEN +c + zpi = 4. * ATAN(1.) +c +c Calculer la longitude vraie de l'orbite terrestre: + CALL orbite(rjour,zlonsun,zdist) +c +c Calculer la declinaison du soleil (qui varie entre + et - R_incl): + zdeclin = ASIN(SIN(zlonsun*zpi/180.0)*SIN(R_incl*zpi/180.0)) +c + DO 999 i=1,klon + aa = SIN(rlat(i)*zpi/180.0) * SIN(zdeclin) + bb = COS(rlat(i)*zpi/180.0) * COS(zdeclin) +c +c Midi local (angle du temps = 0.0): + rmu = aa + bb * COS(0.0) + rmu = MAX(0.0, rmu) + fauxo = (1.47-ACOS(rmu))/.15 + alb = 0.03+0.630/(1.+fauxo*fauxo) + srmu = rmu + salb = alb * rmu +c +c Faire l'integration numerique de midi a minuit (le facteur 2 +c prend en compte l'autre moitie de la journee): + DO k = 1, npts + rmu = aa + bb * COS(FLOAT(k)/FLOAT(npts)*zpi) + rmu = MAX(0.0, rmu) + fauxo = (1.47-ACOS(rmu))/.15 + alb = 0.03+0.630/(1.+fauxo*fauxo) + srmu = srmu + rmu * 2.0 + salb = salb + alb*rmu * 2.0 + ENDDO + IF (srmu .NE. 0.0) THEN + albedo(i) = salb / srmu * fmagic+pmagic + ELSE ! nuit polaire (on peut prendre une valeur quelconque) + albedo(i) = fmagic + ENDIF + 999 CONTINUE +c +c nouvel albedo +c + ELSE +c + zpi = 4. * ATAN(1.) +c +c Calculer la longitude vraie de l'orbite terrestre: + CALL orbite(rjour,zlonsun,zdist) +c +c Calculer la declinaison du soleil (qui varie entre + et - R_incl): + zdeclin = ASIN(SIN(zlonsun*zpi/180.0)*SIN(R_incl*zpi/180.0)) +c + DO 1999 i=1,klon + aa = SIN(rlat(i)*zpi/180.0) * SIN(zdeclin) + bb = COS(rlat(i)*zpi/180.0) * COS(zdeclin) +c +c Midi local (angle du temps = 0.0): + rmu = aa + bb * COS(0.0) + rmu = MAX(0.0, rmu) +cIM cf. PB alb = 0.058/(rmu + 0.30) +c alb = 0.058/(rmu + 0.30) * 1.5 + alb = 0.058/(rmu + 0.30) * 1.2 +c alb = 0.058/(rmu + 0.30) * 1.3 + srmu = rmu + salb = alb * rmu +c +c Faire l'integration numerique de midi a minuit (le facteur 2 +c prend en compte l'autre moitie de la journee): + DO k = 1, npts + rmu = aa + bb * COS(FLOAT(k)/FLOAT(npts)*zpi) + rmu = MAX(0.0, rmu) +cIM cf. PB alb = 0.058/(rmu + 0.30) +c alb = 0.058/(rmu + 0.30) * 1.5 + alb = 0.058/(rmu + 0.30) * 1.2 +c alb = 0.058/(rmu + 0.30) * 1.3 + srmu = srmu + rmu * 2.0 + salb = salb + alb*rmu * 2.0 + ENDDO + IF (srmu .NE. 0.0) THEN + albedo(i) = salb / srmu * fmagic+pmagic + ELSE ! nuit polaire (on peut prendre une valeur quelconque) + albedo(i) = fmagic + ENDIF +1999 CONTINUE + ENDIF + RETURN + END +c===================================================================== + SUBROUTINE alboc_cd(rmu0,albedo) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) +c date: 19940624 +c Calculer l'albedo sur l'ocean en fonction de l'angle zenithal moyen +c Formule due a Larson and Barkstrom (1977) Proc. of the symposium +C on radiation in the atmosphere, 19-28 August 1976, science Press, +C 1977 pp 451-453, ou These de 3eme cycle de Sylvie Joussaume. +c +c Arguments +c rmu0 (in): cosinus de l'angle solaire zenithal +c albedo (out): albedo de surface de l'ocean +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "clesphys.h" + REAL rmu0(klon), albedo(klon) +c +c REAL fmagic ! un facteur magique pour regler l'albedo +ccc PARAMETER (fmagic=0.7) +cccIM => a remplacer +c PARAMETER (fmagic=1.32) +c PARAMETER (fmagic=1.0) +c PARAMETER (fmagic=0.7) +c + REAL fauxo + INTEGER i +cccIM + LOGICAL ancien_albedo + PARAMETER(ancien_albedo=.FALSE.) +c SAVE albedo +c + IF ( ancien_albedo ) THEN +c + DO i = 1, klon +c + rmu0(i) = MAX(rmu0(i),0.0) +c + fauxo = ( 1.47 - ACOS( rmu0(i) ) )/0.15 + albedo(i) = fmagic*( .03 + .630/( 1. + fauxo*fauxo))+pmagic + albedo(i) = MAX(MIN(albedo(i),0.60),0.04) + ENDDO +c +c nouvel albedo +c + ELSE +c + DO i = 1, klon + rmu0(i) = MAX(rmu0(i),0.0) +cIM:orig albedo(i) = 0.058/(rmu0(i) + 0.30) + albedo(i) = fmagic * 0.058/(rmu0(i) + 0.30)+pmagic + albedo(i) = MAX(MIN(albedo(i),0.60),0.04) + ENDDO +c + ENDIF +c + RETURN + END +c======================================================================== Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/albsno.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/albsno.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/albsno.F90 (revision 1280) @@ -0,0 +1,55 @@ +! +! $Header$ +! +SUBROUTINE albsno(klon, knon, dtime, agesno, alb_neig_grid, precip_snow) + + IMPLICIT NONE + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: klon, knon + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: precip_snow + +! In/Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: alb_neig_grid + +! Local variables +!**************************************************************************************** + INTEGER :: i, nv + INTEGER, PARAMETER :: nvm = 8 + REAL :: as + REAL, DIMENSION(klon,nvm) :: veget + REAL, DIMENSION(nvm),SAVE :: init, decay + !$OMP THREADPRIVATE(init, decay) + + DATA init /0.55, 0.14, 0.18, 0.29, 0.15, 0.15, 0.14, 0./ + DATA decay/0.30, 0.67, 0.63, 0.45, 0.40, 0.14, 0.06, 1./ +!**************************************************************************************** + + veget = 0. + veget(:,1) = 1. ! desert partout + DO i = 1, knon + alb_neig_grid(i) = 0.0 + ENDDO + DO nv = 1, nvm + DO i = 1, knon + as = init(nv)+decay(nv)*EXP(-agesno(i)/5.) + alb_neig_grid(i) = alb_neig_grid(i) + veget(i,nv)*as + ENDDO + ENDDO + + +! modilation en fonction de l'age de la neige + DO i = 1, knon + agesno(i) = (agesno(i) + (1.-agesno(i)/50.)*dtime/86400.)& + & * EXP(-1.*MAX(0.0,precip_snow(i))*dtime/0.3) + agesno(i) = MAX(agesno(i),0.0) + ENDDO + +END SUBROUTINE albsno Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/atm2geo.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/atm2geo.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/atm2geo.F90 (revision 1280) @@ -0,0 +1,48 @@ +! +! $Header$ +! +SUBROUTINE atm2geo ( im, jm, pte, ptn, plon, plat, pxx, pyy, pzz ) + USE dimphy + USE mod_phys_lmdz_para + IMPLICIT NONE + INCLUDE 'dimensions.h' + INCLUDE 'YOMCST.h' +! +! Change wind local atmospheric coordinates to geocentric +! + INTEGER, INTENT (in) :: im, jm + REAL, DIMENSION (im,jm), INTENT (in) :: pte, ptn + REAL, DIMENSION (im,jm), INTENT (in) :: plon, plat + REAL, DIMENSION (im,jm), INTENT(out) :: pxx, pyy, pzz + + REAL :: rad + + + rad = rpi / 180.0E0 + + pxx(:,:) = & + - pte(:,:) * SIN(rad * plon(:,:)) & + - ptn(:,:) * SIN(rad * plat(:,:)) * COS(rad * plon(:,:)) + + pyy(:,:) = & + + pte(:,:) * COS(rad * plon(:,:)) & + - ptn(:,:) * SIN(rad * plat(:,:)) * SIN(rad * plon(:,:)) + + pzz(:,:) = & + + ptn(:,:) * COS(rad * plat (:,:)) + +! Value at North Pole + IF (is_north_pole) THEN + pxx(:, 1) = pxx(1,1) + pyy(:, 1) = pyy(1,1) + pzz(:, 1) = pzz(1,1) + ENDIF + +! Value at South Pole + IF (is_south_pole) THEN + pxx(:,jm) = pxx(1,jm) + pyy(:,jm) = pyy(1,jm) + pzz(:,jm) = pzz(1,jm) + ENDIF + +END SUBROUTINE atm2geo Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/buffer_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/buffer_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/buffer_mod.F90 (revision 1280) @@ -0,0 +1,86 @@ +MODULE buffer_mod + +PRIVATE + REAL,PARAMETER :: grow_factor=1.5 + + INTEGER, POINTER, SAVE :: buffer_i(:) + INTEGER,SAVE :: size_buffer_i = 0 +!$OMP THREADPRIVATE(buffer_i,size_buffer_i) + + REAL,POINTER,SAVE :: buffer_r(:) + INTEGER,SAVE :: size_buffer_r = 0 +!$OMP THREADPRIVATE(buffer_r,size_buffer_r) + + LOGICAL,POINTER,SAVE :: buffer_l(:) + INTEGER,SAVE :: size_buffer_l = 0 +!$OMP THREADPRIVATE(buffer_l,size_buffer_l) + + CHARACTER,POINTER,SAVE :: buffer_c(:) + INTEGER,SAVE :: size_buffer_c = 0 +!$OMP THREADPRIVATE(buffer_c,size_buffer_c) + +INTERFACE get_buffer + MODULE PROCEDURE get_buffer_i, get_buffer_r, get_buffer_l, get_buffer_c +END INTERFACE + +PUBLIC :: get_buffer + +CONTAINS + + SUBROUTINE get_buffer_i(buff,buff_size) + IMPLICIT NONE + INTEGER,POINTER :: buff(:) + INTEGER,INTENT(IN) :: buff_size + + IF (buff_size>size_buffer_i) THEN + DEALLOCATE(buffer_i) + size_buffer_i=MAX(2,INT(size_buffer_i*grow_factor)) + ALLOCATE(buffer_i(size_buffer_i)) + ENDIF + + buff=>buffer_i + END SUBROUTINE get_buffer_i + + SUBROUTINE get_buffer_r(buff,buff_size) + IMPLICIT NONE + REAL,POINTER :: buff(:) + INTEGER,INTENT(IN) :: buff_size + + IF (buff_size>size_buffer_r) THEN + DEALLOCATE(buffer_r) + size_buffer_r=MAX(2,INT(size_buffer_r*grow_factor)) + ALLOCATE(buffer_r(size_buffer_r)) + ENDIF + + buff=>buffer_r + END SUBROUTINE get_buffer_r + + SUBROUTINE get_buffer_l(buff,buff_size) + IMPLICIT NONE + LOGICAL,POINTER :: buff(:) + INTEGER,INTENT(IN) :: buff_size + + IF (buff_size>size_buffer_l) THEN + DEALLOCATE(buffer_l) + size_buffer_l=MAX(2,INT(size_buffer_l*grow_factor)) + ALLOCATE(buffer_l(size_buffer_l)) + ENDIF + + buff=>buffer_l + END SUBROUTINE get_buffer_l + + SUBROUTINE get_buffer_c(buff,buff_size) + IMPLICIT NONE + CHARACTER,POINTER :: buff(:) + INTEGER,INTENT(IN) :: buff_size + + IF (buff_size>size_buffer_c) THEN + DEALLOCATE(buffer_c) + size_buffer_c=MAX(2,INT(size_buffer_c*grow_factor)) + ALLOCATE(buffer_c(size_buffer_c)) + ENDIF + + buff=>buffer_c + END SUBROUTINE get_buffer_c + +END MODULE buffer_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calbeta.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calbeta.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calbeta.F90 (revision 1280) @@ -0,0 +1,103 @@ +! +! $Header$ +! +SUBROUTINE calbeta(dtime,indice,knon,snow,qsol, & + vbeta,vcal,vdif) + + USE dimphy + IMPLICIT none +!====================================================================== +! Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM au LMD) +! date: 19940414 +!====================================================================== +! +! Calculer quelques parametres pour appliquer la couche limite +! ------------------------------------------------------------ + INCLUDE "indicesol.h" + +! Variables d'entrees +!**************************************************************************************** + REAL, INTENT(IN) :: dtime + INTEGER, INTENT(IN) :: indice + INTEGER, INTENT(IN) :: knon + REAL, DIMENSION(klon), INTENT(IN) :: snow + REAL, DIMENSION(klon), INTENT(IN) :: qsol + + +! Variables de sorties +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: vbeta + REAL, DIMENSION(klon), INTENT(OUT) :: vcal + REAL, DIMENSION(klon), INTENT(OUT) :: vdif + +! Variables locales +!**************************************************************************************** + REAL, PARAMETER :: tau_gl=86400.0*5.0 ! temps de relaxation pour la glace de mer +!cc PARAMETER (tau_gl=86400.0*30.0) + REAL, PARAMETER :: mx_eau_sol=150.0 + REAL, PARAMETER :: calsol=1.0/(2.5578E+06*0.15) + REAL, PARAMETER :: calsno=1.0/(2.3867E+06*0.15) + REAL, PARAMETER :: calice=1.0/(5.1444E+06*0.15) + + INTEGER :: i + +!**************************************************************************************** + + vbeta(:) = 0.0 + vcal(:) = 0.0 + vdif(:) = 0.0 + + IF (indice.EQ.is_oce) THEN + DO i = 1, knon + vcal(i) = 0.0 + vbeta(i) = 1.0 + vdif(i) = 0.0 + ENDDO + ENDIF + + IF (indice.EQ.is_sic) THEN + DO i = 1, knon + vcal(i) = calice + IF (snow(i) .GT. 0.0) vcal(i) = calsno + vbeta(i) = 1.0 + vdif(i) = 1.0/tau_gl +! vdif(i) = calice/tau_gl ! c'etait une erreur + ENDDO + ENDIF + + IF (indice.EQ.is_ter) THEN + DO i = 1, knon + vcal(i) = calsol + IF (snow(i) .GT. 0.0) vcal(i) = calsno + vbeta(i) = MIN(2.0*qsol(i)/mx_eau_sol, 1.0) + vdif(i) = 0.0 + ENDDO + ENDIF + + IF (indice.EQ.is_lic) THEN + DO i = 1, knon + vcal(i) = calice + IF (snow(i) .GT. 0.0) vcal(i) = calsno + vbeta(i) = 1.0 + vdif(i) = 0.0 + ENDDO + ENDIF + +END SUBROUTINE calbeta + + + + + + + + + + + + + + + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcratqs.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcratqs.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcratqs.F (revision 1280) @@ -0,0 +1,166 @@ +! +! $Header$ +! + SUBROUTINE calcratqs ( flag_ratqs, + I paprs,pplay,q_seri,d_t_con,d_t_ajs + O ,ratqs,zpt_conv) + USE dimphy + IMPLICIT none +c====================================================================== +c +c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +c +c Objet: Moniteur general de la physique du modele +cAA Modifications quant aux traceurs : +cAA - uniformisation des parametrisations ds phytrac +cAA - stockage des moyennes des champs necessaires +cAA en mode traceur off-line +c====================================================================== +c modif ( P. Le Van , 12/10/98 ) +c +c Arguments: +c +c paprs---input-R-pression pour chaque inter-couche (en Pa) +c pplay---input-R-pression pour le mileu de chaque couche (en Pa) +c presnivs-input_R_pressions approximat. des milieux couches ( en PA) +cym#include "dimensions.h" +cym#include "dimphy.h" + REAL paprs(klon,klev+1) + REAL pplay(klon,klev) + REAL d_t_con(klon,klev) + REAL d_t_ajs(klon,klev) + REAL ratqs(klon,klev) + LOGICAL pt_conv(klon,klev) + REAL q_seri(klon,klev) + + logical firstcall + save firstcall + data firstcall/.true./ +c$OMP THREADPRIVATE(firstcall) + + REAL ratqsmin,ratqsmax,zx,epmax + REAL ratqs1,ratqs2,ratqs3,ratqs4 + REAL ratqsc1,ratqsc2,ratqsc3,ratqsc4 + INTEGER i,k + INTEGER flag_ratqs + save ratqsmin,ratqsmax,epmax + save ratqs1,ratqs2,ratqs3,ratqs4 + save ratqsc1,ratqsc2,ratqsc3,ratqsc4 +c$OMP THREADPRIVATE(ratqsmin,ratqsmax,epmax) +c$OMP THREADPRIVATE(ratqs1,ratqs2,ratqs3,ratqs4) +c$OMP THREADPRIVATE(ratqsc1,ratqsc2,ratqsc3,ratqsc4) + real zpt_conv(klon,klev) + + REAL zx_min + PARAMETER (zx_min=1.0) + REAL zx_max + PARAMETER (zx_max=0.1) + + zpt_conv=0. +c +c Appeler le processus de condensation a grande echelle +c et le processus de precipitation +c + if (flag_ratqs.eq.0) then + + ratqsmax=0.01 + ratqsmin=0.3 + + if (firstcall) print*,'RATQS ANCIEN ' + do k=1,klev + do i=1,klon + zx = pplay(i,k)/paprs(i,1) + zx = (zx_max-zx)/(zx_max-zx_min) + zx = MIN(MAX(zx,0.0),1.0) + zx = zx * zx * zx + ratqs(i,k)= zx * (ratqsmax-ratqsmin) + ratqsmin + enddo + enddo + + else + +c On aplique un ratqs "interactif" a toutes les mailles affectees +c par la convection ou se trouvant "sous" une maille affectee. + do i=1,klon + pt_conv(i,klev)=.false. + enddo + do k=klev-1,1,-1 + do i=1,klon + pt_conv(i,k)=pt_conv(i,k+1).or. + s (abs(d_t_con(i,k))+abs(d_t_ajs(i,k))).gt.1.e-8 + if(pt_conv(i,k)) then + zpt_conv(i,k)=1. + else + zpt_conv(i,k)=0. + endif + enddo + enddo + + if (flag_ratqs.eq.1) then + + ratqsmin=0.4 + ratqsmax=0.99 + if (firstcall) print*,'RATQS INTERACTIF ' + do k=1,klev + do i=1,klon + if (pt_conv(i,k)) then + ratqs(i,k)=0.01 + s +1.5*0.25*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k) + ratqs(i,k)=min(ratqs(i,k),ratqsmax) + ratqs(i,k)=max(ratqs(i,k),0.1) + else + ratqs(i,k)=0.01+(ratqsmin-0.01)* + s min((paprs(i,1)-pplay(i,k))/(paprs(i,1)-30000.),1.) + endif + enddo + enddo + else if (flag_ratqs.eq.2) then + do k=1,klev + do i=1,klon + ratqs(i,k)=0.001+ + s (q_seri(i,1)-q_seri(i,k))/q_seri(i,k) + if (pt_conv(i,k)) then + ratqs(i,k)=min(ratqs(i,k),ratqsmax) + else + ratqs(i,k)=min(ratqs(i,k),ratqsmin) + endif + enddo + enddo + else + do k=1,klev + do i=1,klon + if (pplay(i,k).ge.95000.) then + if (pt_conv(i,k)) then + ratqs(i,k)=ratqsc1 + else + ratqs(i,k)=ratqs1 + endif + else if (pplay(i,k).ge.75000.) then + if (pt_conv(i,k)) then + ratqs(i,k)=ratqsc2 + else + ratqs(i,k)=ratqs2 + endif + else if (pplay(i,k).ge.50000.) then + if (pt_conv(i,k)) then + ratqs(i,k)=ratqsc3 + else + ratqs(i,k)=ratqs3 + endif + else + if (pt_conv(i,k)) then + ratqs(i,k)=ratqsc4 + else + ratqs(i,k)=ratqs4 + endif + endif + enddo + enddo + endif + + endif + + firstcall=.false. + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcul_REGDYN.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcul_REGDYN.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcul_REGDYN.h (revision 1280) @@ -0,0 +1,22 @@ +c +c $Header$ +c +c calculs statistiques distribution nuage ftion du regime dynamique +c +c Ce calcul doit etre fait a partir de valeurs mensuelles ?? + CALL histo_o500_pctau(nbregdyn,pct_ocean,o500,fq_isccp, + &histoW,nhistoW) +c +c nhistoWt = somme de toutes les nhistoW + DO nreg=1, nbregdyn + DO k = 1, kmaxm1 + DO l = 1, lmaxm1 + DO iw = 1, iwmax + nhistoWt(k,l,iw,nreg)=nhistoWt(k,l,iw,nreg)+ + & nhistoW(k,l,iw,nreg) + ENDDO + ENDDO + ENDDO + ENDDO +c +cIM 190504 END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcul_STDlev.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcul_STDlev.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcul_STDlev.h (revision 1280) @@ -0,0 +1,333 @@ +c +c $Header$ +c +c +cIM on initialise les champs en debut du jour ou du mois +c + CALL ini_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth, + $ tnondef,tsumSTD) + CALL ini_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth, + $ tnondef,usumSTD) + CALL ini_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth, + $ tnondef,vsumSTD) + CALL ini_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth, + $ tnondef,wsumSTD) + CALL ini_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth, + $ tnondef,phisumSTD) + CALL ini_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth, + $ tnondef,qsumSTD) + CALL ini_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth, + $ tnondef,rhsumSTD) + CALL ini_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth, + $ tnondef,uvsumSTD) + CALL ini_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth, + $ tnondef,vqsumSTD) + CALL ini_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth, + $ tnondef,vTsumSTD) + CALL ini_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth, + $ tnondef,wqsumSTD) + CALL ini_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth, + $ tnondef,vphisumSTD) + CALL ini_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth, + $ tnondef,wTsumSTD) + CALL ini_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth, + $ tnondef,u2sumSTD) + CALL ini_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth, + $ tnondef,v2sumSTD) + CALL ini_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth, + $ tnondef,T2sumSTD) +c +cIM on interpole sur les niveaux STD de pression a chaque pas de temps de la physique +c +c-------------------------------------------------------c +c positionnement de l'argument logique a .false. c +c pour ne pas recalculer deux fois la meme chose ! c +c a cet effet un appel a plevel_new a ete deplace c +c a la fin de la serie d'appels c +c la boucle 'DO k=1, nlevSTD' a ete internalisee c +c dans plevel_new, d'ou la creation de cette routine... c +c-------------------------------------------------------c +c + CALL plevel_new(klon,klev,nlevSTD,.true.,pplay,rlevSTD, + & t_seri,tlevSTD) + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & u_seri,ulevSTD) + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & v_seri,vlevSTD) +c + +c + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zphi/RG,philevSTD) + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & qx(:,:,ivap),qlevSTD) + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_rh*100.,rhlevSTD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=u_seri(i,l)*v_seri(i,l) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,uvSTD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=v_seri(i,l)*q_seri(i,l) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,vqSTD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=v_seri(i,l)*t_seri(i,l) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,vTSTD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=omega(i,l)*qx(i,l,ivap) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,wqSTD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=v_seri(i,l)*zphi(i,l)/RG + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,vphiSTD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=omega(i,l)*t_seri(i,l) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,wTSTD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=u_seri(i,l)*u_seri(i,l) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,u2STD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=v_seri(i,l)*v_seri(i,l) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,v2STD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=t_seri(i,l)*t_seri(i,l) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,T2STD) + + + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=paprs(i,l) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.true.,zx_tmp_fi3d,rlevSTD, + & omega,wlevSTD) + +c +cIM on somme les valeurs definies a chaque pas de temps de la physique ou +cIM toutes les 6 heures +c + oknondef(1:klon,1:nlevSTD,1:nout)=.TRUE. + CALL undefSTD(nlevSTD,itap,tlevSTD, + $ dtime,ecrit_hf, + $ oknondef,tnondef,tsumSTD) +c + oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE. + CALL undefSTD(nlevSTD,itap,ulevSTD, + $ dtime,ecrit_hf, + $ oknondef,tnondef,usumSTD) +c + oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE. + CALL undefSTD(nlevSTD,itap,vlevSTD, + $ dtime,ecrit_hf, + $ oknondef,tnondef,vsumSTD) +c + oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE. + CALL undefSTD(nlevSTD,itap,wlevSTD, + $ dtime,ecrit_hf, + $ oknondef,tnondef,wsumSTD) +c + oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE. + CALL undefSTD(nlevSTD,itap,philevSTD, + $ dtime,ecrit_hf, + $ oknondef,tnondef,phisumSTD) +c + oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE. + CALL undefSTD(nlevSTD,itap,qlevSTD, + $ dtime,ecrit_hf, + $ oknondef,tnondef,qsumSTD) +c + oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE. + CALL undefSTD(nlevSTD,itap,rhlevSTD, + $ dtime,ecrit_hf, + $ oknondef,tnondef,rhsumSTD) +c + oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE. + CALL undefSTD(nlevSTD,itap,uvSTD, + $ dtime,ecrit_hf, + $ oknondef,tnondef,uvsumSTD) +c + oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE. + CALL undefSTD(nlevSTD,itap,vqSTD, + $ dtime,ecrit_hf, + $ oknondef,tnondef,vqsumSTD) +c + oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE. + CALL undefSTD(nlevSTD,itap,vTSTD, + $ dtime,ecrit_hf, + $ oknondef,tnondef,vTsumSTD) +c + oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE. + CALL undefSTD(nlevSTD,itap,wqSTD, + $ dtime,ecrit_hf, + $ oknondef,tnondef,wqsumSTD) +c + oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE. + CALL undefSTD(nlevSTD,itap,vphiSTD, + $ dtime,ecrit_hf, + $ oknondef,tnondef,vphisumSTD) +c + oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE. + CALL undefSTD(nlevSTD,itap,wTSTD, + $ dtime,ecrit_hf, + $ oknondef,tnondef,wTsumSTD) +c + oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE. + CALL undefSTD(nlevSTD,itap,u2STD, + $ dtime,ecrit_hf, + $ oknondef,tnondef,u2sumSTD) +c + oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE. + CALL undefSTD(nlevSTD,itap,v2STD, + $ dtime,ecrit_hf, + $ oknondef,tnondef,v2sumSTD) +c + oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE. + CALL undefSTD(nlevSTD,itap,T2STD, + $ dtime,ecrit_hf, + $ oknondef,tnondef,T2sumSTD) +c +cIM on moyenne a la fin du jour ou du mois +c + CALL moy_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth,ecrit_hf2mth, + $ tnondef,tsumSTD) +c + CALL moy_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth,ecrit_hf2mth, + $ tnondef,usumSTD) +c + CALL moy_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth,ecrit_hf2mth, + $ tnondef,vsumSTD) +c + CALL moy_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth,ecrit_hf2mth, + $ tnondef,wsumSTD) +c + CALL moy_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth,ecrit_hf2mth, + $ tnondef,phisumSTD) +c + CALL moy_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth,ecrit_hf2mth, + $ tnondef,qsumSTD) +c + CALL moy_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth,ecrit_hf2mth, + $ tnondef,rhsumSTD) +c + CALL moy_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth,ecrit_hf2mth, + $ tnondef,uvsumSTD) +c + CALL moy_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth,ecrit_hf2mth, + $ tnondef,vqsumSTD) +c + CALL moy_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth,ecrit_hf2mth, + $ tnondef,vTsumSTD) +c + CALL moy_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth,ecrit_hf2mth, + $ tnondef,wqsumSTD) +c + CALL moy_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth,ecrit_hf2mth, + $ tnondef,vphisumSTD) +c + CALL moy_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth,ecrit_hf2mth, + $ tnondef,wTsumSTD) +c + CALL moy_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth,ecrit_hf2mth, + $ tnondef,u2sumSTD) +c + CALL moy_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth,ecrit_hf2mth, + $ tnondef,v2sumSTD) +c + CALL moy_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth,ecrit_hf2mth, + $ tnondef,T2sumSTD) +c +cIM interpolation a chaque pas de temps du SWup(clr) et SWdn(clr) a 200 hPa +c + CALL plevel(klon,klevp1,.true.,paprs,20000., + $ swdn0,SWdn200clr) + CALL plevel(klon,klevp1,.false.,paprs,20000., + $ swdn,SWdn200) + CALL plevel(klon,klevp1,.false.,paprs,20000., + $ swup0,SWup200clr) + CALL plevel(klon,klevp1,.false.,paprs,20000., + $ swup,SWup200) +c + CALL plevel(klon,klevp1,.false.,paprs,20000., + $ lwdn0,LWdn200clr) + CALL plevel(klon,klevp1,.false.,paprs,20000., + $ lwdn,LWdn200) + CALL plevel(klon,klevp1,.false.,paprs,20000., + $ lwup0,LWup200clr) + CALL plevel(klon,klevp1,.false.,paprs,20000., + $ lwup,LWup200) +c Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcul_divers.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcul_divers.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcul_divers.h (revision 1280) @@ -0,0 +1,29 @@ +c +c $Header$ +c +c +c initialisations diverses au "debut" du mois +c + IF(MOD(itap,INT(ecrit_mth)).EQ.1) THEN + DO i=1, klon + nday_rain(i)=0. + ENDDO !i +c +c surface terre + DO i=1, klon + IF(pctsrf(i,is_ter).GT.0.) THEN + paire_ter(i)=airephy(i)*pctsrf(i,is_ter) + ENDIF + ENDDO +c + ENDIF !MOD(itap,INT(ecrit_mth)).EQ.1 +c + IF(MOD(itap,INT(ecrit_day)).EQ.0) THEN +c +cIM calcul total_rain, nday_rain +c + DO i = 1, klon + total_rain(i)=rain_fall(i)+snow_fall(i) + IF(total_rain(i).GT.0.) nday_rain(i)=nday_rain(i)+1. + ENDDO + ENDIF !itap.EQ.ecrit_mth Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcul_fluxs_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcul_fluxs_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcul_fluxs_mod.F90 (revision 1280) @@ -0,0 +1,289 @@ +! +MODULE calcul_fluxs_mod + + +CONTAINS + SUBROUTINE calcul_fluxs( knon, nisurf, dtime, & + tsurf, p1lay, cal, beta, coef1lay, ps, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, & + petAcoef, peqAcoef, petBcoef, peqBcoef, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + + USE dimphy, ONLY : klon + +! Cette routine calcule les fluxs en h et q a l'interface et eventuellement +! une temperature de surface (au cas ou ok_veget = false) +! +! L. Fairhead 4/2000 +! +! input: +! knon nombre de points a traiter +! nisurf surface a traiter +! tsurf temperature de surface +! p1lay pression 1er niveau (milieu de couche) +! cal capacite calorifique du sol +! beta evap reelle +! coef1lay coefficient d'echange +! ps pression au sol +! precip_rain precipitations liquides +! precip_snow precipitations solides +! snow champs hauteur de neige +! runoff runoff en cas de trop plein +! petAcoef coeff. A de la resolution de la CL pour t +! peqAcoef coeff. A de la resolution de la CL pour q +! petBcoef coeff. B de la resolution de la CL pour t +! peqBcoef coeff. B de la resolution de la CL pour q +! radsol rayonnement net aus sol (LW + SW) +! dif_grnd coeff. diffusion vers le sol profond +! +! output: +! tsurf_new temperature au sol +! qsurf humidite de l'air au dessus du sol +! fluxsens flux de chaleur sensible +! fluxlat flux de chaleur latente +! dflux_s derivee du flux de chaleur sensible / Ts +! dflux_l derivee du flux de chaleur latente / Ts +! + + INCLUDE "YOETHF.h" + INCLUDE "FCTTRE.h" + INCLUDE "indicesol.h" + INCLUDE "YOMCST.h" + +! Parametres d'entree +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon, nisurf + REAL , INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: petAcoef, peqAcoef + REAL, DIMENSION(klon), INTENT(IN) :: petBcoef, peqBcoef + REAL, DIMENSION(klon), INTENT(IN) :: ps, q1lay + REAL, DIMENSION(klon), INTENT(IN) :: tsurf, p1lay, cal, beta, coef1lay + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow ! pas utiles + REAL, DIMENSION(klon), INTENT(IN) :: radsol, dif_grnd + REAL, DIMENSION(klon), INTENT(IN) :: t1lay, u1lay, v1lay + +! Parametres entree-sorties +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow ! snow pas utile + +! Parametres sorties +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new, evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + +! Variables locales +!**************************************************************************************** + INTEGER :: i + REAL, DIMENSION(klon) :: zx_mh, zx_nh, zx_oh + REAL, DIMENSION(klon) :: zx_mq, zx_nq, zx_oq + REAL, DIMENSION(klon) :: zx_pkh, zx_dq_s_dt, zx_qsat, zx_coef + REAL, DIMENSION(klon) :: zx_sl, zx_k1 + REAL, DIMENSION(klon) :: d_ts + REAL :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh + REAL :: qsat_new, q1_new + REAL, PARAMETER :: t_grnd = 271.35, t_coup = 273.15 + REAL, PARAMETER :: max_eau_sol = 150.0 + CHARACTER (len = 20) :: modname = 'calcul_fluxs' + LOGICAL :: fonte_neige + LOGICAL, SAVE :: check = .FALSE. + !$OMP THREADPRIVATE(check) + +! End definition +!**************************************************************************************** + + IF (check) WRITE(*,*)'Entree ', modname,' surface = ',nisurf + + IF (check) THEN + WRITE(*,*)' radsol (min, max)', & + MINVAL(radsol(1:knon)), MAXVAL(radsol(1:knon)) + ENDIF + +! Traitement neige et humidite du sol +!**************************************************************************************** +! +!!$ WRITE(*,*)'test calcul_flux, surface ', nisurf +!!PB test +!!$ if (nisurf == is_oce) then +!!$ snow = 0. +!!$ qsol = max_eau_sol +!!$ else +!!$ where (precip_snow > 0.) snow = snow + (precip_snow * dtime) +!!$ where (snow > epsilon(snow)) snow = max(0.0, snow - (evap * dtime)) +!!$! snow = max(0.0, snow + (precip_snow - evap) * dtime) +!!$ where (precip_rain > 0.) qsol = qsol + (precip_rain - evap) * dtime +!!$ endif +!!$ IF (nisurf /= is_ter) qsol = max_eau_sol + + +! +! Initialisation +!**************************************************************************************** + evap = 0. + fluxsens=0. + fluxlat=0. + dflux_s = 0. + dflux_l = 0. +! +! zx_qs = qsat en kg/kg +!**************************************************************************************** + DO i = 1, knon + zx_pkh(i) = (ps(i)/ps(i))**RKAPPA + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,rtt-tsurf(i))) + zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta + zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q1lay(i)) + zx_qs= r2es * FOEEW(tsurf(i),zdelta)/ps(i) + zx_qs=MIN(0.5,zx_qs) + zcor=1./(1.-retv*zx_qs) + zx_qs=zx_qs*zcor + zx_dq_s_dh = FOEDE(tsurf(i),zdelta,zcvm5,zx_qs,zcor) & + /RLVTT / zx_pkh(i) + ELSE + IF (tsurf(i).LT.t_coup) THEN + zx_qs = qsats(tsurf(i)) / ps(i) + zx_dq_s_dh = dqsats(tsurf(i),zx_qs)/RLVTT & + / zx_pkh(i) + ELSE + zx_qs = qsatl(tsurf(i)) / ps(i) + zx_dq_s_dh = dqsatl(tsurf(i),zx_qs)/RLVTT & + / zx_pkh(i) + ENDIF + ENDIF + zx_dq_s_dt(i) = RCPD * zx_pkh(i) * zx_dq_s_dh + zx_qsat(i) = zx_qs + zx_coef(i) = coef1lay(i) * & + (1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) * & + p1lay(i)/(RD*t1lay(i)) + + ENDDO + + +! === Calcul de la temperature de surface === +! zx_sl = chaleur latente d'evaporation ou de sublimation +!**************************************************************************************** + + DO i = 1, knon + zx_sl(i) = RLVTT + IF (tsurf(i) .LT. RTT) zx_sl(i) = RLSTT + zx_k1(i) = zx_coef(i) + ENDDO + + + DO i = 1, knon +! Q + zx_oq(i) = 1. - (beta(i) * zx_k1(i) * peqBcoef(i) * dtime) + zx_mq(i) = beta(i) * zx_k1(i) * & + (peqAcoef(i) - zx_qsat(i) + & + zx_dq_s_dt(i) * tsurf(i)) & + / zx_oq(i) + zx_nq(i) = beta(i) * zx_k1(i) * (-1. * zx_dq_s_dt(i)) & + / zx_oq(i) + +! H + zx_oh(i) = 1. - (zx_k1(i) * petBcoef(i) * dtime) + zx_mh(i) = zx_k1(i) * petAcoef(i) / zx_oh(i) + zx_nh(i) = - (zx_k1(i) * RCPD * zx_pkh(i))/ zx_oh(i) + +! Tsurface + tsurf_new(i) = (tsurf(i) + cal(i)/(RCPD * zx_pkh(i)) * dtime * & + (radsol(i) + zx_mh(i) + zx_sl(i) * zx_mq(i)) & + + dif_grnd(i) * t_grnd * dtime)/ & + ( 1. - dtime * cal(i)/(RCPD * zx_pkh(i)) * ( & + zx_nh(i) + zx_sl(i) * zx_nq(i)) & + + dtime * dif_grnd(i)) + +! +! Y'a-t-il fonte de neige? +! +! fonte_neige = (nisurf /= is_oce) .AND. & +! & (snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) & +! & .AND. (tsurf_new(i) >= RTT) +! if (fonte_neige) tsurf_new(i) = RTT + d_ts(i) = tsurf_new(i) - tsurf(i) +! zx_h_ts(i) = tsurf_new(i) * RCPD * zx_pkh(i) +! zx_q_0(i) = zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i) + +!== flux_q est le flux de vapeur d'eau: kg/(m**2 s) positive vers bas +!== flux_t est le flux de cpt (energie sensible): j/(m**2 s) + evap(i) = - zx_mq(i) - zx_nq(i) * tsurf_new(i) + fluxlat(i) = - evap(i) * zx_sl(i) + fluxsens(i) = zx_mh(i) + zx_nh(i) * tsurf_new(i) + +! Derives des flux dF/dTs (W m-2 K-1): + dflux_s(i) = zx_nh(i) + dflux_l(i) = (zx_sl(i) * zx_nq(i)) + +! Nouvelle valeure de l'humidite au dessus du sol + qsat_new=zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i) + q1_new = peqAcoef(i) - peqBcoef(i)*evap(i)*dtime + qsurf(i)=q1_new*(1.-beta(i)) + beta(i)*qsat_new +! +! en cas de fonte de neige +! +! if (fonte_neige) then +! bilan_f = radsol(i) + fluxsens(i) - (zx_sl(i) * evap (i)) - & +! & dif_grnd(i) * (tsurf_new(i) - t_grnd) - & +! & RCPD * (zx_pkh(i))/cal(i)/dtime * (tsurf_new(i) - tsurf(i)) +! bilan_f = max(0., bilan_f) +! fq_fonte = bilan_f / zx_sl(i) +! snow(i) = max(0., snow(i) - fq_fonte * dtime) +! qsol(i) = qsol(i) + (fq_fonte * dtime) +! endif +!!$ if (nisurf == is_ter) & +!!$ & run_off(i) = run_off(i) + max(qsol(i) - max_eau_sol, 0.0) +!!$ qsol(i) = min(qsol(i), max_eau_sol) + ENDDO +! +!**************************************************************************************** +! + END SUBROUTINE calcul_fluxs +! +!**************************************************************************************** +! + SUBROUTINE calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, cdrag_m, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, t1lay, & + flux_u1, flux_v1) + + USE dimphy + INCLUDE "YOMCST.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: u0, v0 ! u and v at niveau 0 + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 ! u and v at niveau 1 + REAL, DIMENSION(klon), INTENT(IN) :: cdrag_m ! cdrag pour momentum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: p1lay ! pression 1er niveau (milieu de couche) + REAL, DIMENSION(klon), INTENT(IN) :: t1lay ! temperature +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1 + REAL, DIMENSION(klon), INTENT(OUT) :: flux_v1 + +! Local variables +!**************************************************************************************** + INTEGER :: i + REAL :: mod_wind, buf + +!**************************************************************************************** +! Calculate the surface flux +! +!**************************************************************************************** + DO i=1,knon + mod_wind = 1.0 + SQRT((u1(i) - u0(i))**2 + (v1(i)-v0(i))**2) + buf = cdrag_m(i) * mod_wind * p1lay(i)/(RD*t1lay(i)) + flux_u1(i) = (AcoefU(i) - u0(i)) / (1/buf - BcoefU(i)*dtime ) + flux_v1(i) = (AcoefV(i) - v0(i)) / (1/buf - BcoefV(i)*dtime ) + END DO + + END SUBROUTINE calcul_flux_wind +! +!**************************************************************************************** +! +END MODULE calcul_fluxs_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcul_simulISCCP.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcul_simulISCCP.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calcul_simulISCCP.h (revision 1280) @@ -0,0 +1,146 @@ +c +c $Header$ +c +c on appelle le simulateur ISCCP toutes les 3h +c et on fait des sorties 1 fois par jour +c +c ATTENTION : le temps de calcul peut augmenter considerablement ! +c =============================================================== c + DO n=1, napisccp +c + nbapp_isccp=30 !appel toutes les 15h +cIM 170107 isccppas=NINT((itap*dtime)/3600.) !Nb. d'heures de la physique + freqin_pdt(n)=ifreq_isccp(n) +c +cIM initialisation nbsunlit pour calculs simulateur ISCCP pdt la journee +c + DO i=1, klon + sunlit(i)=1 + IF(rmu0(i).EQ.0.) sunlit(i)=0 + nbsunlit(1,i,n)=FLOAT(sunlit(i)) + ENDDO +c +cIM calcul tau, emissivite nuages convectifs +c + convfra(:,:)=rnebcon(:,:) + convliq(:,:)=rnebcon(:,:)*clwcon(:,:) +c + CALL newmicro (paprs, pplay,ok_newmicro, + . t_seri, convliq, convfra, dtau_c, dem_c, + . cldh_c, cldl_c, cldm_c, cldt_c, cldq_c, + . flwp_c, fiwp_c, flwc_c, fiwc_c, + e ok_aie, + e mass_solu_aero, mass_solu_aero_pi, + e bl95_b0, bl95_b1, + s cldtaupi, re, fl) +c +cIM calcul tau, emissivite nuages startiformes +c + CALL newmicro (paprs, pplay,ok_newmicro, + . t_seri, cldliq, cldfra, dtau_s, dem_s, + . cldh_s, cldl_s, cldm_s, cldt_s, cldq_s, + . flwp_s, fiwp_s, flwc_s, fiwc_s, + e ok_aie, + e mass_solu_aero, mass_solu_aero_pi, + e bl95_b0, bl95_b1, + s cldtaupi, re, fl) +c + cldtot(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.) +c +cIM inversion des niveaux de pression ==> de haut en bas +c + CALL haut2bas(klon, klev, pplay, pfull) + CALL haut2bas(klon, klev, q_seri, qv) + CALL haut2bas(klon, klev, cldtot, cc) + CALL haut2bas(klon, klev, rnebcon, conv) + CALL haut2bas(klon, klev, dtau_s, dtau_sH2B) + CALL haut2bas(klon, klev, dtau_c, dtau_cH2B) + CALL haut2bas(klon, klev, t_seri, at) + CALL haut2bas(klon, klev, dem_s, dem_sH2B) + CALL haut2bas(klon, klev, dem_c, dem_cH2B) + CALL haut2bas(klon, klevp1, paprs, phalf) +c +cIM: initialisation de seed +c + DO i=1, klon +c + aa=ABS(paprs(i,2)-NINT(paprs(i,2))) + seed_re(i,n)=1000.*aa+1. + seed(i,n)=NINT(seed_re(i,n)) +c + IF(seed(i,n).LT.50) THEN +c print*,'seed<50 avant i seed itap paprs',i, +c . seed(i,n),itap,paprs(i,2) + seed(i,n)=50+seed(i,n)+i+itap + seed_old(i,n)=seed(i,n) +c + IF(itap.GT.1) then + IF(seed(i,n).EQ.seed_old(i,n)) THEN + seed(i,n)=seed(i,n)+10 + seed_old(i,n)=seed(i,n) + ENDIF + ENDIF +c +c print*,'seed<50 apres i seed itap paprs',i, +c . seed(i,n),itap,paprs(i,2) +c + ELSE IF(seed(i,n).EQ.0) THEN + print*,'seed=0 i paprs aa seed_re', + . i,paprs(i,2),aa,seed_re(i,n) + STOP + ELSE IF(seed(i,n).LT.0) THEN + print*,'seed < 0, i seed itap paprs',i, + . seed(i,n),itap,paprs(i,2) + STOP + ENDIF +c + ENDDO +c +cIM: pas de debug, debugcol + debug=0 + debugcol=0 +c +cIM o500 ==> distribution nuage ftion du regime dynamique (vit. verticale a 500 hPa) +c + DO k=1, klevm1 + kp1=k+1 +c PRINT*,'k, presnivs',k,presnivs(k), presnivs(kp1) + if(presnivs(k).GT.50000.AND.presnivs(kp1).LT.50000.) THEN + DO i=1, klon + o500(i)=omega(i,k)*RDAY/100. +c if(i.EQ.1) print*,' 500hPa lev',k,presnivs(k),presnivs(kp1) + ENDDO + GOTO 1000 + endif +1000 continue + ENDDO +c +cIM recalcule les nuages vus par satellite, via le simulateur ISCCP +c + CALL ISCCP_CLOUD_TYPES( + & debug, + & debugcol, + & klon, + & sunlit, + & klev, + & ncol(n), + & seed(:,n), + & pfull, + & phalf, + & qv, cc, conv, dtau_sH2B, dtau_cH2B, + & top_height, + & overlap, + & tautab, + & invtau, + & ztsol, + & emsfc_lw, + & at, dem_sH2B, dem_cH2B, + & fq_isccp(:,:,:,n), + & totalcldarea(:,n), + & meanptop(:,n), + & meantaucld(:,n), + & boxtau(:,:,n), + & boxptop(:,:,n)) +c + ENDDO !n=1, napisccp + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calltherm.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calltherm.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calltherm.F90 (revision 1280) @@ -0,0 +1,349 @@ +! +! $Header$ +! + subroutine calltherm(dtime & + & ,pplay,paprs,pphi,weak_inversion & + & ,u_seri,v_seri,t_seri,q_seri,zqsat,debut & + & ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs & + & ,fm_therm,entr_therm,detr_therm,zqasc,clwcon0,lmax,ratqscth, & + & ratqsdiff,zqsatth,Ale_bl,Alp_bl,lalim_conv,wght_th, & + & zmax0,f0,zw2,fraca) + + USE dimphy + implicit none +#include "dimensions.h" +!#include "dimphy.h" +#include "thermcell.h" +#include "iniprint.h" + +!IM 140508 + INTEGER itap + REAL dtime + LOGICAL debut + LOGICAL logexpr0, logexpr2(klon,klev), logexpr1(klon) + REAL fact(klon) + INTEGER nbptspb + + REAL u_seri(klon,klev),v_seri(klon,klev) + REAL t_seri(klon,klev),q_seri(klon,klev),qmemoire(klon,klev) + REAL weak_inversion(klon) + REAL paprs(klon,klev+1) + REAL pplay(klon,klev) + REAL pphi(klon,klev) + real zlev(klon,klev+1) +!test: on sort lentr et a* pour alimenter KE + REAL wght_th(klon,klev) + INTEGER lalim_conv(klon) + REAL zw2(klon,klev+1),fraca(klon,klev+1) + +!FH Update Thermiques + REAL d_t_ajs(klon,klev), d_q_ajs(klon,klev) + REAL d_u_ajs(klon,klev),d_v_ajs(klon,klev) + real fm_therm(klon,klev+1) + real entr_therm(klon,klev),detr_therm(klon,klev) + +!******************************************************** +! declarations + real fmc_therm(klon,klev+1),zqasc(klon,klev) + real zqla(klon,klev) + real zqta(klon,klev) + real wmax_sec(klon) + real zmax_sec(klon) + real f_sec(klon) + real detrc_therm(klon,klev) +! FH WARNING : il semble que ces save ne servent a rien +! save fmc_therm, detrc_therm + real clwcon0(klon,klev) + real zqsat(klon,klev) + real zw_sec(klon,klev+1) + integer lmix_sec(klon) + integer lmax(klon) + real ratqscth(klon,klev) + real ratqsdiff(klon,klev) + real zqsatth(klon,klev) +!nouvelles variables pour la convection + real Ale_bl(klon) + real Alp_bl(klon) + real Ale(klon) + real Alp(klon) +!RC + !on garde le zmax du pas de temps precedent + real zmax0(klon), f0(klon) +!******************************************************** + + +! variables locales + REAL d_t_the(klon,klev), d_q_the(klon,klev) + REAL d_u_the(klon,klev),d_v_the(klon,klev) +! + real zfm_therm(klon,klev+1),zdt + real zentr_therm(klon,klev),zdetr_therm(klon,klev) +! FH A VERIFIER : SAVE INUTILES +! save zentr_therm,zfm_therm + + integer i,k + logical, save :: first=.true. +!$OMP THREADPRIVATE(first) +!******************************************************** + if (first) then + itap=0 + first=.false. + endif + +! Incrementer le compteur de la physique + itap = itap + 1 + +! Modele du thermique +! =================== +! print*,'thermiques: WARNING on passe t au lieu de t_seri' + + +! On prend comme valeur initiale des thermiques la valeur du pas +! de temps precedent + zfm_therm(:,:)=fm_therm(:,:) + zdetr_therm(:,:)=detr_therm(:,:) + zentr_therm(:,:)=entr_therm(:,:) + +! On reinitialise les flux de masse a zero pour le cumul en +! cas de splitting + fm_therm(:,:)=0. + entr_therm(:,:)=0. + detr_therm(:,:)=0. + + Ale_bl(:)=0. + Alp_bl(:)=0. + if (prt_level.ge.10) then + print*,'thermV4 nsplit: ',nsplit_thermals,' weak_inversion' + endif + +! tests sur les valeurs negatives de l'eau + logexpr0=prt_level.ge.10 + nbptspb=0 + do k=1,klev + do i=1,klon +! Attention teste abderr 19-03-09 +! logexpr2(i,k)=.not.q_seri(i,k).ge.0. + logexpr2(i,k)=.not.q_seri(i,k).ge.1.e-15 + if (logexpr2(i,k)) then + q_seri(i,k)=1.e-15 + nbptspb=nbptspb+1 + endif +! if (logexpr0) & +! & print*,'WARN eau<0 avant therm i=',i,' k=',k & +! & ,' dq,q',d_q_the(i,k),q_seri(i,k) + enddo + enddo + if(nbptspb.GT.0) print*,'Number of points with q_seri(i,k)<=0 ',nbptspb + + zdt=dtime/float(nsplit_thermals) + do isplit=1,nsplit_thermals + + if (iflag_thermals.eq.1) then + CALL thermcell_2002(klon,klev,zdt & + & ,pplay,paprs,pphi & + & ,u_seri,v_seri,t_seri,q_seri & + & ,d_u_the,d_v_the,d_t_the,d_q_the & + & ,zfm_therm,zentr_therm & + & ,r_aspect_thermals,30.,w2di_thermals & + & ,tau_thermals,3) + else if (iflag_thermals.eq.2) then + CALL thermcell_sec(klon,klev,zdt & + & ,pplay,paprs,pphi,zlev & + & ,u_seri,v_seri,t_seri,q_seri & + & ,d_u_the,d_v_the,d_t_the,d_q_the & + & ,zfm_therm,zentr_therm & + & ,r_aspect_thermals,30.,w2di_thermals & + & ,tau_thermals,3) + else if (iflag_thermals.eq.3) then + CALL thermcell(klon,klev,zdt & + & ,pplay,paprs,pphi & + & ,u_seri,v_seri,t_seri,q_seri & + & ,d_u_the,d_v_the,d_t_the,d_q_the & + & ,zfm_therm,zentr_therm & + & ,r_aspect_thermals,l_mix_thermals,w2di_thermals & + & ,tau_thermals,3) + else if (iflag_thermals.eq.10) then + CALL thermcell_eau(klon,klev,zdt & + & ,pplay,paprs,pphi & + & ,u_seri,v_seri,t_seri,q_seri & + & ,d_u_the,d_v_the,d_t_the,d_q_the & + & ,zfm_therm,zentr_therm & + & ,r_aspect_thermals,l_mix_thermals,w2di_thermals & + & ,tau_thermals,3) + else if (iflag_thermals.eq.11) then + stop 'cas non prevu dans calltherm' +! CALL thermcell_pluie(klon,klev,zdt & +! & ,pplay,paprs,pphi,zlev & +! & ,u_seri,v_seri,t_seri,q_seri & +! & ,d_u_the,d_v_the,d_t_the,d_q_the & +! & ,zfm_therm,zentr_therm,zqla & +! & ,r_aspect_thermals,l_mix_thermals,w2di_thermals & +! & ,tau_thermals,3) + else if (iflag_thermals.eq.12) then + CALL calcul_sec(klon,klev,zdt & + & ,pplay,paprs,pphi,zlev & + & ,u_seri,v_seri,t_seri,q_seri & + & ,zmax_sec,wmax_sec,zw_sec,lmix_sec & + & ,r_aspect_thermals,l_mix_thermals,w2di_thermals & + & ,tau_thermals) + else if (iflag_thermals.ge.13) then + CALL thermcell_main(itap,klon,klev,zdt & + & ,pplay,paprs,pphi,debut & + & ,u_seri,v_seri,t_seri,q_seri & + & ,d_u_the,d_v_the,d_t_the,d_q_the & + & ,zfm_therm,zentr_therm,zdetr_therm,zqasc,zqla,lmax & + & ,ratqscth,ratqsdiff,zqsatth & + & ,r_aspect_thermals,l_mix_thermals & + & ,tau_thermals,Ale,Alp,lalim_conv,wght_th & + & ,zmax0,f0,zw2,fraca) + endif + + + fact(:)=0. + DO i=1,klon + logexpr1(i)=iflag_thermals.lt.14.or.weak_inversion(i).gt.0.5 + IF(logexpr1(i)) fact(i)=1./float(nsplit_thermals) + ENDDO + + DO k=1,klev +! transformation de la derivee en tendance + d_t_the(:,k)=d_t_the(:,k)*dtime*fact(:) + d_u_the(:,k)=d_u_the(:,k)*dtime*fact(:) + d_v_the(:,k)=d_v_the(:,k)*dtime*fact(:) + d_q_the(:,k)=d_q_the(:,k)*dtime*fact(:) + fm_therm(:,k)=fm_therm(:,k) & + & +zfm_therm(:,k)*fact(:) + entr_therm(:,k)=entr_therm(:,k) & + & +zentr_therm(:,k)*fact(:) + detr_therm(:,k)=detr_therm(:,k) & + & +zdetr_therm(:,k)*fact(:) + ENDDO + fm_therm(:,klev+1)=0. + + + +! accumulation de la tendance + d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_the(:,:) + d_u_ajs(:,:)=d_u_ajs(:,:)+d_u_the(:,:) + d_v_ajs(:,:)=d_v_ajs(:,:)+d_v_the(:,:) + d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_the(:,:) + +! incrementation des variables meteo + t_seri(:,:) = t_seri(:,:) + d_t_the(:,:) + u_seri(:,:) = u_seri(:,:) + d_u_the(:,:) + v_seri(:,:) = v_seri(:,:) + d_v_the(:,:) + qmemoire(:,:)=q_seri(:,:) + q_seri(:,:) = q_seri(:,:) + d_q_the(:,:) + + DO i=1,klon + if(prt_level.GE.10) print*,'calltherm i Alp_bl Alp Ale_bl Ale',i,Alp_bl(i),Alp(i),Ale_bl(i),Ale(i) + fm_therm(i,klev+1)=0. + Ale_bl(i)=Ale_bl(i)+Ale(i)/float(nsplit_thermals) +! write(22,*)'ALE CALLTHERM',Ale_bl(i),Ale(i) + Alp_bl(i)=Alp_bl(i)+Alp(i)/float(nsplit_thermals) +! write(23,*)'ALP CALLTHERM',Alp_bl(i),Alp(i) + ENDDO + +!IM 060508 marche pas comme cela !!! enddo ! isplit + +! tests sur les valeurs negatives de l'eau + nbptspb=0 + DO k = 1, klev + DO i = 1, klon + logexpr2(i,k)=.not.q_seri(i,k).ge.0. + if (logexpr2(i,k)) then + q_seri(i,k)=1.e-15 + nbptspb=nbptspb+1 +! if (prt_level.ge.10) then +! print*,'WARN eau<0 apres therm i=',i,' k=',k & +! & ,' dq,q',d_q_the(i,k),q_seri(i,k), & +! & 'fm=',zfm_therm(i,k),'entr=',entr_therm(i,k) + endif +! stop + ENDDO + ENDDO + IF(nbptspb.GT.0) print*,'Number of points with q_seri(i,k)<=0 ',nbptspb +! tests sur les valeurs de la temperature + nbptspb=0 + DO k = 1, klev + DO i = 1, klon + logexpr2(i,k)=t_seri(i,k).lt.50..or.t_seri(i,k).gt.370. + if (logexpr2(i,k)) nbptspb=nbptspb+1 +! if ((t_seri(i,k).lt.50.) .or. & +! & (t_seri(i,k).gt.370.)) then +! print*,'WARN temp apres therm i=',i,' k=',k & +! & ,' t_seri',t_seri(i,k) +! CALL abort +! endif + ENDDO + ENDDO + IF(nbptspb.GT.0) print*,'Number of points with q_seri(i,k)<=0 ',nbptspb + enddo ! isplit + +! +!*************************************************************** +! calcul du flux ascencant conservatif +! print*,'<<< calwake, wake_s ', wake_s(1) + + RDCP=1./3.5 + + +c----------------------------------------------------------- +cIM 290108 DO 999 i=1,klon ! a vectoriser +c---------------------------------------------------------- + + + DO l=1,klev + DO i=1,klon + p(i,l)= pplay(i,l) + ph(i,l)= paprs(i,l) + pi(i,l) = (pplay(i,l)/100000.)**RDCP + + te(i,l) = t(i,l) + qe(i,l) = q(i,l) + omgbe(i,l) = omgb(i,l) + + dtdwn(i,l)= dt_dwn(i,l) + dqdwn(i,l)= dq_dwn(i,l) + dta(i,l)= dt_a(i,l) + dqa(i,l)= dq_a(i,l) + wdtPBL(i,l)= wdt_PBL(i,l) + wdqPBL(i,l)= wdq_PBL(i,l) + udtPBL(i,l)= udt_PBL(i,l) + udqPBL(i,l)= udq_PBL(i,l) + ENDDO + ENDDO + + omgbe(:,klev+1) = 0. + + DO i=1,klon + sigd0(i)=sigd(i) + ENDDO +c print*, 'sigd0,sigd', sigd0, sigd(i) + DO i=1,klon + ph(i,klev+1)=0. + ENDDO + + DO i=1,klon + ktopw(i) = wake_k(i) + ENDDO + + DO l=1,klev + DO i=1,klon + dtw(i,l) = wake_deltat(i,l) + dqw(i,l) = wake_deltaq(i,l) + ENDDO + ENDDO + + DO l=1,klev + DO i=1,klon + dtls(i,l)=dt_wake(i,l) + dqls(i,l)=dq_wake(i,l) + ENDDO + ENDDO + + DO i=1,klon + hw(i) = wake_h(i) + sigmaw(i)= wake_s(i) + ENDDO + +cfkc les flux de masses sont evalues aux niveaux et valent 0 a la surface +cfkc on veut le flux de masse au milieu des couches + + DO l=1,klev-1 + DO i=1,klon + amdwn(i,l)= 0.5*(M_dwn(i,l)+M_dwn(i,l+1)) + amdwn(i,l)= (M_dwn(i,l+1)) + ENDDO + ENDDO + +c au sommet le flux de masse est nul + + DO i=1,klon + amdwn(i,klev)=0.5*M_dwn(i,klev) + ENDDO +c + DO l = 1,klev + DO i=1,klon + amup(i,l)=M_up(i,l) + ENDDO + ENDDO + + call WAKE(p,ph,pi,dtime,sigd0 + $ ,te,qe,omgbe + $ ,dtdwn,dqdwn,amdwn,amup,dta,dqa + $ ,wdtPBL,wdqPBL,udtPBL,udqPBL + $ ,dtw,dqw,dth,hw,sigmaw,wape,fip,gfl + $ ,dtls,dqls,ktopw + $ ,omgbdth,dp_omgb,wdens + $ ,tu,qu + $ ,dtKE,dqKE + $ ,dtPBL,dqPBL + $ ,omg,dp_deltomg,spread + $ ,Cstar,d_deltat_gw + $ ,d_deltatw,d_deltaqw) + + DO i=1,klon + IF (ktopw(i) .GT. 0) THEN + DO l=1,klev + wake_deltat(i,l)= dtw(i,l) + wake_deltaq(i,l)= dqw(i,l) + wake_d_deltat_gw(i,l)= d_deltat_gw(i,l) + wake_omgbdth(i,l) = omgbdth(i,l) + wake_dp_omgb(i,l) = dp_omgb(i,l) + wake_dtKE(i,l) = dtKE(i,l) + wake_dqKE(i,l) = dqKE(i,l) + wake_dtPBL(i,l) = dtPBL(i,l) + wake_dqPBL(i,l) = dqPBL(i,l) + wake_omg(i,l) = omg(i,l) + wake_dp_deltomg(i,l) = dp_deltomg(i,l) + wake_spread(i,l) = spread(i,l) + wake_dth(i,l) = dth(i,l) + dt_wake(i,l) = dtls(i,l) + dq_wake(i,l) = dqls(i,l) + undi_t(i,l) = tu(i,l) + undi_q(i,l) = qu(i,l) + wake_ddeltat(i,l) = d_deltatw(i,l) + wake_ddeltaq(i,l) = d_deltaqw(i,l) + ENDDO + ELSE + DO l = 1,klev + wake_deltat(i,l)= 0. + wake_deltaq(i,l)= 0. + wake_d_deltat_gw(i,l)= 0. + wake_omgbdth(i,l) = 0. + wake_dp_omgb(i,l) = 0. + wake_dtKE(i,l) = 0. + wake_dqKE(i,l) = 0. + wake_omg(i,l) = 0. + wake_dp_deltomg(i,l) = 0. + wake_spread(i,l) = 0. + wake_dth(i,l)=0. + dt_wake(i,l)=0. + dq_wake(i,l)=0. + undi_t(i,l)=te(i,l) + undi_q(i,l)=qe(i,l) + ENDDO + ENDIF + + wake_h(i)= hw(i) + wake_s(i)= sigmaw(i) + wake_pe(i)= wape(i) + wake_fip(i)= fip(i) + wake_gfl(i) = gfl(i) + wake_k(i) =ktopw(i) + wake_Cstar(i) = Cstar(i) + wake_dens(i) = wdens(i) +c +cIM 290108 999 CONTINUE +c + ENDDO + RETURN + END + SUBROUTINE CALWAKE_scal(paprs,pplay,dtime + : ,t,q,omgb + : ,dt_dwn,dq_dwn,M_dwn,M_up + : ,dt_a,dq_a,sigd + : ,wdt_PBL,wdq_PBL + : ,udt_PBL,udq_PBL + o ,wake_deltat,wake_deltaq,wake_dth + o ,wake_h,wake_s,wake_dens + o ,wake_pe,wake_fip,wake_gfl + o ,dt_wake,dq_wake + o ,wake_k + o ,undi_t,undi_q + o ,wake_omgbdth,wake_dp_omgb + o ,wake_dtKE,wake_dqKE + o ,wake_dtPBL,wake_dqPBL + o ,wake_omg,wake_dp_deltomg + o ,wake_spread,wake_Cstar,wake_d_deltat_gw + o ,wake_ddeltat,wake_ddeltaq) +*************************************************************** +* * +* CALWAKE * +* interface avec le schema de calcul de la poche * +* froide * +* * +* written by : CHERUY Frederique, 13/03/2000, 10.31.05 * +* modified by : ROEHRIG Romain, 01/30/2007 * +*************************************************************** +* + USE dimphy + IMPLICIT none +c====================================================================== + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" + +c Arguments +c---------- + + INTEGER i,l,ktopw + REAL dtime + + REAL paprs(klon,klev+1),pplay(klon,klev) + REAL t(klon,klev), q(klon,klev), omgb(klon,klev) + REAL dt_dwn(klon,klev), dq_dwn(klon,klev),M_dwn(klon,klev) + REAL M_up(klon,klev) + REAL dt_a(klon,klev), dq_a(klon,klev) + REAL wdt_PBL(klon,klev), wdq_PBL(klon,klev) + REAL udt_PBL(klon,klev), udq_PBL(klon,klev) + REAL wake_deltat(klon,klev),wake_deltaq(klon,klev) + REAL dt_wake(klon,klev),dq_wake(klon,klev) + REAL wake_d_deltat_gw(klon,klev) + REAL wake_h(klon),wake_s(klon) + REAL wake_dth(klon,klev) + REAL wake_pe(klon),wake_fip(klon),wake_gfl(klon) + REAL undi_t(klon,klev),undi_q(klon,klev) + REAL wake_omgbdth(klon,klev),wake_dp_omgb(klon,klev) + REAL wake_dtKE(klon,klev),wake_dqKE(klon,klev) + REAL wake_dtPBL(klon,klev),wake_dqPBL(klon,klev) + REAL wake_omg(klon,klev+1),wake_dp_deltomg(klon,klev) + REAL wake_spread(klon,klev),wake_Cstar(klon) + REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev) + REAL d_deltatw(klev), d_deltaqw(klev) + INTEGER wake_k(klon) + REAL sigd(klon) + REAL wake_dens(klon) + +C Variable internes +C ----------------- + + REAL aire + REAL p(klev),ph(klev+1),pi(klev) + REAL te(klev),qe(klev),omgbe(klev),dtdwn(klev),dqdwn(klev) + REAL dta(klev),dqa(klev) + REAL wdtPBL(klev),wdqPBL(klev) + REAL udtPBL(klev),udqPBL(klev) + REAL amdwn(klev),amup(klev) + REAL dtw(klev),dqw(klev),dth(klev),d_deltat_gw(klev) + REAL dtls(klev),dqls(klev) + REAL tu(klev),qu(klev) + REAL hw,sigmaw,wape,fip,gfl + REAL omgbdth(klev),dp_omgb(klev) + REAL dtKE(klev),dqKE(klev) + REAL dtPBL(klev),dqPBL(klev) + REAL omg(klev+1),dp_deltomg(klev),spread(klev),Cstar + REAL sigd0,wdens + + REAL RDCP + +c print *, '-> calwake, wake_s ', wake_s(1) + + RDCP=1./3.5 + +c----------------------------------------------------------- + DO 999 i=1,klon ! a vectoriser +c---------------------------------------------------------- + + + DO l=1,klev + p(l)= pplay(i,l) + ph(l)= paprs(i,l) + pi(l) = (pplay(i,l)/100000.)**RDCP + + te(l) = t(i,l) + qe(l) = q(i,l) + omgbe(l) = omgb(i,l) + + dtdwn(l)= dt_dwn(i,l) + dqdwn(l)= dq_dwn(i,l) + dta(l)= dt_a(i,l) + dqa(l)= dq_a(i,l) + wdtPBL(l)= wdt_PBL(i,l) + wdqPBL(l)= wdq_PBL(i,l) + udtPBL(l)= udt_PBL(i,l) + udqPBL(l)= udq_PBL(i,l) + ENDDO + + sigd0=sigd(i) +c print*, 'sigd0,sigd', sigd0, sigd(i) + ph(klev+1)=0. + + ktopw = wake_k(i) + + DO l=1,klev + dtw(l) = wake_deltat(i,l) + dqw(l) = wake_deltaq(i,l) + ENDDO + + DO l=1,klev + dtls(l)=dt_wake(i,l) + dqls(l)=dq_wake(i,l) + ENDDO + + hw = wake_h(i) + sigmaw = wake_s(i) + +cfkc les flux de masses sont evalues aux niveaux et valent 0 a la surface +cfkc on veut le flux de masse au milieu des couches + + DO l=1,klev-1 + amdwn(l)= 0.5*(M_dwn(i,l)+M_dwn(i,l+1)) + amdwn(l)= (M_dwn(i,l+1)) + ENDDO + +c au sommet le flux de masse est nul + + amdwn(klev)=0.5*M_dwn(i,klev) +c + DO l = 1,klev + amup(l)=M_up(i,l) + ENDDO + + call WAKE_scal(p,ph,pi,dtime,sigd0 + $ ,te,qe,omgbe + $ ,dtdwn,dqdwn,amdwn,amup,dta,dqa + $ ,wdtPBL,wdqPBL,udtPBL,udqPBL + $ ,dtw,dqw,dth,hw,sigmaw,wape,fip,gfl + $ ,dtls,dqls,ktopw + $ ,omgbdth,dp_omgb,wdens + $ ,tu,qu + $ ,dtKE,dqKE + $ ,dtPBL,dqPBL + $ ,omg,dp_deltomg,spread + $ ,Cstar,d_deltat_gw + $ ,d_deltatw,d_deltaqw) + + IF (ktopw .GT. 0) THEN + DO l=1,klev + wake_deltat(i,l)= dtw(l) + wake_deltaq(i,l)= dqw(l) + wake_d_deltat_gw(i,l)= d_deltat_gw(l) + wake_omgbdth(i,l) = omgbdth(l) + wake_dp_omgb(i,l) = dp_omgb(l) + wake_dtKE(i,l) = dtKE(l) + wake_dqKE(i,l) = dqKE(l) + wake_dtPBL(i,l) = dtPBL(l) + wake_dqPBL(i,l) = dqPBL(l) + wake_omg(i,l) = omg(l) + wake_dp_deltomg(i,l) = dp_deltomg(l) + wake_spread(i,l) = spread(l) + wake_dth(i,l) = dth(l) + dt_wake(i,l) = dtls(l) + dq_wake(i,l) = dqls(l) + undi_t(i,l) = tu(l) + undi_q(i,l) = qu(l) + wake_ddeltat(i,l) = d_deltatw(l) + wake_ddeltaq(i,l) = d_deltaqw(l) + ENDDO + ELSE + DO l = 1,klev + wake_deltat(i,l)= 0. + wake_deltaq(i,l)= 0. + wake_d_deltat_gw(i,l)= 0. + wake_omgbdth(i,l) = 0. + wake_dp_omgb(i,l) = 0. + wake_dtKE(i,l) = 0. + wake_dqKE(i,l) = 0. + wake_omg(i,l) = 0. + wake_dp_deltomg(i,l) = 0. + wake_spread(i,l) = 0. + wake_dth(i,l)=0. + dt_wake(i,l)=0. + dq_wake(i,l)=0. + undi_t(i,l)=te(l) + undi_q(i,l)=qe(l) + ENDDO + ENDIF + + wake_h(i)= hw + wake_s(i)= sigmaw + wake_pe(i)= wape + wake_fip(i)= fip + wake_gfl(i) = gfl + wake_k(i) =ktopw + wake_Cstar(i) = Cstar + wake_dens(i) = wdens +c + 999 CONTINUE +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/carbon_cycle_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/carbon_cycle_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/carbon_cycle_mod.F90 (revision 1280) @@ -0,0 +1,401 @@ +MODULE carbon_cycle_mod + +! Author : Josefine GHATTAS, Patricia CADULE + + IMPLICIT NONE + SAVE + PRIVATE + PUBLIC :: carbon_cycle_init, carbon_cycle + +! Variables read from parmeter file physiq.def + LOGICAL, PUBLIC :: carbon_cycle_tr ! 3D transport of CO2 in the atmosphere, parameter read in conf_phys +!$OMP THREADPRIVATE(carbon_cycle_tr) + LOGICAL, PUBLIC :: carbon_cycle_cpl ! Coupling of CO2 fluxes between LMDZ/ORCHIDEE and LMDZ/OCEAN(PISCES) +!$OMP THREADPRIVATE(carbon_cycle_cpl) + LOGICAL :: carbon_cycle_emis_comp=.FALSE. ! Calculation of emission compatible + +! Scalare values when no transport, from physiq.def + REAL :: fos_fuel_s ! carbon_cycle_fos_fuel dans physiq.def +!$OMP THREADPRIVATE(fos_fuel_s) + REAL :: emis_land_s ! not yet implemented +!$OMP THREADPRIVATE(emis_land_s) + + INTEGER :: ntr_co2 ! Number of tracers concerning the carbon cycle + INTEGER :: id_fco2_tot ! Tracer index + INTEGER :: id_fco2_ocn ! - " - + INTEGER :: id_fco2_land ! - " - + INTEGER :: id_fco2_land_use ! - " - + INTEGER :: id_fco2_fos_fuel ! - " - +!$OMP THREADPRIVATE(ntr_co2, id_fco2_tot, id_fco2_ocn, id_fco2_land, id_fco2_land_use, id_fco2_fos_fuel) + + REAL, DIMENSION(:), ALLOCATABLE :: fos_fuel ! CO2 fossil fuel emission from file [gC/m2/d] +!$OMP THREADPRIVATE(fos_fuel) + REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_ocn_day ! flux CO2 from ocean for 1 day (cumulated) [gC/m2/d] +!$OMP THREADPRIVATE(fco2_ocn_day) + REAL, DIMENSION(:), ALLOCATABLE :: fco2_land_day ! flux CO2 from land for 1 day (cumulated) [gC/m2/d] +!$OMP THREADPRIVATE(fco2_land_day) + REAL, DIMENSION(:), ALLOCATABLE :: fco2_lu_day ! Emission from land use change for 1 day (cumulated) [gC/m2/d] +!$OMP THREADPRIVATE(fco2_lu_day) + +! Following 2 fields will be initialized in surf_land_orchidee at each time step + REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_inst ! flux CO2 from land at one time step +!$OMP THREADPRIVATE(fco2_land_inst) + REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_lu_inst ! Emission from land use change at one time step +!$OMP THREADPRIVATE(fco2_lu_inst) + +! Calculated co2 field to be send to the ocean via the coupler and to ORCHIDEE + REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: co2_send +!$OMP THREADPRIVATE(co2_send) + +CONTAINS + + SUBROUTINE carbon_cycle_init(tr_seri, aerosol, radio) + USE dimphy + USE infotrac + USE IOIPSL + USE surface_data, ONLY : ok_veget, type_ocean + + IMPLICIT NONE + INCLUDE "clesphys.h" + INCLUDE "iniprint.h" + +! Input argument + REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr_seri ! Concentration Traceur [U/KgA] + +! InOutput arguments + LOGICAL,DIMENSION(nbtr), INTENT(INOUT) :: aerosol + LOGICAL,DIMENSION(nbtr), INTENT(INOUT) :: radio + +! Local variables + INTEGER :: ierr, it, iiq + REAL, DIMENSION(klon) :: tr_seri_sum + + +! 0) Test for compatibility + IF (carbon_cycle_cpl .AND. type_ocean/='couple') & + CALL abort_gcm('carbon_cycle_init', 'Coupling with ocean model is needed for carbon_cycle_cpl',1) + IF (carbon_cycle_cpl .AND..NOT. ok_veget) & + CALL abort_gcm('carbon_cycle_init', 'Coupling with surface land model ORCHDIEE is needed for carbon_cycle_cpl',1) + + +! 1) Check if transport of one tracer flux CO2 or 4 separated tracers + IF (carbon_cycle_tr) THEN + id_fco2_tot=0 + id_fco2_ocn=0 + id_fco2_land=0 + id_fco2_land_use=0 + id_fco2_fos_fuel=0 + + ! Search in tracer list + DO it=1,nbtr + iiq=niadv(it+2) + IF (tname(iiq) == "fCO2" ) THEN + id_fco2_tot=it + ELSE IF (tname(iiq) == "fCO2_ocn" ) THEN + id_fco2_ocn=it + ELSE IF (tname(iiq) == "fCO2_land" ) THEN + id_fco2_land=it + ELSE IF (tname(iiq) == "fCO2_land_use" ) THEN + id_fco2_land_use=it + ELSE IF (tname(iiq) == "fCO2_fos_fuel" ) THEN + id_fco2_fos_fuel=it + END IF + END DO + + ! Count tracers found + IF (id_fco2_tot /= 0 .AND. & + id_fco2_ocn==0 .AND. id_fco2_land==0 .AND. id_fco2_land_use==0 .AND. id_fco2_fos_fuel==0) THEN + + ! transport 1 tracer flux CO2 + ntr_co2 = 1 + + ELSE IF (id_fco2_tot==0 .AND. & + id_fco2_ocn /=0 .AND. id_fco2_land/=0 .AND. id_fco2_land_use/=0 .AND. id_fco2_fos_fuel/=0) THEN + + ! transport 4 tracers seperatively + ntr_co2 = 4 + + ELSE + CALL abort_gcm('carbon_cycle_init', 'error in coherence between traceur.def and gcm.def',1) + END IF + + ! Definition of control varaiables for the tracers + DO it=1,nbtr + IF (it==id_fco2_tot .OR. it==id_fco2_ocn .OR. it==id_fco2_land .OR. & + it==id_fco2_land_use .OR. it==id_fco2_fos_fuel) THEN + aerosol(it) = .FALSE. + radio(it) = .FALSE. + END IF + END DO + + ELSE + ! No transport of CO2 + ntr_co2 = 0 + END IF ! carbon_cycle_tr + + +! 2) Allocate variable for CO2 fossil fuel emission + IF (carbon_cycle_tr) THEN + ! Allocate 2D variable + ALLOCATE(fos_fuel(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('carbon_cycle_init', 'pb in allocation 1',1) + ELSE + ! No transport : read value from .def + fos_fuel_s = 0. + CALL getin ('carbon_cycle_fos_fuel',fos_fuel_s) + WRITE(lunout,*) 'carbon_cycle_fos_fuel = ', fos_fuel_s + END IF + + +! 3) Allocate and initialize fluxes + IF (carbon_cycle_cpl) THEN + IF (ierr /= 0) CALL abort_gcm('carbon_cycle_init', 'pb in allocation 2',1) + ALLOCATE(fco2_land_day(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('carbon_cycle_init', 'pb in allocation 3',1) + ALLOCATE(fco2_lu_day(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('carbon_cycle_init', 'pb in allocation 4',1) + + fco2_land_day(:) = 0. ! JG : Doit prend valeur de restart + fco2_lu_day(:) = 0. ! JG : Doit prend valeur de restart + + ! fco2_ocn_day is allocated in cpl_mod + ! fco2_land_inst and fco2_lu_inst are allocated in surf_land_orchidee + + ALLOCATE(co2_send(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('carbon_cycle_init', 'pb in allocation 7',1) + + ! Calculate using restart tracer values + IF (carbon_cycle_tr) THEN + IF (ntr_co2==1) THEN + co2_send(:) = tr_seri(:,1,id_fco2_tot) + co2_ppm0 + ELSE ! ntr_co2==4 + ! Calculate the delta CO2 flux + tr_seri_sum(:) = tr_seri(:,1,id_fco2_fos_fuel) + tr_seri(:,1,id_fco2_land_use) + & + tr_seri(:,1,id_fco2_land) + tr_seri(:,1,id_fco2_ocn) + co2_send(:) = tr_seri_sum(:) + co2_ppm0 + END IF + ELSE + ! Send a scalare value in 2D variable to ocean and land model (PISCES and ORCHIDEE) + co2_send(:) = co2_ppm + END IF + + + ELSE + IF (carbon_cycle_tr) THEN + ! No coupling of CO2 fields : + ! corresponding fields will instead be read from files + ALLOCATE(fco2_ocn_day(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('carbon_cycle_init', 'pb in allocation 8',1) + ALLOCATE(fco2_land_day(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('carbon_cycle_init', 'pb in allocation 9',1) + ALLOCATE(fco2_lu_day(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('carbon_cycle_init', 'pb in allocation 10',1) + END IF + END IF + +! 4) Read parmeter for calculation of emission compatible + IF (.NOT. carbon_cycle_tr) THEN + carbon_cycle_emis_comp=.FALSE. + CALL getin('carbon_cycle_emis_comp',carbon_cycle_emis_comp) + WRITE(lunout,*) 'carbon_cycle_emis_comp = ',carbon_cycle_emis_comp + END IF + + END SUBROUTINE carbon_cycle_init + +! +! +! + + SUBROUTINE carbon_cycle(nstep, pdtphys, pctsrf, tr_seri) + + USE infotrac + USE dimphy + USE mod_phys_lmdz_transfert_para, ONLY : reduce_sum + USE phys_cal_mod, ONLY : mth_cur, mth_len + USE phys_cal_mod, ONLY : day_cur + USE comgeomphy + + IMPLICIT NONE + + INCLUDE "clesphys.h" + INCLUDE "indicesol.h" + +! In/Output arguments + INTEGER,INTENT(IN) :: nstep ! time step in physiq + REAL,INTENT(IN) :: pdtphys ! length of time step in physiq (sec) + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Pourcentage de sol f(nature du sol) + REAL, DIMENSION(klon,klev,nbtr), INTENT(INOUT) :: tr_seri + +! Local variables + LOGICAL :: newmonth ! indicates if a new month just started + LOGICAL :: newday ! indicates if a new day just started + LOGICAL :: endday ! indicated if last time step in a day + + REAL, PARAMETER :: fact=1.E-15/2.12 ! transformation factor from gC/m2/day => ppm/m2/day + REAL, DIMENSION(klon) :: fco2_tmp, tr_seri_sum + REAL :: sumtmp + REAL :: airetot ! Total area the earth + REAL :: delta_co2_ppm + +! -) Calculate logicals indicating if it is a new month, new day or the last time step in a day (end day) + + newday = .FALSE.; endday = .FALSE.; newmonth = .FALSE. + + IF (MOD(nstep,INT(86400./pdtphys))==1) newday=.TRUE. + IF (MOD(nstep,INT(86400./pdtphys))==0) endday=.TRUE. + IF (newday .AND. day_cur==1) newmonth=.TRUE. + +! -) Read new maps if new month started + IF (newmonth .AND. carbon_cycle_tr) THEN + CALL read_map2D('fossil_fuel.nc','fos_fuel', mth_cur, .FALSE., fos_fuel) + + ! division by month lenght to get dayly value + fos_fuel(:) = fos_fuel(:)/mth_len + + IF (.NOT. carbon_cycle_cpl) THEN + ! Get dayly values from monthly fluxes + CALL read_map2D('fl_co2_ocean.nc','CO2_OCN',mth_cur,.FALSE.,fco2_ocn_day) + CALL read_map2D('fl_co2_land.nc','CO2_LAND', mth_cur,.FALSE.,fco2_land_day) + CALL read_map2D('fl_co2_land_use.nc','CO2_LAND_USE',mth_cur,.FALSE.,fco2_lu_day) + END IF + END IF + + + +! -) Update tracers at beginning of a new day. Beginning of a new day correspond to a new coupling period in cpl_mod. + IF (newday) THEN + + IF (carbon_cycle_tr) THEN + + ! Update tracers + IF (ntr_co2 == 1) THEN + ! Calculate the new flux CO2 + tr_seri(:,1,id_fco2_tot) = tr_seri(:,1,id_fco2_tot) + & + (fos_fuel(:) + & + fco2_lu_day(:) * pctsrf(:,is_ter) + & + fco2_land_day(:)* pctsrf(:,is_ter) + & + fco2_ocn_day(:) * pctsrf(:,is_oce)) * fact + + ELSE ! ntr_co2 == 4 + tr_seri(:,1,id_fco2_fos_fuel) = tr_seri(:,1,id_fco2_fos_fuel) + fos_fuel(:) * fact ! [ppm/m2/day] + + tr_seri(:,1,id_fco2_land_use) = tr_seri(:,1,id_fco2_land_use) + & + fco2_lu_day(:) *pctsrf(:,is_ter)*fact ! [ppm/m2/day] + + tr_seri(:,1,id_fco2_land) = tr_seri(:,1,id_fco2_land) + & + fco2_land_day(:)*pctsrf(:,is_ter)*fact ! [ppm/m2/day] + + tr_seri(:,1,id_fco2_ocn) = tr_seri(:,1,id_fco2_ocn) + & + fco2_ocn_day(:) *pctsrf(:,is_oce)*fact ! [ppm/m2/day] + + END IF + + ELSE ! no transport + IF (carbon_cycle_cpl) THEN + IF (carbon_cycle_emis_comp) THEN + ! Calcul emission compatible a partir des champs 2D et co2_ppm + !!! TO DO!! + CALL abort_gcm('carbon_cycle', ' Option carbon_cycle_emis_comp not yet implemented',1) + END IF + END IF + + END IF ! carbon_cycle_tr + + ! Reset cumluative variables + IF (carbon_cycle_cpl) THEN + fco2_land_day(:) = 0. + fco2_lu_day(:) = 0. + END IF + + END IF ! newday + + + +! -) Cumulate fluxes from ORCHIDEE at each timestep + IF (carbon_cycle_cpl) THEN + fco2_land_day(:) = fco2_land_day(:) + fco2_land_inst(:) + fco2_lu_day(:) = fco2_lu_day(:) + fco2_lu_inst(:) + END IF + + + +! -) At the end of a new day, calculate a mean scalare value of CO2 to be used by +! the radiation scheme (instead of reading value from .def) + +! JG : Ici on utilise uniquement le traceur du premier couche du modele. Est-ce que c'est correcte ? + IF (endday) THEN + ! Calculte total area of the earth surface + CALL reduce_sum(SUM(airephy),airetot) + + + IF (carbon_cycle_tr) THEN + IF (ntr_co2 == 1) THEN + + ! Calculate mean value of tracer CO2 to get an scalare value to be used in the + ! radiation scheme (instead of reading value from .def) + ! Mean value weighted with the grid cell area + + ! Calculate mean value + fco2_tmp(:) = tr_seri(:,1,id_fco2_tot) * airephy(:) + CALL reduce_sum(SUM(fco2_tmp),sumtmp) + co2_ppm = sumtmp/airetot + co2_ppm0 + + ELSE ! ntr_co2 == 4 + + ! Calculate the delta CO2 flux + tr_seri_sum(:) = tr_seri(:,1,id_fco2_fos_fuel) + tr_seri(:,1,id_fco2_land_use) + & + tr_seri(:,1,id_fco2_land) + tr_seri(:,1,id_fco2_ocn) + + ! Calculate mean value of delta CO2 flux + fco2_tmp(:) = tr_seri_sum(:) * airephy(:) + CALL reduce_sum(SUM(fco2_tmp),sumtmp) + delta_co2_ppm = sumtmp/airetot + + ! Add initial value for co2_ppm to delta value + co2_ppm = delta_co2_ppm + co2_ppm0 + END IF + + ELSE IF (carbon_cycle_cpl) THEN ! no carbon_cycle_tr + + ! Calculate the total CO2 flux and integrate to get scalare value for the radiation scheme + fco2_tmp(:) = (fos_fuel(:) + (fco2_lu_day(:) + fco2_land_day(:))*pctsrf(:,is_ter) & + + fco2_ocn_day(:)*pctsrf(:,is_oce)) * fact + + ! Calculate mean value + fco2_tmp(:) = fco2_tmp(:) * airephy(:) + CALL reduce_sum(SUM(fco2_tmp),sumtmp) + delta_co2_ppm = sumtmp/airetot + + ! Update current value of the atmospheric co2_ppm + co2_ppm = co2_ppm + delta_co2_ppm + + END IF ! carbon_cycle_tr + + ! transformation of the atmospheric CO2 concentration for the radiation code + RCO2 = co2_ppm * 1.0e-06 * 44.011/28.97 + + END IF + + ! Calculate CO2 flux to send to ocean and land models : PISCES and ORCHIDEE + IF (endday .AND. carbon_cycle_cpl) THEN + + IF (carbon_cycle_tr) THEN + IF (ntr_co2==1) THEN + + co2_send(:) = tr_seri(:,1,id_fco2_tot) + co2_ppm0 + + ELSE ! ntr_co2 == 4 + + co2_send(:) = tr_seri_sum(:) + co2_ppm0 + + END IF + ELSE + ! Send a scalare value in 2D variable to ocean and land model (PISCES and ORCHIDEE) + co2_send(:) = co2_ppm + END IF + + END IF + + END SUBROUTINE carbon_cycle + +END MODULE carbon_cycle_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/change_srf_frac_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/change_srf_frac_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/change_srf_frac_mod.F90 (revision 1280) @@ -0,0 +1,157 @@ +! +! $Header$ +! +MODULE change_srf_frac_mod + + IMPLICIT NONE + +CONTAINS +! +! Change Surface Fractions +! + SUBROUTINE change_srf_frac(itime, dtime, jour, & + pctsrf, alb1, alb2, tsurf, u10m, v10m, pbl_tke) +! +! This subroutine is called from physiq.F at each timestep. +! 1- For each type of ocean (force, slab, couple) receive new fractions only if +! it's time to modify (is_modified=true). Otherwise nothing is done (is_modified=false). +! If received new fraction : +! 2- Tests and ajustements are done on the fractions +! 3- Initialize variables where a new fraction(new or melted ice) has appered, +! + + USE dimphy + USE surface_data, ONLY : type_ocean + USE limit_read_mod + USE pbl_surface_mod, ONLY : pbl_surface_newfrac + USE cpl_mod, ONLY : cpl_receive_frac + USE ocean_slab_mod, ONLY : ocean_slab_frac + + INCLUDE "iniprint.h" + INCLUDE "indicesol.h" + INCLUDE "YOMCST.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime ! current time step + INTEGER, INTENT(IN) :: jour ! day of the year + REAL, INTENT(IN) :: dtime ! length of time step (s) + +! In-Output arguments +!**************************************************************************************** + + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf ! sub-surface fraction + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: alb1 ! albedo first interval in SW spektrum + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: alb2 ! albedo second interval in SW spektrum + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: tsurf + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: u10m + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: v10m + REAL, DIMENSION(klon,klev+1,nbsrf), INTENT(INOUT) :: pbl_tke + +! Loccal variables +!**************************************************************************************** + INTEGER :: i, nsrf + LOGICAL :: is_modified ! true if pctsrf is modified at this time step + LOGICAL :: test_sum=.FALSE. + LOGICAL, DIMENSION(klon,nbsrf) :: new_surf + REAL, DIMENSION(klon,nbsrf) :: pctsrf_old ! fraction from previous time-step + REAL :: tmpsum + + pctsrf_old(:,:) = pctsrf(:,:) +!**************************************************************************************** +! 1) +! For each type of ocean (force, slab, couple) receive new fractions only if it's time +! to modify (is_modified=true). Otherwise nothing is done (is_modified=false). +!**************************************************************************************** + SELECT CASE (type_ocean) + CASE ('force') + ! Read fraction from limit.nc + CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified) + CASE ('slab') + ! Get fraction from slab module + CALL ocean_slab_frac(itime, dtime, jour, pctsrf, is_modified) + CASE ('couple') + ! Get fraction from the coupler + CALL cpl_receive_frac(itime, dtime, pctsrf, is_modified) + END SELECT + + IF (is_modified) THEN +!**************************************************************************************** +! 2) +! Tests and ajustements on the new fractions : +! - Put to zero fractions that are too small +! - Test total fraction sum is one for each grid point +! +!**************************************************************************************** + +! Test and exit if a fraction is negative + IF (MINVAL(pctsrf(:,:)) < 0.) THEN + WRITE(lunout,*)'Warning! One or several fractions are negative, itime=',itime + WRITE(lunout,*)'at point = ',MINLOC(pctsrf(:,:)) + WRITE(lunout,*)'value = ',MINVAL(pctsrf(:,:)) + CALL abort_gcm('change_srf_frac','Negative fraction',1) + END IF + +! Optional test on the incoming fraction + IF (test_sum) THEN + DO i= 1, klon + tmpsum = SUM(pctsrf(i,:)) + IF (ABS(1. - tmpsum) > 0.05) CALL abort_gcm('change_srf_frac','Total fraction not equal 1.',1) + END DO + END IF + +! Test for too small fractions of the sum land+landice and ocean+sea-ice + WHERE ((pctsrf(:,is_ter) + pctsrf(:,is_lic)) < 2*EPSFRA) + pctsrf(:,is_ter) = 0. + pctsrf(:,is_lic) = 0. + END WHERE + + WHERE ((pctsrf(:,is_oce) + pctsrf(:,is_sic)) < 2*EPSFRA) + pctsrf(:,is_oce) = 0. + pctsrf(:,is_sic) = 0. + END WHERE + +! Normalize to force total fraction to be equal one + DO i= 1, klon + tmpsum = SUM(pctsrf(i,:)) + DO nsrf = 1, nbsrf + pctsrf(i,nsrf) = pctsrf(i,nsrf) / tmpsum + END DO + END DO + +! Test for too small fractions at each sub-surface + WHERE (pctsrf(:,is_ter) < EPSFRA) + pctsrf(:,is_lic) = pctsrf(:,is_ter) + pctsrf(:,is_lic) + pctsrf(:,is_ter) = 0. + END WHERE + + WHERE (pctsrf(:,is_lic) < EPSFRA) + pctsrf(:,is_ter) = pctsrf(:,is_ter) + pctsrf(:,is_lic) + pctsrf(:,is_lic) = 0. + END WHERE + + WHERE (pctsrf(:,is_oce) < EPSFRA) + pctsrf(:,is_sic) = pctsrf(:,is_oce) + pctsrf(:,is_sic) + pctsrf(:,is_oce) = 0. + END WHERE + + WHERE (pctsrf(:,is_sic) < EPSFRA) + pctsrf(:,is_oce) = pctsrf(:,is_oce) + pctsrf(:,is_sic) + pctsrf(:,is_sic) = 0. + END WHERE + +!**************************************************************************************** +! 3) +! Initialize variables where a new fraction has appered, +! i.e. where new sea ice has been formed +! or where ice free ocean has appread in a grid cell +! +!**************************************************************************************** + CALL pbl_surface_newfrac(itime, pctsrf, pctsrf_old, tsurf, alb1, alb2, u10m, v10m, pbl_tke) + + END IF ! is_modified + + END SUBROUTINE change_srf_frac + + +END MODULE change_srf_frac_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/chem.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/chem.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/chem.h (revision 1280) @@ -0,0 +1,14 @@ +! +! $Header$ +! + INTEGER idms, iso2, iso4, ih2s, idmso, imsa, ih2o2 + PARAMETER (idms=1, iso2=2, iso4=3) + PARAMETER (ih2s=4, idmso=5, imsa=6, ih2o2=7) + + REAL n_avogadro, masse_s, masse_so4, rho_water, rho_ice + PARAMETER (n_avogadro=6.02E23) !--molec mol-1 + PARAMETER (masse_s=32.0) !--g mol-1 + PARAMETER (masse_so4=96.0) !--g mol-1 + PARAMETER (rho_water=1000.0) !--kg m-3 + PARAMETER (rho_ice=500.0) !--kg m-3 + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/clcdrag.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/clcdrag.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/clcdrag.F90 (revision 1280) @@ -0,0 +1,135 @@ +! +!$Id$ +! +SUBROUTINE clcdrag(knon, nsrf, paprs, pplay,& + u1, v1, t1, q1, & + tsurf, qsurf, rugos, & + pcfm, pcfh) + + USE dimphy + IMPLICIT NONE +! ================================================================= c +! +! Objet : calcul des cdrags pour le moment (pcfm) et +! les flux de chaleur sensible et latente (pcfh). +! +! ================================================================= c +! +! knon----input-I- nombre de points pour un type de surface +! nsrf----input-I- indice pour le type de surface; voir indicesol.h +! u1-------input-R- vent zonal au 1er niveau du modele +! v1-------input-R- vent meridien au 1er niveau du modele +! t1-------input-R- temperature de l'air au 1er niveau du modele +! q1-------input-R- humidite de l'air au 1er niveau du modele +! tsurf------input-R- temperature de l'air a la surface +! qsurf---input-R- humidite de l'air a la surface +! rugos---input-R- rugosite +! +! pcfm---output-R- cdrag pour le moment +! pcfh---output-R- cdrag pour les flux de chaleur latente et sensible +! + INTEGER, INTENT(IN) :: knon, nsrf + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1, t1, q1 + REAL, DIMENSION(klon), INTENT(IN) :: tsurf, qsurf + REAL, DIMENSION(klon), INTENT(IN) :: rugos + REAL, DIMENSION(klon), INTENT(OUT) :: pcfm, pcfh +! +! ================================================================= c +! + INCLUDE "YOMCST.h" + INCLUDE "YOETHF.h" + INCLUDE "indicesol.h" + INCLUDE "clesphys.h" +! +! Quelques constantes et options: +!!$PB REAL, PARAMETER :: ckap=0.35, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2 + REAL, PARAMETER :: ckap=0.40, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2 +! +! Variables locales : + INTEGER :: i + REAL :: zdu2, ztsolv + REAL :: ztvd, zscf + REAL :: zucf, zcr + REAL :: friv, frih + REAL, DIMENSION(klon) :: zcfm1, zcfm2 + REAL, DIMENSION(klon) :: zcfh1, zcfh2 + REAL, DIMENSION(klon) :: zcdn + REAL, DIMENSION(klon) :: zri + REAL, DIMENSION(klon) :: zgeop1 ! geopotentiel au 1er niveau du modele + LOGICAL, PARAMETER :: zxli=.FALSE. ! calcul des cdrags selon Laurent Li +! +! Fonctions thermodynamiques et fonctions d'instabilite + REAL :: fsta, fins, x + fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x)) + fins(x) = SQRT(1.0-18.0*x) + +! ================================================================= c +! +! Calculer le geopotentiel du premier couche de modele +! + DO i = 1, knon + zgeop1(i) = RD * t1(i) / (0.5*(paprs(i,1)+pplay(i,1))) & + * (paprs(i,1)-pplay(i,1)) + END DO +! ================================================================= c +! +! Calculer le frottement au sol (Cdrag) +! + DO i = 1, knon + zdu2 = MAX(cepdu2,u1(i)**2+v1(i)**2) + ztsolv = tsurf(i) * (1.0+RETV*qsurf(i)) + ztvd = (t1(i)+zgeop1(i)/RCPD/(1.+RVTMP2*q1(i))) & + *(1.+RETV*q1(i)) + zri(i) = zgeop1(i)*(ztvd-ztsolv)/(zdu2*ztvd) + zcdn(i) = (ckap/LOG(1.+zgeop1(i)/(RG*rugos(i))))**2 + +!!$ IF (zri(i) .ge. 0.) THEN ! situation stable + IF (zri(i) .GT. 0.) THEN ! situation stable + zri(i) = MIN(20.,zri(i)) + IF (.NOT.zxli) THEN + zscf = SQRT(1.+cd*ABS(zri(i))) + FRIV = AMAX1(1. / (1.+2.*CB*zri(i)/ZSCF), 0.1) + zcfm1(i) = zcdn(i) * FRIV + FRIH = AMAX1(1./ (1.+3.*CB*zri(i)*ZSCF), 0.1 ) +!!$ PB zcfh1(i) = zcdn(i) * FRIH +!!$ PB zcfh1(i) = f_cdrag_stable * zcdn(i) * FRIH + zcfh1(i) = f_cdrag_ter * zcdn(i) * FRIH + IF(nsrf.EQ.is_oce) zcfh1(i) = f_cdrag_oce * zcdn(i) * FRIH +!!$ PB + pcfm(i) = zcfm1(i) + pcfh(i) = zcfh1(i) + ELSE + pcfm(i) = zcdn(i)* fsta(zri(i)) + pcfh(i) = zcdn(i)* fsta(zri(i)) + ENDIF + ELSE ! situation instable + IF (.NOT.zxli) THEN + zucf = 1./(1.+3.0*cb*cc*zcdn(i)*SQRT(ABS(zri(i)) & + *(1.0+zgeop1(i)/(RG*rugos(i))))) + zcfm2(i) = zcdn(i)*amax1((1.-2.0*cb*zri(i)*zucf),0.1) +!!$PB zcfh2(i) = zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),0.1) + zcfh2(i) = f_cdrag_ter*zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),0.1) + pcfm(i) = zcfm2(i) + pcfh(i) = zcfh2(i) + ELSE + pcfm(i) = zcdn(i)* fins(zri(i)) + pcfh(i) = zcdn(i)* fins(zri(i)) + ENDIF + zcr = (0.0016/(zcdn(i)*SQRT(zdu2)))*ABS(ztvd-ztsolv)**(1./3.) + IF(nsrf.EQ.is_oce) pcfh(i) =f_cdrag_oce* zcdn(i)*(1.0+zcr**1.25)**(1./1.25) + ENDIF + END DO + +! ================================================================= c + + ! IM cf JLD : on seuille cdrag_m et cdrag_h + IF (nsrf == is_oce) THEN + DO i=1,knon + pcfm(i)=MIN(pcfm(i),cdmmax) + pcfh(i)=MIN(pcfh(i),cdhmax) + END DO + END IF + +END SUBROUTINE clcdrag Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/clesphys.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/clesphys.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/clesphys.h (revision 1280) @@ -0,0 +1,81 @@ +! +! $Id$ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez à n'utiliser que des ! pour les commentaires +! et à bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +!..include cles_phys.h +! + LOGICAL cycle_diurne,soil_model,new_oliq,ok_orodr,ok_orolf + LOGICAL ok_limitvrai + INTEGER nbapp_rad, iflag_con + REAL co2_ppm, co2_ppm0, solaire + REAL(kind=8) RCO2, RCH4, RN2O, RCFC11, RCFC12 + REAL(kind=8) CH4_ppb, N2O_ppb, CFC11_ppt, CFC12_ppt + +!OM ---> correction du bilan d'eau global +!OM Correction sur precip KE + REAL cvl_corr +!OM Fonte calotte dans bilan eau + LOGICAL ok_lic_melt + +!IM simulateur ISCCP + INTEGER top_height, overlap +!IM seuils cdrm, cdrh + REAL cdmmax, cdhmax +!IM param. stabilite s/ terres et en dehors + REAL ksta, ksta_ter +!IM ok_kzmin : clef calcul Kzmin dans la CL de surface cf FH + LOGICAL ok_kzmin +!IM, MAFo fmagic, pmagic : parametres - additionnel et multiplicatif - +! pour regler l albedo sur ocean + REAL fmagic, pmagic +! Hauteur (imposee) du contenu en eau du sol + REAL qsol0 +! Frottement au sol (Cdrag) + Real f_cdrag_ter,f_cdrag_oce +! Rugoro + Real f_rugoro + +!IM lev_histhf : niveau sorties 6h +!IM lev_histday : niveau sorties journalieres +!IM lev_histmth : niveau sorties mensuelles + INTEGER lev_histhf, lev_histday, lev_histmth + Integer lev_histins, lev_histLES + CHARACTER(len=4) type_run +! aer_type: pour utiliser un fichier constant dans readaerosol + CHARACTER*8 :: aer_type + LOGICAL ok_isccp, ok_regdyn + REAL lonmin_ins, lonmax_ins, latmin_ins, latmax_ins + REAL ecrit_ins, ecrit_hf, ecrit_hf2mth, ecrit_day + REAL ecrit_mth, ecrit_tra, ecrit_reg + REAL ecrit_LES + REAL freq_ISCCP, ecrit_ISCCP + REAL freq_COSP + LOGICAL :: ok_cosp + INTEGER :: ip_ebil_phy, iflag_rrtm + LOGICAL :: ok_strato + LOGICAL :: ok_hines + + COMMON/clesphys/cycle_diurne, soil_model, new_oliq, & + & ok_orodr, ok_orolf, ok_limitvrai, nbapp_rad, iflag_con & + & , co2_ppm, solaire, RCO2, RCH4, RN2O, RCFC11, RCFC12 & + & , CH4_ppb, N2O_ppb, CFC11_ppt, CFC12_ppt & + & , top_height, overlap, cdmmax, cdhmax, ksta, ksta_ter & + & , ok_kzmin, fmagic, pmagic & + & , f_cdrag_ter,f_cdrag_oce,f_rugoro & + & , lev_histhf, lev_histday, lev_histmth & + & , lev_histins, lev_histLES & + & , type_run, ok_isccp, ok_regdyn, ok_cosp & + & , lonmin_ins, lonmax_ins, latmin_ins, latmax_ins & + & , ecrit_ins, ecrit_hf, ecrit_hf2mth, ecrit_day & + & , ecrit_mth, ecrit_tra, ecrit_reg & + & , freq_ISCCP, ecrit_ISCCP, freq_COSP, ip_ebil_phy & + & , ok_lic_melt, cvl_corr, aer_type & + & , qsol0, iflag_rrtm, ok_strato,ok_hines,ecrit_LES & + & , co2_ppm0 + +!$OMP THREADPRIVATE(/clesphys/) + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/clift.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/clift.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/clift.F (revision 1280) @@ -0,0 +1,72 @@ +! +! $Header$ +! + SUBROUTINE CLIFT (P,T,RR,RS,PLCL,DPLCLDT,DPLCLDQ) +C*************************************************************** +C* * +C* CLIFT : COMPUTE LIFTING CONDENSATION LEVEL AND ITS * +C* DERIVATIVES RELATIVE TO T AND R * +C* (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980) * +C* * +C* written by : GRANDPEIX Jean-Yves, 17/11/98, 12.39.01 * +C* modified by : * +C*************************************************************** +C* +C*Arguments : +C* +C* Input : P = pressure of level from wich lifting is performed +C* T = temperature of level P +C* RR = vapour mixing ratio at level P +C* RS = vapour saturation mixing ratio at level P +C* +C* Output : PLCL = lifting condensation level +C* DPLCLDT = derivative of PLCL relative to T +C* DPLCLDQ = derivative of PLCL relative to R +C* +ccccccccccccccccccccccc +c constantes coherentes avec le modele du Centre Europeen +c RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644 +c RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153 +c CPD = 3.5 * RD +c CPV = 4.0 * RV +c CL = 4218.0 +c CI=2090.0 +c CPVMCL=CL-CPV +c CLMCI=CL-CI +c EPS=RD/RV +c ALV0=2.5008E+06 +c ALF0=3.34E+05 +c +c on utilise les constantes thermo du Centre Europeen: (sb) +c +#include "YOMCST.h" +c + CPD = RCPD + CPV = RCPV + CL = RCW + CPVMCL = CL-CPV + EPS = RD/RV + ALV0 = RLVTT +c +c +c Bolton formula coefficients : + A = 1669.0 + B = 122.0 +c + RH=RR/RS + CHI=T/(A-B*RH-T) + PLCL=P*(RH**CHI) +c + ALV = ALV0 - CPVMCL*(T-273.15) +c +c -- sb: correction: +c DPLCLDQ = PLCL*CHI*( 1./RR - B*CHI/T/RS*ALOG(RH) ) + DPLCLDQ = PLCL*CHI*( 1./RR + B*CHI/T/RS*ALOG(RH) ) +c sb -- +c + DPLCLDT = PLCL*CHI*((A-B*RH*(1.+ALV/RV/T))/T**2*CHI*ALOG(RH) + $ - ALV/RV/T**2 ) +c +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/climb_hq_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/climb_hq_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/climb_hq_mod.F90 (revision 1280) @@ -0,0 +1,377 @@ +MODULE climb_hq_mod +! +! Module to solve the verctical diffusion of "q" and "H"; +! specific humidity and potential energi. +! + USE dimphy + + IMPLICIT NONE + SAVE + PRIVATE + PUBLIC :: climb_hq_down, climb_hq_up + + REAL, DIMENSION(:,:), ALLOCATABLE :: gamaq, gamah + !$OMP THREADPRIVATE(gamaq,gamah) + REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_Q, Dcoef_Q + !$OMP THREADPRIVATE(Ccoef_Q, Dcoef_Q) + REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_H, Dcoef_H + !$OMP THREADPRIVATE(Ccoef_H, Dcoef_H) + REAL, DIMENSION(:), ALLOCATABLE :: Acoef_Q, Bcoef_Q + !$OMP THREADPRIVATE(Acoef_Q, Bcoef_Q) + REAL, DIMENSION(:), ALLOCATABLE :: Acoef_H, Bcoef_H + !$OMP THREADPRIVATE(Acoef_H, Bcoef_H) + REAL, DIMENSION(:,:), ALLOCATABLE :: Kcoefhq + !$OMP THREADPRIVATE(Kcoefhq) + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE climb_hq_down(knon, coefhq, paprs, pplay, & + delp, temp, q, dtime, & + Acoef_H_out, Acoef_Q_out, Bcoef_H_out, Bcoef_Q_out) + + INCLUDE "YOMCST.h" +! This routine calculates recursivly the coefficients C and D +! for the quantity X=[Q,H] in equation X(k) = C(k) + D(k)*X(k-1), where k is +! the index of the vertical layer. +! +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + REAL, DIMENSION(klon,klev), INTENT(IN) :: coefhq + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs + REAL, DIMENSION(klon,klev), INTENT(IN) :: temp, delp ! temperature + REAL, DIMENSION(klon,klev), INTENT(IN) :: q + REAL, INTENT(IN) :: dtime + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: Acoef_H_out + REAL, DIMENSION(klon), INTENT(OUT) :: Acoef_Q_out + REAL, DIMENSION(klon), INTENT(OUT) :: Bcoef_H_out + REAL, DIMENSION(klon), INTENT(OUT) :: Bcoef_Q_out + +! Local variables +!**************************************************************************************** + LOGICAL, SAVE :: first=.TRUE. + !$OMP THREADPRIVATE(first) + REAL, DIMENSION(klon,klev) :: local_H + REAL, DIMENSION(klon) :: psref + REAL :: delz, pkh + INTEGER :: k, i, ierr + +! Include +!**************************************************************************************** + INCLUDE "compbl.h" + + +!**************************************************************************************** +! 1) +! Allocation at first time step only +! +!**************************************************************************************** + + IF (first) THEN + first=.FALSE. + ALLOCATE(Ccoef_Q(klon,klev), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc Ccoef_Q, ierr=', ierr + + ALLOCATE(Dcoef_Q(klon,klev), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc Dcoef_Q, ierr=', ierr + + ALLOCATE(Ccoef_H(klon,klev), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc Ccoef_H, ierr=', ierr + + ALLOCATE(Dcoef_H(klon,klev), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc Dcoef_H, ierr=', ierr + + ALLOCATE(Acoef_Q(klon), Bcoef_Q(klon), Acoef_H(klon), Bcoef_H(klon), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc Acoef_X and Bcoef_X, ierr=', ierr + + ALLOCATE(Kcoefhq(klon,klev), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc Kcoefhq, ierr=', ierr + + ALLOCATE(gamaq(1:klon,2:klev), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc gamaq, ierr=', ierr + + ALLOCATE(gamah(1:klon,2:klev), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc gamah, ierr=', ierr + END IF + +!**************************************************************************************** +! 2) +! Definition of the coeficient K +! +!**************************************************************************************** + Kcoefhq(:,:) = 0.0 + DO k = 2, klev + DO i = 1, knon + Kcoefhq(i,k) = & + coefhq(i,k)*RG*RG*dtime /(pplay(i,k-1)-pplay(i,k)) & + *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2 + ENDDO + ENDDO + +!**************************************************************************************** +! 3) +! Calculation of gama for "Q" and "H" +! +!**************************************************************************************** +! surface pressure is used as reference + psref(:) = paprs(:,1) + +! definition of gama + IF (iflag_pbl == 1) THEN + gamaq(:,:) = 0.0 + gamah(:,:) = -1.0e-03 + gamah(:,2) = -2.5e-03 + +! conversion de gama + DO k = 2, klev + DO i = 1, knon + delz = RD * (temp(i,k-1)+temp(i,k)) / & + 2.0 / RG / paprs(i,k) * (pplay(i,k-1)-pplay(i,k)) + pkh = (psref(i)/paprs(i,k))**RKAPPA + +! convertie gradient verticale d'humidite specifique en difference d'humidite specifique entre centre de couches + gamaq(i,k) = gamaq(i,k) * delz +! convertie gradient verticale de temperature en difference de temperature potentielle entre centre de couches + gamah(i,k) = gamah(i,k) * delz * RCPD * pkh + ENDDO + ENDDO + + ELSE + gamaq(:,:) = 0.0 + gamah(:,:) = 0.0 + ENDIF + + +!**************************************************************************************** +! 4) +! Calculte the coefficients C and D for specific humidity, q +! +!**************************************************************************************** + + CALL calc_coef(knon, Kcoefhq(:,:), gamaq(:,:), delp(:,:), q(:,:), & + Ccoef_Q(:,:), Dcoef_Q(:,:), Acoef_Q, Bcoef_Q) + +!**************************************************************************************** +! 5) +! Calculte the coefficients C and D for potentiel entalpie, H +! +!**************************************************************************************** + local_H(:,:) = 0.0 + + DO k=1,klev + DO i = 1, knon + ! convertie la temperature en entalpie potentielle + local_H(i,k) = RCPD * temp(i,k) * & + (psref(i)/pplay(i,k))**RKAPPA + ENDDO + ENDDO + + CALL calc_coef(knon, Kcoefhq(:,:), gamah(:,:), delp(:,:), local_H(:,:), & + Ccoef_H(:,:), Dcoef_H(:,:), Acoef_H, Bcoef_H) + +!**************************************************************************************** +! 6) +! Return the first layer in output variables +! +!**************************************************************************************** + Acoef_H_out = Acoef_H + Bcoef_H_out = Bcoef_H + Acoef_Q_out = Acoef_Q + Bcoef_Q_out = Bcoef_Q + + END SUBROUTINE climb_hq_down +! +!**************************************************************************************** +! + SUBROUTINE calc_coef(knon, Kcoef, gama, delp, X, Ccoef, Dcoef, Acoef, Bcoef) +! +! Calculate the coefficients C and D in : X(k) = C(k) + D(k)*X(k-1) +! where X is H or Q, and k the vertical level k=1,klev +! + INCLUDE "YOMCST.h" +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + REAL, DIMENSION(klon,klev), INTENT(IN) :: Kcoef, delp + REAL, DIMENSION(klon,klev), INTENT(IN) :: X + REAL, DIMENSION(klon,2:klev), INTENT(IN) :: gama + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: Acoef, Bcoef + REAL, DIMENSION(klon,klev), INTENT(OUT) :: Ccoef, Dcoef + +! Local variables +!**************************************************************************************** + INTEGER :: k, i + REAL :: buf + +!**************************************************************************************** +! Niveau au sommet, k=klev +! +!**************************************************************************************** + Ccoef(:,:) = 0.0 + Dcoef(:,:) = 0.0 + + DO i = 1, knon + buf = delp(i,klev) + Kcoef(i,klev) + + Ccoef(i,klev) = (X(i,klev)*delp(i,klev) - Kcoef(i,klev)*gama(i,klev))/buf + Dcoef(i,klev) = Kcoef(i,klev)/buf + END DO + + +!**************************************************************************************** +! Niveau (klev-1) <= k <= 2 +! +!**************************************************************************************** + + DO k=(klev-1),2,-1 + DO i = 1, knon + buf = delp(i,k) + Kcoef(i,k) + Kcoef(i,k+1)*(1.-Dcoef(i,k+1)) + Ccoef(i,k) = (X(i,k)*delp(i,k) + Kcoef(i,k+1)*Ccoef(i,k+1) + & + Kcoef(i,k+1)*gama(i,k+1) - Kcoef(i,k)*gama(i,k))/buf + Dcoef(i,k) = Kcoef(i,k)/buf + END DO + END DO + +!**************************************************************************************** +! Niveau k=1 +! +!**************************************************************************************** + + DO i = 1, knon + buf = delp(i,1) + Kcoef(i,2)*(1.-Dcoef(i,2)) + Acoef(i) = (X(i,1)*delp(i,1) + Kcoef(i,2)*(gama(i,2)+Ccoef(i,2)))/buf + Bcoef(i) = -1. * RG / buf + END DO + + END SUBROUTINE calc_coef +! +!**************************************************************************************** +! + SUBROUTINE climb_hq_up(knon, dtime, t_old, q_old, & + flx_q1, flx_h1, paprs, pplay, & + flux_q, flux_h, d_q, d_t) +! +! This routine calculates the flux and tendency of the specific humidity q and +! the potential engergi H. +! The quantities q and H are calculated according to +! X(k) = C(k) + D(k)*X(k-1) for X=[q,H], where the coefficients +! C and D are known from before and k is index of the vertical layer. +! + INCLUDE "YOMCST.h" +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon,klev), INTENT(IN) :: t_old, q_old + REAL, DIMENSION(klon), INTENT(IN) :: flx_q1, flx_h1 + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon,klev), INTENT(OUT) :: flux_q, flux_h, d_q, d_t + +! Local variables +!**************************************************************************************** + LOGICAL, SAVE :: last=.FALSE. + REAL, DIMENSION(klon,klev) :: h_new, q_new + REAL, DIMENSION(klon) :: psref + INTEGER :: k, i, ierr + +!**************************************************************************************** +! 1) +! Definition of some variables +! +!**************************************************************************************** + flux_q(:,:) = 0.0 + flux_h(:,:) = 0.0 + d_q(:,:) = 0.0 + d_t(:,:) = 0.0 + + psref(1:knon) = paprs(1:knon,1) + +!**************************************************************************************** +! 2) +! Calculation of Q and H +! +!**************************************************************************************** + +!- First layer + q_new(1:knon,1) = Acoef_Q(1:knon) + Bcoef_Q(1:knon)*flx_q1(1:knon)*dtime + h_new(1:knon,1) = Acoef_H(1:knon) + Bcoef_H(1:knon)*flx_h1(1:knon)*dtime + +!- All the other layers + DO k = 2, klev + DO i = 1, knon + q_new(i,k) = Ccoef_Q(i,k) + Dcoef_Q(i,k)*q_new(i,k-1) + h_new(i,k) = Ccoef_H(i,k) + Dcoef_H(i,k)*h_new(i,k-1) + END DO + END DO +!**************************************************************************************** +! 3) +! Calculation of the flux for Q and H +! +!**************************************************************************************** + +!- The flux at first layer, k=1 + flux_q(1:knon,1)=flx_q1(1:knon) + flux_h(1:knon,1)=flx_h1(1:knon) + +!- The flux at all layers above surface + DO k = 2, klev + DO i = 1, knon + flux_q(i,k) = (Kcoefhq(i,k)/RG/dtime) * & + (q_new(i,k)-q_new(i,k-1)+gamaq(i,k)) + + flux_h(i,k) = (Kcoefhq(i,k)/RG/dtime) * & + (h_new(i,k)-h_new(i,k-1)+gamah(i,k)) + END DO + END DO + +!**************************************************************************************** +! 4) +! Calculation of tendency for Q and H +! +!**************************************************************************************** + + DO k = 1, klev + DO i = 1, knon + d_t(i,k) = h_new(i,k)/(psref(i)/pplay(i,k))**RKAPPA/RCPD - t_old(i,k) + d_q(i,k) = q_new(i,k) - q_old(i,k) + END DO + END DO + +!**************************************************************************************** +! Some deallocations +! +!**************************************************************************************** + IF (last) THEN + DEALLOCATE(Ccoef_Q, Dcoef_Q, Ccoef_H, Dcoef_H,stat=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in dealllocate Ccoef_Q, Dcoef_Q, Ccoef_H, Dcoef_H, ierr=', ierr + DEALLOCATE(Acoef_Q, Bcoef_Q, Acoef_H, Bcoef_H,stat=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in dealllocate Acoef_Q, Bcoef_Q, Acoef_H, Bcoef_H, ierr=', ierr + DEALLOCATE(gamaq, gamah,stat=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in dealllocate gamaq, gamah, ierr=', ierr + DEALLOCATE(Kcoefhq,stat=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in dealllocate Kcoefhq, ierr=', ierr + END IF + END SUBROUTINE climb_hq_up +! +!**************************************************************************************** +! +END MODULE climb_hq_mod + + + + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/climb_wind_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/climb_wind_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/climb_wind_mod.F90 (revision 1280) @@ -0,0 +1,307 @@ +! +MODULE climb_wind_mod +! +! Module to solve the verctical diffusion of the wind components "u" and "v". +! + USE dimphy + + IMPLICIT NONE + + SAVE + PRIVATE + + REAL, DIMENSION(:), ALLOCATABLE :: alf1, alf2 + !$OMP THREADPRIVATE(alf1,alf2) + REAL, DIMENSION(:,:), ALLOCATABLE :: Kcoefm + !$OMP THREADPRIVATE(Kcoefm) + REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_U, Dcoef_U + !$OMP THREADPRIVATE(Ccoef_U, Dcoef_U) + REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_V, Dcoef_V + !$OMP THREADPRIVATE(Ccoef_V, Dcoef_V) + REAL, DIMENSION(:), ALLOCATABLE :: Acoef_U, Bcoef_U + !$OMP THREADPRIVATE(Acoef_U, Bcoef_U) + REAL, DIMENSION(:), ALLOCATABLE :: Acoef_V, Bcoef_V + !$OMP THREADPRIVATE(Acoef_V, Bcoef_V) + LOGICAL :: firstcall=.TRUE. + !$OMP THREADPRIVATE(firstcall) + + + PUBLIC :: climb_wind_down, climb_wind_up + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE climb_wind_init + + INTEGER :: ierr + CHARACTER(len = 20) :: modname = 'climb_wind_init' + +!**************************************************************************************** +! Allocation of global module variables +! +!**************************************************************************************** + + ALLOCATE(alf1(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate alf2',1) + + ALLOCATE(alf2(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate alf2',1) + + ALLOCATE(Kcoefm(klon,klev), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate Kcoefm',1) + + ALLOCATE(Ccoef_U(klon,klev), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate Ccoef_U',1) + + ALLOCATE(Dcoef_U(klon,klev), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Dcoef_U',1) + + ALLOCATE(Ccoef_V(klon,klev), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Ccoef_V',1) + + ALLOCATE(Dcoef_V(klon,klev), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Dcoef_V',1) + + ALLOCATE(Acoef_U(klon), Bcoef_U(klon), Acoef_V(klon), Bcoef_V(klon), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc Acoef_U and Bcoef_U, ierr=', ierr + + firstcall=.FALSE. + + END SUBROUTINE climb_wind_init +! +!**************************************************************************************** +! + SUBROUTINE climb_wind_down(knon, dtime, coef_in, pplay, paprs, temp, delp, u_old, v_old, & + Acoef_U_out, Acoef_V_out, Bcoef_U_out, Bcoef_V_out) +! +! This routine calculates for the wind components u and v, +! recursivly the coefficients C and D in equation +! X(k) = C(k) + D(k)*X(k-1), X=[u,v], k=[1,klev] is the vertical layer. +! +! + INCLUDE "YOMCST.h" +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon,klev), INTENT(IN) :: coef_in + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay ! pres au milieu de couche (Pa) + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs ! pression a inter-couche (Pa) + REAL, DIMENSION(klon,klev), INTENT(IN) :: temp ! temperature + REAL, DIMENSION(klon,klev), INTENT(IN) :: delp + REAL, DIMENSION(klon,klev), INTENT(IN) :: u_old + REAL, DIMENSION(klon,klev), INTENT(IN) :: v_old + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: Acoef_U_out + REAL, DIMENSION(klon), INTENT(OUT) :: Acoef_V_out + REAL, DIMENSION(klon), INTENT(OUT) :: Bcoef_U_out + REAL, DIMENSION(klon), INTENT(OUT) :: Bcoef_V_out + +! Local variables +!**************************************************************************************** + REAL, DIMENSION(klon) :: u1lay, v1lay + INTEGER :: k, i + + +!**************************************************************************************** +! Initialize module + IF (firstcall) CALL climb_wind_init + +!**************************************************************************************** +! Calculate the coefficients C and D in : u(k) = C(k) + D(k)*u(k-1) +! +!**************************************************************************************** +! - Define alpha (alf1 and alf2) + alf1(:) = 1.0 + alf2(:) = 1.0 - alf1(:) + +! - Calculate the coefficients K + Kcoefm(:,:) = 0.0 + DO k = 2, klev + DO i=1,knon + Kcoefm(i,k) = coef_in(i,k)*RG*RG*dtime/(pplay(i,k-1)-pplay(i,k)) & + *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2 + END DO + END DO + +! - Calculate the coefficients C and D, component "u" + CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), & + u_old(:,:), alf1(:), alf2(:), & + Ccoef_U(:,:), Dcoef_U(:,:), Acoef_U(:), Bcoef_U(:)) + +! - Calculate the coefficients C and D, component "v" + CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), & + v_old(:,:), alf1(:), alf2(:), & + Ccoef_V(:,:), Dcoef_V(:,:), Acoef_V(:), Bcoef_V(:)) + +!**************************************************************************************** +! 6) +! Return the first layer in output variables +! +!**************************************************************************************** + Acoef_U_out = Acoef_U + Bcoef_U_out = Bcoef_U + Acoef_V_out = Acoef_V + Bcoef_V_out = Bcoef_V + + END SUBROUTINE climb_wind_down +! +!**************************************************************************************** +! + SUBROUTINE calc_coef(knon, Kcoef, delp, X, alfa1, alfa2, Ccoef, Dcoef, Acoef, Bcoef) +! +! Find the coefficients C and D in fonction of alfa, K and delp +! +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + REAL, DIMENSION(klon,klev), INTENT(IN) :: Kcoef, delp + REAL, DIMENSION(klon,klev), INTENT(IN) :: X + REAL, DIMENSION(klon), INTENT(IN) :: alfa1, alfa2 + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: Acoef, Bcoef + REAL, DIMENSION(klon,klev), INTENT(OUT) :: Ccoef, Dcoef + +! local variables +!**************************************************************************************** + INTEGER :: k, i + REAL :: buf + + INCLUDE "YOMCST.h" +!**************************************************************************************** +! + +! Calculate coefficients C and D at top level, k=klev +! + Ccoef(:,:) = 0.0 + Dcoef(:,:) = 0.0 + + DO i = 1, knon + buf = delp(i,klev) + Kcoef(i,klev) + + Ccoef(i,klev) = X(i,klev)*delp(i,klev)/buf + Dcoef(i,klev) = Kcoef(i,klev)/buf + END DO + +! +! Calculate coefficients C and D at top level (klev-1) <= k <= 2 +! + DO k=(klev-1),2,-1 + DO i = 1, knon + buf = delp(i,k) + Kcoef(i,k) + Kcoef(i,k+1)*(1.-Dcoef(i,k+1)) + + Ccoef(i,k) = (X(i,k)*delp(i,k) + Kcoef(i,k+1)*Ccoef(i,k+1))/buf + Dcoef(i,k) = Kcoef(i,k)/buf + END DO + END DO + +! +! Calculate coeffiecent A and B at surface +! + DO i = 1, knon + buf = delp(i,1) + Kcoef(i,2)*(1-Dcoef(i,2)) + Acoef(i) = (X(i,1)*delp(i,1) + Kcoef(i,2)*Ccoef(i,2))/buf + Bcoef(i) = -RG/buf + END DO + + END SUBROUTINE calc_coef +! +!**************************************************************************************** +! + + SUBROUTINE climb_wind_up(knon, dtime, u_old, v_old, flx_u1, flx_v1, & + flx_u_new, flx_v_new, d_u_new, d_v_new) +! +! Diffuse the wind components from the surface layer and up to the top layer. +! Coefficents A, B, C and D are known from before. Start values for the diffusion are the +! momentum fluxes at surface. +! +! u(k=1) = A + B*flx*dtime +! u(k) = C(k) + D(k)*u(k-1) [2 <= k <= klev] +! +!**************************************************************************************** + INCLUDE "YOMCST.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon,klev), INTENT(IN) :: u_old + REAL, DIMENSION(klon,klev), INTENT(IN) :: v_old + REAL, DIMENSION(klon), INTENT(IN) :: flx_u1, flx_v1 ! momentum flux + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon,klev), INTENT(OUT) :: flx_u_new, flx_v_new + REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_u_new, d_v_new + +! Local variables +!**************************************************************************************** + REAL, DIMENSION(klon,klev) :: u_new, v_new + INTEGER :: k, i + +! +!**************************************************************************************** + +! Niveau 1 + DO i = 1, knon + u_new(i,1) = Acoef_U(i) + Bcoef_U(i)*flx_u1(i)*dtime + v_new(i,1) = Acoef_V(i) + Bcoef_V(i)*flx_v1(i)*dtime + END DO + +! Niveau 2 jusqu'au sommet klev + DO k = 2, klev + DO i=1, knon + u_new(i,k) = Ccoef_U(i,k) + Dcoef_U(i,k) * u_new(i,k-1) + v_new(i,k) = Ccoef_V(i,k) + Dcoef_V(i,k) * v_new(i,k-1) + END DO + END DO + +!**************************************************************************************** +! Calcul flux +! +!== flux_u/v est le flux de moment angulaire (positif vers bas) +!== dont l'unite est: (kg m/s)/(m**2 s) +! +!**************************************************************************************** +! + flx_u_new(:,:) = 0.0 + flx_v_new(:,:) = 0.0 + + flx_u_new(1:knon,1)=flx_u1(1:knon) + flx_v_new(1:knon,1)=flx_v1(1:knon) + +! Niveau 2->klev + DO k = 2, klev + DO i = 1, knon + flx_u_new(i,k) = Kcoefm(i,k)/RG/dtime * & + (u_new(i,k)-u_new(i,k-1)) + + flx_v_new(i,k) = Kcoefm(i,k)/RG/dtime * & + (v_new(i,k)-v_new(i,k-1)) + END DO + END DO + +!**************************************************************************************** +! Calcul tendances +! +!**************************************************************************************** + d_u_new(:,:) = 0.0 + d_v_new(:,:) = 0.0 + DO k = 1, klev + DO i = 1, knon + d_u_new(i,k) = u_new(i,k) - u_old(i,k) + d_v_new(i,k) = v_new(i,k) - v_old(i,k) + END DO + END DO + + END SUBROUTINE climb_wind_up +! +!**************************************************************************************** +! +END MODULE climb_wind_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/clouds_gno.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/clouds_gno.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/clouds_gno.F (revision 1280) @@ -0,0 +1,263 @@ +! +! $Header$ +! +C +C================================================================================ +C + SUBROUTINE CLOUDS_GNO(klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF) + IMPLICIT NONE +C +C-------------------------------------------------------------------------------- +C +C Inputs: +C +C ND----------: Number of vertical levels +C R--------ND-: Domain-averaged mixing ratio of total water +C RS-------ND-: Mean saturation humidity mixing ratio within the gridbox +C QSUB-----ND-: Mixing ratio of condensed water within clouds associated +C with SUBGRID-SCALE condensation processes (here, it is +C predicted by the convection scheme) +C Outputs: +C +C PTCONV-----ND-: Point convectif = TRUE +C RATQSC-----ND-: Largeur normalisee de la distribution +C CLDF-----ND-: Fraction nuageuse +C +C-------------------------------------------------------------------------------- + + + INTEGER klon,ND + REAL R(klon,ND), RS(klon,ND), QSUB(klon,ND) + LOGICAL PTCONV(klon,ND) + REAL RATQSC(klon,ND) + REAL CLDF(klon,ND) + +c -- parameters controlling the iteration: +c -- nmax : maximum nb of iterations (hopefully never reached) +c -- epsilon : accuracy of the numerical resolution +c -- vmax : v-value above which we use an asymptotic expression for ERF(v) + + INTEGER nmax + PARAMETER ( nmax = 10) + REAL epsilon, vmax0, vmax(klon) + PARAMETER ( epsilon = 0.02, vmax0 = 2.0 ) + + REAL min_mu, min_Q + PARAMETER ( min_mu = 1.e-12, min_Q=1.e-12 ) + + INTEGER i,K, n, m + REAL mu(klon), qsat, delta(klon), beta(klon) + real zu2,zv2 + REAL xx(klon), aux(klon), coeff, block + REAL dist, fprime, det + REAL pi, u, v, erfcu, erfcv + REAL xx1, xx2 + real erf,hsqrtlog_2,v2 + real sqrtpi,sqrt2,zx1,zx2,exdel +c lconv = true si le calcul a converge (entre autre si qsub < min_q) + LOGICAL lconv(klon) + +!cdir arraycomb + cldf (1:klon,1:ND)=0.0 ! cym + ratqsc(1:klon,1:ND)=0.0 + ptconv(1:klon,1:ND)=.false. +!cdir end arraycomb + + pi = ACOS(-1.) + sqrtpi=sqrt(pi) + sqrt2=sqrt(2.) + hsqrtlog_2=0.5*SQRT(log(2.)) + + DO 500 K = 1, ND + + do i=1,klon ! vector + mu(i) = R(i,K) + mu(i) = MAX(mu(i),min_mu) + qsat = RS(i,K) + qsat = MAX(qsat,min_mu) + delta(i) = log(mu(i)/qsat) +c enddo ! vector + +C +C *** There is no subgrid-scale condensation; *** +C *** the scheme becomes equivalent to an "all-or-nothing" *** +C *** large-scale condensation scheme. *** +C + +C +C *** Some condensation is produced at the subgrid-scale *** +C *** *** +C *** PDF = generalized log-normal distribution (GNO) *** +C *** (k<0 because a lower bound is considered for the PDF) *** +C *** *** +C *** -> Determine x (the parameter k of the GNO PDF) such *** +C *** that the contribution of subgrid-scale processes to *** +C *** the in-cloud water content is equal to QSUB(K) *** +C *** (equations (13), (14), (15) + Appendix B of the paper) *** +C *** *** +C *** Here, an iterative method is used for this purpose *** +C *** (other numerical methods might be more efficient) *** +C *** *** +C *** NB: the "error function" is called ERF *** +C *** (ERF in double precision) *** +C + +c On commence par eliminer les cas pour lesquels on n'a pas +c suffisamment d'eau nuageuse. + +c do i=1,klon ! vector + + IF ( QSUB(i,K) .lt. min_Q ) THEN + ptconv(i,k)=.false. + ratqsc(i,k)=0. + lconv(i) = .true. + +c Rien on a deja initialise + + ELSE + + lconv(i) = .FALSE. + vmax(i) = vmax0 + + beta(i) = QSUB(i,K)/mu(i) + EXP( -MIN(0.0,delta(i)) ) + +c -- roots of equation v > vmax: + + det = delta(i) + vmax(i)*vmax(i) + if (det.LE.0.0) vmax(i) = vmax0 + 1.0 + det = delta(i) + vmax(i)*vmax(i) + + if (det.LE.0.) then + xx(i) = -0.0001 + else + zx1=-sqrt2*vmax(i) + zx2=SQRT(1.0+delta(i)/(vmax(i)*vmax(i))) + xx1=zx1*(1.0-zx2) + xx2=zx1*(1.0+zx2) + xx(i) = 1.01 * xx1 + if ( xx1 .GE. 0.0 ) xx(i) = 0.5*xx2 + endif + if (delta(i).LT.0.) xx(i) = -hsqrtlog_2 + + ENDIF + + enddo ! vector + +c---------------------------------------------------------------------- +c Debut des nmax iterations pour trouver la solution. +c---------------------------------------------------------------------- + + DO n = 1, nmax + + do i=1,klon ! vector + if (.not.lconv(i)) then + + u = delta(i)/(xx(i)*sqrt2) + xx(i)/(2.*sqrt2) + v = delta(i)/(xx(i)*sqrt2) - xx(i)/(2.*sqrt2) + v2 = v*v + + IF ( v .GT. vmax(i) ) THEN + + IF ( ABS(u) .GT. vmax(i) + : .AND. delta(i) .LT. 0. ) THEN + +c -- use asymptotic expression of erf for u and v large: +c ( -> analytic solution for xx ) + exdel=beta(i)*EXP(delta(i)) + aux(i) = 2.0*delta(i)*(1.-exdel) + : /(1.+exdel) + if (aux(i).lt.0.) then +c print*,'AUX(',i,',',k,')<0',aux(i),delta(i),beta(i) + aux(i)=0. + endif + xx(i) = -SQRT(aux(i)) + block = EXP(-v*v) / v / sqrtpi + dist = 0.0 + fprime = 1.0 + + ELSE + +c -- erfv -> 1.0, use an asymptotic expression of erfv for v large: + + erfcu = 1.0-ERF(u) +c !!! ATTENTION : rajout d'un seuil pour l'exponentiel + aux(i) = sqrtpi*erfcu*EXP(min(v2,100.)) + coeff = 1.0 - 0.5/(v2) + 0.75/(v2*v2) + block = coeff * EXP(-v2) / v / sqrtpi + dist = v * aux(i) / coeff - beta(i) + fprime = 2.0 / xx(i) * (v2) + : * ( EXP(-delta(i)) - u * aux(i) / coeff ) + : / coeff + + ENDIF ! ABS(u) + + ELSE + +c -- general case: + + erfcu = 1.0-ERF(u) + erfcv = 1.0-ERF(v) + block = erfcv + dist = erfcu / erfcv - beta(i) + zu2=u*u + zv2=v2 + if(zu2.gt.20..or. zv2.gt.20.) then +c print*,'ATTENTION !!! xx(',i,') =', xx(i) +c print*,'ATTENTION !!! klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF', +c .klon,ND,R(i,k),RS(i,k),QSUB(i,k),PTCONV(i,k),RATQSC(i,k), +c .CLDF(i,k) +c print*,'ATTENTION !!! zu2 zv2 =',zu2(i),zv2(i) + zu2=20. + zv2=20. + fprime = 0. + else + fprime = 2. /sqrtpi /xx(i) /(erfcv*erfcv) + : * ( erfcv*v*EXP(-zu2) + : - erfcu*u*EXP(-zv2) ) + endif + ENDIF ! x + +c -- test numerical convergence: + +! if (beta(i).lt.1.e-10) then +! print*,'avant test ',i,k,lconv(i),u(i),v(i),beta(i) +! stop +! endif + if (abs(fprime).lt.1.e-11) then +! print*,'avant test fprime<.e-11 ' +! s ,i,k,lconv(i),u(i),v(i),beta(i),fprime(i) +! print*,'klon,ND,R,RS,QSUB', +! s klon,ND,R(i,k),rs(i,k),qsub(i,k) + fprime=sign(1.e-11,fprime) + endif + + + if ( ABS(dist/beta(i)) .LT. epsilon ) then +c print*,'v-u **2',(v(i)-u(i))**2 +c print*,'exp v-u **2',exp((v(i)-u(i))**2) + ptconv(i,K) = .TRUE. + lconv(i)=.true. +c borne pour l'exponentielle + ratqsc(i,k)=min(2.*(v-u)*(v-u),20.) + ratqsc(i,k)=sqrt(exp(ratqsc(i,k))-1.) + CLDF(i,K) = 0.5 * block + else + xx(i) = xx(i) - dist/fprime + endif +c print*,'apres test ',i,k,lconv(i) + + endif ! lconv + enddo ! vector + +c---------------------------------------------------------------------- +c Fin des nmax iterations pour trouver la solution. + ENDDO ! n +c---------------------------------------------------------------------- + +500 CONTINUE ! K + + RETURN + END + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cltrac.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cltrac.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cltrac.F90 (revision 1280) @@ -0,0 +1,140 @@ +! +! $Id $ +! +SUBROUTINE cltrac(dtime,coef,t,tr,flux,paprs,pplay,delp,d_tr) + USE dimphy + IMPLICIT NONE +!====================================================================== +! Auteur(s): O. Boucher (LOA/LMD) date: 19961127 +! inspire de clvent +! Objet: diffusion verticale de traceurs avec flux fixe a la surface +! ou/et flux du type c-drag +! +! Arguments: +!----------- +! dtime....input-R- intervalle du temps (en secondes) +! coef.....input-R- le coefficient d'echange (m**2/s) l>1 +! t........input-R- temperature (K) +! tr.......input-R- la q. de traceurs +! flux.....input-R- le flux de traceurs a la surface +! paprs....input-R- pression a inter-couche (Pa) +! pplay....input-R- pression au milieu de couche (Pa) +! delp.....input-R- epaisseur de couche (Pa) +! cdrag....input-R- cdrag pour le flux de surface (non active) +! tr0......input-R- traceurs a la surface ou dans l'ocean (non active) +! d_tr.....output-R- le changement de tr +! flux_tr..output-R- flux de tr +!====================================================================== + include "YOMCST.h" +! +! Entree +! + REAL,INTENT(IN) :: dtime + REAL,DIMENSION(klon,klev),INTENT(IN) :: coef + REAL,DIMENSION(klon,klev),INTENT(IN) :: t, tr + REAL,DIMENSION(klon),INTENT(IN) :: flux !(at/s/m2) + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs + REAL,DIMENSION(klon,klev),INTENT(IN) :: pplay, delp +! +! Sorties +! + REAL ,DIMENSION(klon,klev),INTENT(OUT) :: d_tr +! REAL ,DIMENSION(klon,klev),INTENT(OUT) :: flux_tr +! +! Local +! + INTEGER :: i, k + REAL,DIMENSION(klon) :: cdrag, tr0 + REAL,DIMENSION(klon,klev) :: zx_ctr + REAL,DIMENSION(klon,klev) :: zx_dtr + REAL,DIMENSION(klon) :: zx_buf + REAL,DIMENSION(klon,klev) :: zx_coef + REAL,DIMENSION(klon,klev) :: local_tr + REAL,DIMENSION(klon) :: zx_alf1,zx_alf2,zx_flux + +!====================================================================== + + DO k = 1, klev + DO i = 1, klon + local_tr(i,k) = tr(i,k) + ENDDO + ENDDO + +!====================================================================== + + DO i = 1, klon + zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2)) + zx_alf2(i) = 1.0 - zx_alf1(i) + zx_flux(i) = -flux(i)*dtime*RG +! Pour le moment le flux est prescrit cdrag et zx_coef(1) vaut 0 + cdrag(i) = 0.0 + tr0(i) = 0.0 + zx_coef(i,1) = cdrag(i)*dtime*RG + zx_ctr(i,1)=0. + zx_dtr(i,1)=0. + ENDDO + +!====================================================================== + + DO k = 2, klev + DO i = 1, klon + zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k)) & + *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2 + zx_coef(i,k) = zx_coef(i,k)*dtime*RG + ENDDO + ENDDO + +!====================================================================== + + DO i = 1, klon + zx_buf(i) = delp(i,1) + zx_coef(i,1)*zx_alf1(i) + zx_coef(i,2) + ! + zx_ctr(i,2) = (local_tr(i,1)*delp(i,1)+ & + zx_coef(i,1)*tr0(i)-zx_flux(i))/zx_buf(i) + ! + zx_dtr(i,2) = (zx_coef(i,2)-zx_alf2(i)*zx_coef(i,1)) / & + zx_buf(i) + ENDDO + + DO k = 3, klev + DO i = 1, klon + zx_buf(i) = delp(i,k-1) + zx_coef(i,k) & + + zx_coef(i,k-1)*(1.-zx_dtr(i,k-1)) + zx_ctr(i,k) = (local_tr(i,k-1)*delp(i,k-1) & + +zx_coef(i,k-1)*zx_ctr(i,k-1) )/zx_buf(i) + zx_dtr(i,k) = zx_coef(i,k)/zx_buf(i) + ENDDO + ENDDO + + DO i = 1, klon + local_tr(i,klev) = ( local_tr(i,klev)*delp(i,klev) & + +zx_coef(i,klev)*zx_ctr(i,klev) ) & + / ( delp(i,klev) + zx_coef(i,klev) & + -zx_coef(i,klev)*zx_dtr(i,klev) ) + ENDDO + + DO k = klev-1, 1, -1 + DO i = 1, klon + local_tr(i,k) = zx_ctr(i,k+1) + zx_dtr(i,k+1)*local_tr(i,k+1) + ENDDO + ENDDO + +!====================================================================== +!== flux_tr est le flux de traceur (positif vers bas) +! DO i = 1, klon +! flux_tr(i,1) = zx_coef(i,1)/(RG*dtime) +! ENDDO +! DO k = 2, klev +! DO i = 1, klon +! flux_tr(i,k) = zx_coef(i,k)/(RG*dtime) +! . * (local_tr(i,k)-local_tr(i,k-1)) +! ENDDO +! ENDDO +!====================================================================== + DO k = 1, klev + DO i = 1, klon + d_tr(i,k) = local_tr(i,k) - tr(i,k) + ENDDO + ENDDO + +END SUBROUTINE cltrac Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cltracrn.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cltracrn.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cltracrn.F90 (revision 1280) @@ -0,0 +1,286 @@ +!$Id $ + +SUBROUTINE cltracrn( itr, dtime,u1lay, v1lay, & + cdrag,coef,t,ftsol,pctsrf, & + tr,trs,paprs,pplay,delp, & + masktr,fshtr,hsoltr,tautr,vdeptr, & + lat,d_tr,d_trs ) + + USE dimphy + IMPLICIT NONE +!====================================================================== +! Auteur(s): Alex/LMD) date: fev 99 +! inspire de clqh + clvent +! Objet: diffusion verticale de traceurs avec quantite de traceur ds +! le sol ( reservoir de sol de radon ) +! +! note : pour l'instant le traceur dans le sol et le flux sont +! calcules mais ils ne servent que de diagnostiques +! seule la tendance sur le traceur est sortie (d_tr) +!--------------------------------------------------------------------- +! Arguments: +! itr......input-R- le type de traceur 1- Rn 2 - Pb +! dtime....input-R- intervalle du temps (en secondes) ~ pdtphys +! u1lay....input-R- vent u de la premiere couche (m/s) +! v1lay....input-R- vent v de la premiere couche (m/s) +! cdrag....input-R- cdrag +! coef.....input-R- le coefficient d'echange (m**2/s) l>1, valable uniquement pour k entre 2 et klev +! t........input-R- temperature (K) +! paprs....input-R- pression a inter-couche (Pa) +! pplay....input-R- pression au milieu de couche (Pa) +! delp.....input-R- epaisseur de couche (Pa) +! ftsol....input-R- temperature du sol (en Kelvin) +! tr.......input-R- traceurs +! trs......input-R- traceurs dans le sol +! masktr...input-R- Masque reservoir de sol traceur (1 = reservoir) +! fshtr....input-R- Flux surfacique de production dans le sol +! tautr....input-R- Constante de decroissance du traceur +! vdeptr...input-R- Vitesse de depot sec dans la couche brownienne +! hsoltr...input-R- Epaisseur equivalente du reservoir de sol +! lat......input-R- latitude en degree +! d_tr.....output-R- le changement de "tr" +! d_trs....output-R- le changement de "trs" +!====================================================================== + include "YOMCST.h" + include "indicesol.h" +! +!Entrees + INTEGER,INTENT(IN) :: itr + REAL,INTENT(IN) :: dtime + REAL,DIMENSION(klon),INTENT(IN) :: u1lay, v1lay + REAL,DIMENSION(klon),INTENT(IN) :: cdrag + REAL,DIMENSION(klon,klev),INTENT(IN) :: coef, t + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol, pctsrf + REAL,DIMENSION(klon,klev),INTENT(IN) :: tr + REAL,DIMENSION(klon),INTENT(IN) :: trs + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs + REAL,DIMENSION(klon,klev),INTENT(IN) :: pplay, delp + REAL,DIMENSION(klon),INTENT(IN) :: masktr + REAL,DIMENSION(klon),INTENT(IN) :: fshtr + REAL,INTENT(IN) :: hsoltr + REAL,INTENT(IN) :: tautr + REAL,INTENT(IN) :: vdeptr + REAL,DIMENSION(klon),INTENT(IN) :: lat + +!Sorties + REAL,DIMENSION(klon,klev),INTENT(OUT) :: d_tr + REAL,DIMENSION(klon),INTENT(OUT) :: d_trs ! (diagnostic) traceur ds le sol + +!Locales + REAL,DIMENSION(klon,klev) :: flux_tr ! (diagnostic) flux de traceur + INTEGER :: i, k, n, l + REAL,DIMENSION(klon) :: rotrhi + REAL,DIMENSION(klon,klev) :: zx_coef + REAL,DIMENSION(klon) :: zx_buf + REAL,DIMENSION(klon,klev) :: zx_ctr + REAL,DIMENSION(klon,klev) :: zx_dtr + REAL,DIMENSION(klon) :: zx_trs + REAL :: zx_a, zx_b + + REAL,DIMENSION(klon,klev) :: local_tr + REAL,DIMENSION(klon) :: local_trs + REAL,DIMENSION(klon) :: zts ! champ de temperature du sol + REAL,DIMENSION(klon) :: zx_alpha1, zx_alpha2 +!====================================================================== +!AA Pour l'instant les 4 types de surface ne sont pas pris en compte +!AA On fabrique avec zts un champ de temperature de sol +!AA que le pondere par la fraction de nature de sol. + + DO i = 1,klon + zts(i) = 0. + ENDDO + + DO n=1,nbsrf + DO i = 1,klon + zts(i) = zts(i) + ftsol(i,n)*pctsrf(i,n) + ENDDO + ENDDO + + DO i = 1,klon + rotrhi(i) = RD * zts(i) / hsoltr + ENDDO + + DO k = 1, klev + DO i = 1, klon + local_tr(i,k) = tr(i,k) + ENDDO + ENDDO + + DO i = 1, klon + local_trs(i) = trs(i) + ENDDO +!====================================================================== +!AA Attention si dans clmain zx_alf1(i) = 1.0 +!AA Il doit y avoir coherence (dc la meme chose ici) + + DO i = 1, klon +!AA zx_alpha1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2)) + zx_alpha1(i) = 1.0 + zx_alpha2(i) = 1.0 - zx_alpha1(i) + ENDDO +!====================================================================== + DO i = 1, klon + zx_coef(i,1) = cdrag(i)*(1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) & + *pplay(i,1)/(RD*t(i,1)) + zx_coef(i,1) = zx_coef(i,1) * dtime*RG + ENDDO + + DO k = 2, klev + DO i = 1, klon + zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k)) & + *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2 + zx_coef(i,k) = zx_coef(i,k) * dtime*RG + ENDDO + ENDDO +!====================================================================== + DO i = 1, klon + zx_buf(i) = delp(i,klev) + zx_coef(i,klev) + zx_ctr(i,klev) = local_tr(i,klev)*delp(i,klev)/zx_buf(i) + zx_dtr(i,klev) = zx_coef(i,klev) / zx_buf(i) + ENDDO + + DO l = klev-1, 2 , -1 + DO i = 1, klon + zx_buf(i) = delp(i,l)+zx_coef(i,l) & + +zx_coef(i,l+1)*(1.-zx_dtr(i,l+1)) + + zx_ctr(i,l) = ( local_tr(i,l)*delp(i,l) & + + zx_coef(i,l+1)*zx_ctr(i,l+1) )/zx_buf(i) + zx_dtr(i,l) = zx_coef(i,l) / zx_buf(i) + ENDDO + ENDDO + + DO i = 1, klon + zx_buf(i) = delp(i,1) + zx_coef(i,2)*(1.-zx_dtr(i,2)) & + + masktr(i) * zx_coef(i,1) & + *( zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2) ) + + zx_ctr(i,1) = ( local_tr(i,1)*delp(i,1) & + + zx_ctr(i,2) & + *(zx_coef(i,2) & + - masktr(i) * zx_coef(i,1) & + *zx_alpha2(i) ) ) / zx_buf(i) + zx_dtr(i,1) = masktr(i) * zx_coef(i,1) / zx_buf(i) + ENDDO +!====================================================================== +! Calculer d'abord local_trs nouvelle quantite dans le reservoir +! de sol +!===================================================================== + + DO i = 1, klon +!------------------------- +! Au dessus des continents +!-- +! Le pb peut se deposer partout : vdeptr = 10-3 m/s +! Le Rn est traiter commme une couche Brownienne puisque vdeptr = 0. +!------------------------------------------------------------------- + IF ( NINT(masktr(i)) .EQ. 1 ) THEN + zx_trs(i) = local_trs(i) + zx_a = zx_trs(i) & + +fshtr(i)*dtime*rotrhi(i) & + +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG & + *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)) & + +zx_alpha2(i)*zx_ctr(i,2)) +! Pour l'instant, pour aller vite, le depot sec est traite comme une decroissance + zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG & + * (1.-zx_dtr(i,1) & + *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2))) & + + dtime / tautr & + + dtime * vdeptr / hsoltr + zx_trs(i) = zx_a / zx_b + local_trs(i) = zx_trs(i) + ENDIF +!-------------------------------------------------------- +! Si on est entre 60N et 70N on divise par 2 l'emanation +!-------------------------------------------------------- + + IF ( (itr.eq.1.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60..AND.lat(i).LE.70.).OR. & + (itr.eq.2.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60..AND.lat(i).LE.70.) ) THEN + zx_trs(i) = local_trs(i) + zx_a = zx_trs(i) & + +(fshtr(i)/2.)*dtime*rotrhi(i) & + +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG & + *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)) & + +zx_alpha2(i)*zx_ctr(i,2)) + ! + zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG & + * (1.-zx_dtr(i,1) & + *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2))) & + + dtime / tautr & + + dtime * vdeptr / hsoltr + ! + zx_trs(i) = zx_a / zx_b + local_trs(i) = zx_trs(i) + ENDIF + +!---------------------------------------------- +! Au dessus des oceans et aux hautes latitudes +!-- +! au dessous de -60S pas d'emission de radon au dessus +! des oceans et des continents +!--------------------------------------------------------------- + + IF ( (itr.EQ.1.AND.NINT(masktr(i)).EQ.0).OR. & + (itr.EQ.1.AND.NINT(masktr(i)).EQ.1.AND.lat(i).LT.-60.)) THEN + zx_trs(i) = 0. + local_trs(i) = 0. + END IF +!-- +! au dessus de 70 N pas d'emission de radon au dessus +! des oceans et des continents +!-------------------------------------------------------------- + IF ( (itr.EQ.1.AND.NINT(masktr(i)).EQ.0).OR. & + (itr.EQ.1.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GT.70.)) THEN + zx_trs(i) = 0. + local_trs(i) = 0. + END IF +!--------------------------------------------- +! Au dessus des oceans la source est nulle +!-------------------------------------------- + + IF (itr.eq.1.AND.NINT(masktr(i)).EQ.0) THEN + zx_trs(i) = 0. + local_trs(i) = 0. + END IF + + ENDDO ! sur le i=1,klon +! +!====================================================================== +! Une fois on a zx_trs, on peut faire l'iteration +!====================================================================== + + DO i = 1, klon + local_tr(i,1) = zx_ctr(i,1)+zx_dtr(i,1)*zx_trs(i) + ENDDO + DO l = 2, klev + DO i = 1, klon + local_tr(i,l) = zx_ctr(i,l) + zx_dtr(i,l)*local_tr(i,l-1) + ENDDO + ENDDO +!====================================================================== +! Calcul du flux de traceur (flux_tr): UA/(m**2 s) +!====================================================================== + DO i = 1, klon + flux_tr(i,1) = masktr(i)*zx_coef(i,1)/RG & + * (zx_alpha1(i)*local_tr(i,1)+zx_alpha2(i)*local_tr(i,2) & + -zx_trs(i)) / dtime + ENDDO + DO l = 2, klev + DO i = 1, klon + flux_tr(i,l) = zx_coef(i,l)/RG & + * (local_tr(i,l)-local_tr(i,l-1)) / dtime + ENDDO + ENDDO +!====================================================================== +! Calcul des tendances du traceur ds le sol et dans l'atmosphere +!====================================================================== + DO l = 1, klev + DO i = 1, klon + d_tr(i,l) = local_tr(i,l) - tr(i,l) + ENDDO + ENDDO + DO i = 1, klon + d_trs(i) = local_trs(i) - trs(i) + ENDDO + +END SUBROUTINE cltracrn Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/coef_diff_turb_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/coef_diff_turb_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/coef_diff_turb_mod.F90 (revision 1280) @@ -0,0 +1,582 @@ +! +MODULE coef_diff_turb_mod +! +! This module contains some procedures for calculation of the coefficients of the +! turbulent diffusion in the atmosphere and coefficients for turbulent diffusion +! at surface(cdrag) +! + IMPLICIT NONE + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE coef_diff_turb(dtime, nsrf, knon, ni, & + ypaprs, ypplay, yu, yv, yq, yt, yts, yrugos, yqsurf, ycdragm, & + ycoefm, ycoefh ,yq2) + + USE dimphy +! +! Calculate coefficients(ycoefm, ycoefh) for turbulent diffusion in the +! atmosphere +! NB! No values are calculated between surface and the first model layer. +! ycoefm(:,1) and ycoefh(:,1) are not valid !!! +! +! +! Input arguments +!**************************************************************************************** + REAL, INTENT(IN) :: dtime + INTEGER, INTENT(IN) :: nsrf, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: ni + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: ypaprs + REAL, DIMENSION(klon,klev), INTENT(IN) :: ypplay + REAL, DIMENSION(klon,klev), INTENT(IN) :: yu, yv + REAL, DIMENSION(klon,klev), INTENT(IN) :: yq, yt + REAL, DIMENSION(klon), INTENT(IN) :: yts, yrugos, yqsurf + REAL, DIMENSION(klon), INTENT(IN) :: ycdragm + +! InOutput arguments +!**************************************************************************************** + REAL, DIMENSION(klon,klev+1), INTENT(INOUT):: yq2 + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon,klev), INTENT(OUT) :: ycoefh + REAL, DIMENSION(klon,klev), INTENT(OUT) :: ycoefm + +! Other local variables +!**************************************************************************************** + INTEGER :: k, i, j + REAL, DIMENSION(klon,klev) :: ycoefm0, ycoefh0, yzlay, yteta + REAL, DIMENSION(klon,klev+1) :: yzlev, q2diag, ykmm, ykmn, ykmq + REAL, DIMENSION(klon) :: yustar + +! Include +!**************************************************************************************** + INCLUDE "clesphys.h" + INCLUDE "indicesol.h" + INCLUDE "iniprint.h" + INCLUDE "compbl.h" + INCLUDE "YOETHF.h" + INCLUDE "YOMCST.h" + + +!**************************************************************************************** +! Calcul de coefficients de diffusion turbulent de l'atmosphere : +! ycoefm(:,2:klev), ycoefh(:,2:klev) +! +!**************************************************************************************** + + CALL coefkz(nsrf, knon, ypaprs, ypplay, & + ksta, ksta_ter, & + yts, yrugos, yu, yv, yt, yq, & + yqsurf, & + ycoefm, ycoefh) + +!**************************************************************************************** +! Eventuelle recalcule des coeffeicients de diffusion turbulent de l'atmosphere : +! ycoefm(:,2:klev), ycoefh(:,2:klev) +! +!**************************************************************************************** + + IF (iflag_pbl.EQ.1) THEN + CALL coefkz2(nsrf, knon, ypaprs, ypplay, yt, & + ycoefm0, ycoefh0) + + DO k = 2, klev + DO i = 1, knon + ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k)) + ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k)) + ENDDO + ENDDO + ENDIF + + +!**************************************************************************************** +! Calcul d'une diffusion minimale pour les conditions tres stables +! +!**************************************************************************************** + IF (ok_kzmin) THEN + CALL coefkzmin(knon,ypaprs,ypplay,yu,yv,yt,yq,ycdragm, & + ycoefm0,ycoefh0) + + DO k = 2, klev + DO i = 1, knon + ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k)) + ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k)) + ENDDO + ENDDO + + ENDIF + + +!**************************************************************************************** +! MELLOR ET YAMADA adapte a Mars Richard Fournier et Frederic Hourdin +! +!**************************************************************************************** + + IF (iflag_pbl.GE.3) THEN + + yzlay(1:knon,1)= & + RD*yt(1:knon,1)/(0.5*(ypaprs(1:knon,1)+ypplay(1:knon,1))) & + *(ypaprs(1:knon,1)-ypplay(1:knon,1))/RG + DO k=2,klev + DO i = 1, knon + yzlay(i,k)= & + yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k)) & + /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG + END DO + END DO + + DO k=1,klev + DO i = 1, knon + yteta(i,k)= & + yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**RKAPPA & + *(1.+0.61*yq(i,k)) + END DO + END DO + + yzlev(1:knon,1)=0. + yzlev(1:knon,klev+1)=2.*yzlay(1:knon,klev)-yzlay(1:knon,klev-1) + DO k=2,klev + DO i = 1, knon + yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1)) + END DO + END DO + +!!$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!$! Pour memoire, le papier Hourdin et al. 2002 a ete obtenur avec un +!!$! bug sur les coefficients de surface : +!!$! ycdragh(1:knon) = ycoefm(1:knon,1) +!!$! ycdragm(1:knon) = ycoefh(1:knon,1) +!!$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + CALL ustarhb(knon,yu,yv,ycdragm, yustar) + + IF (prt_level > 9) THEN + WRITE(lunout,*) 'USTAR = ',yustar + ENDIF + +! iflag_pbl peut etre utilise comme longuer de melange + IF (iflag_pbl.GE.11) THEN + CALL vdif_kcay(knon,dtime,RG,RD,ypaprs,yt, & + yzlev,yzlay,yu,yv,yteta, & + ycdragm,yq2,q2diag,ykmm,ykmn,yustar, & + iflag_pbl) + ELSE + CALL yamada4(knon,dtime,RG,RD,ypaprs,yt, & + yzlev,yzlay,yu,yv,yteta, & + ycdragm,yq2,ykmm,ykmn,ykmq,yustar, & + iflag_pbl) + ENDIF + + ycoefm(1:knon,2:klev)=ykmm(1:knon,2:klev) + ycoefh(1:knon,2:klev)=ykmn(1:knon,2:klev) + + ENDIF !(iflag_pbl.ge.3) + + END SUBROUTINE coef_diff_turb +! +!**************************************************************************************** +! + SUBROUTINE coefkz(nsrf, knon, paprs, pplay, & + ksta, ksta_ter, & + ts, rugos, & + u,v,t,q, & + qsurf, & + pcfm, pcfh) + + USE dimphy + +!====================================================================== +! Auteur(s) F. Hourdin, M. Forichon, Z.X. Li (LMD/CNRS) date: 19930922 +! (une version strictement identique a l'ancien modele) +! Objet: calculer le coefficient du frottement du sol (Cdrag) et les +! coefficients d'echange turbulent dans l'atmosphere. +! Arguments: +! nsrf-----input-I- indicateur de la nature du sol +! knon-----input-I- nombre de points a traiter +! paprs----input-R- pregssion a chaque intercouche (en Pa) +! pplay----input-R- pression au milieu de chaque couche (en Pa) +! ts-------input-R- temperature du sol (en Kelvin) +! rugos----input-R- longeur de rugosite (en m) +! u--------input-R- vitesse u +! v--------input-R- vitesse v +! t--------input-R- temperature (K) +! q--------input-R- vapeur d'eau (kg/kg) +! +! pcfm-----output-R- coefficients a calculer (vitesse) +! pcfh-----output-R- coefficients a calculer (chaleur et humidite) +!====================================================================== + INCLUDE "YOETHF.h" + INCLUDE "FCTTRE.h" + INCLUDE "iniprint.h" + INCLUDE "indicesol.h" + INCLUDE "compbl.h" + INCLUDE "YOMCST.h" +! +! Arguments: +! + INTEGER, INTENT(IN) :: knon, nsrf + REAL, INTENT(IN) :: ksta, ksta_ter + REAL, DIMENSION(klon), INTENT(IN) :: ts + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay + REAL, DIMENSION(klon,klev), INTENT(IN) :: u, v, t, q + REAL, DIMENSION(klon), INTENT(IN) :: rugos + REAL, DIMENSION(klon), INTENT(IN) :: qsurf + + REAL, DIMENSION(klon,klev), INTENT(OUT) :: pcfm, pcfh + +! +! Local variables: +! + INTEGER, DIMENSION(klon) :: itop ! numero de couche du sommet de la couche limite +! +! Quelques constantes et options: +! + REAL, PARAMETER :: cepdu2=0.1**2 + REAL, PARAMETER :: CKAP=0.4 + REAL, PARAMETER :: cb=5.0 + REAL, PARAMETER :: cc=5.0 + REAL, PARAMETER :: cd=5.0 + REAL, PARAMETER :: clam=160.0 + REAL, PARAMETER :: ratqs=0.05 ! largeur de distribution de vapeur d'eau + LOGICAL, PARAMETER :: richum=.TRUE. ! utilise le nombre de Richardson humide + REAL, PARAMETER :: ric=0.4 ! nombre de Richardson critique + REAL, PARAMETER :: prandtl=0.4 + REAL kstable ! diffusion minimale (situation stable) + ! GKtest + ! PARAMETER (kstable=1.0e-10) +!IM: 261103 REAL kstable_ter, kstable_sinon +!IM: 211003 cf GK PARAMETER (kstable_ter = 1.0e-6) +!IM: 261103 PARAMETER (kstable_ter = 1.0e-8) +!IM: 261103 PARAMETER (kstable_ter = 1.0e-10) +!IM: 261103 PARAMETER (kstable_sinon = 1.0e-10) + ! fin GKtest + REAL, PARAMETER :: mixlen=35.0 ! constante controlant longueur de melange + INTEGER isommet ! le sommet de la couche limite + LOGICAL, PARAMETER :: tvirtu=.TRUE. ! calculer Ri d'une maniere plus performante + LOGICAL, PARAMETER :: opt_ec=.FALSE.! formule du Centre Europeen dans l'atmosphere + +! +! Variables locales: + INTEGER i, k !IM 120704 + REAL zgeop(klon,klev) + REAL zmgeom(klon) + REAL zri(klon) + REAL zl2(klon) + REAL zdphi, zdu2, ztvd, ztvu, zcdn + REAL zscf + REAL zt, zq, zdelta, zcvm5, zcor, zqs, zfr, zdqs + REAL z2geomf, zalh2, zalm2, zscfh, zscfm + REAL, PARAMETER :: t_coup=273.15 + LOGICAL, PARAMETER :: check=.FALSE. +! +! contre-gradient pour la chaleur sensible: Kelvin/metre + REAL gamt(2:klev) + + LOGICAL, SAVE :: appel1er=.TRUE. + !$OMP THREADPRIVATE(appel1er) +! +! Fonctions thermodynamiques et fonctions d'instabilite + REAL fsta, fins, x + + fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x)) + fins(x) = SQRT(1.0-18.0*x) + + isommet=klev + + IF (appel1er) THEN + IF (prt_level > 9) THEN + WRITE(lunout,*)'coefkz, opt_ec:', opt_ec + WRITE(lunout,*)'coefkz, richum:', richum + IF (richum) WRITE(lunout,*)'coefkz, ratqs:', ratqs + WRITE(lunout,*)'coefkz, isommet:', isommet + WRITE(lunout,*)'coefkz, tvirtu:', tvirtu + appel1er = .FALSE. + ENDIF + ENDIF +! +! Initialiser les sorties +! + DO k = 1, klev + DO i = 1, knon + pcfm(i,k) = 0.0 + pcfh(i,k) = 0.0 + ENDDO + ENDDO + DO i = 1, knon + itop(i) = 0 + ENDDO + +! +! Prescrire la valeur de contre-gradient +! + IF (iflag_pbl.EQ.1) THEN + DO k = 3, klev + gamt(k) = -1.0E-03 + ENDDO + gamt(2) = -2.5E-03 + ELSE + DO k = 2, klev + gamt(k) = 0.0 + ENDDO + ENDIF +!IM cf JLD/ GKtest + IF ( nsrf .NE. is_oce ) THEN +!IM 261103 kstable = kstable_ter + kstable = ksta_ter + ELSE +!IM 261103 kstable = kstable_sinon + kstable = ksta + ENDIF +!IM cf JLD/ GKtest fin + +! +! Calculer les geopotentiels de chaque couche +! + DO i = 1, knon + zgeop(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) & + * (paprs(i,1)-pplay(i,1)) + ENDDO + DO k = 2, klev + DO i = 1, knon + zgeop(i,k) = zgeop(i,k-1) & + + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) & + * (pplay(i,k-1)-pplay(i,k)) + ENDDO + ENDDO + +! +! Calculer les coefficients turbulents dans l'atmosphere +! + DO i = 1, knon + itop(i) = isommet + ENDDO + + + DO k = 2, isommet + DO i = 1, knon + zdu2=MAX(cepdu2,(u(i,k)-u(i,k-1))**2 & + +(v(i,k)-v(i,k-1))**2) + zmgeom(i)=zgeop(i,k)-zgeop(i,k-1) + zdphi =zmgeom(i) / 2.0 + zt = (t(i,k)+t(i,k-1)) * 0.5 + zq = (q(i,k)+q(i,k-1)) * 0.5 + +! +! Calculer Qs et dQs/dT: +! + IF (thermcep) THEN + zdelta = MAX(0.,SIGN(1.,RTT-zt)) + zcvm5 = R5LES*RLVTT/RCPD/(1.0+RVTMP2*zq)*(1.-zdelta) & + + R5IES*RLSTT/RCPD/(1.0+RVTMP2*zq)*zdelta + zqs = R2ES * FOEEW(zt,zdelta) / pplay(i,k) + zqs = MIN(0.5,zqs) + zcor = 1./(1.-RETV*zqs) + zqs = zqs*zcor + zdqs = FOEDE(zt,zdelta,zcvm5,zqs,zcor) + ELSE + IF (zt .LT. t_coup) THEN + zqs = qsats(zt) / pplay(i,k) + zdqs = dqsats(zt,zqs) + ELSE + zqs = qsatl(zt) / pplay(i,k) + zdqs = dqsatl(zt,zqs) + ENDIF + ENDIF +! +! calculer la fraction nuageuse (processus humide): +! + zfr = (zq+ratqs*zq-zqs) / (2.0*ratqs*zq) + zfr = MAX(0.0,MIN(1.0,zfr)) + IF (.NOT.richum) zfr = 0.0 +! +! calculer le nombre de Richardson: +! + IF (tvirtu) THEN + ztvd =( t(i,k) & + + zdphi/RCPD/(1.+RVTMP2*zq) & + *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) & + )*(1.+RETV*q(i,k)) + ztvu =( t(i,k-1) & + - zdphi/RCPD/(1.+RVTMP2*zq) & + *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) & + )*(1.+RETV*q(i,k-1)) + zri(i) =zmgeom(i)*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu)) + zri(i) = zri(i) & + + zmgeom(i)*zmgeom(i)/RG*gamt(k) & + *(paprs(i,k)/101325.0)**RKAPPA & + /(zdu2*0.5*(ztvd+ztvu)) + + ELSE ! calcul de Ridchardson compatible LMD5 + + zri(i) =(RCPD*(t(i,k)-t(i,k-1)) & + -RD*0.5*(t(i,k)+t(i,k-1))/paprs(i,k) & + *(pplay(i,k)-pplay(i,k-1)) & + )*zmgeom(i)/(zdu2*0.5*RCPD*(t(i,k-1)+t(i,k))) + zri(i) = zri(i) + & + zmgeom(i)*zmgeom(i)*gamt(k)/RG & + *(paprs(i,k)/101325.0)**RKAPPA & + /(zdu2*0.5*(t(i,k-1)+t(i,k))) + ENDIF +! +! finalement, les coefficients d'echange sont obtenus: +! + zcdn=SQRT(zdu2) / zmgeom(i) * RG + + IF (opt_ec) THEN + z2geomf=zgeop(i,k-1)+zgeop(i,k) + zalm2=(0.5*ckap/RG*z2geomf & + /(1.+0.5*ckap/rg/clam*z2geomf))**2 + zalh2=(0.5*ckap/rg*z2geomf & + /(1.+0.5*ckap/RG/(clam*SQRT(1.5*cd))*z2geomf))**2 + IF (zri(i).LT.0.0) THEN ! situation instable + zscf = ((zgeop(i,k)/zgeop(i,k-1))**(1./3.)-1.)**3 & + / (zmgeom(i)/RG)**3 / (zgeop(i,k-1)/RG) + zscf = SQRT(-zri(i)*zscf) + zscfm = 1.0 / (1.0+3.0*cb*cc*zalm2*zscf) + zscfh = 1.0 / (1.0+3.0*cb*cc*zalh2*zscf) + pcfm(i,k)=zcdn*zalm2*(1.-2.0*cb*zri(i)*zscfm) + pcfh(i,k)=zcdn*zalh2*(1.-3.0*cb*zri(i)*zscfh) + ELSE ! situation stable + zscf=SQRT(1.+cd*zri(i)) + pcfm(i,k)=zcdn*zalm2/(1.+2.0*cb*zri(i)/zscf) + pcfh(i,k)=zcdn*zalh2/(1.+3.0*cb*zri(i)*zscf) + ENDIF + ELSE + zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,itop(i)+1)) & + /(paprs(i,2)-paprs(i,itop(i)+1)) ))**2 + pcfm(i,k)=SQRT(MAX(zcdn*zcdn*(ric-zri(i))/ric, kstable)) + pcfm(i,k)= zl2(i)* pcfm(i,k) + pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different + ENDIF + ENDDO + ENDDO + +! +! Au-dela du sommet, pas de diffusion turbulente: +! + DO i = 1, knon + IF (itop(i)+1 .LE. klev) THEN + DO k = itop(i)+1, klev + pcfh(i,k) = 0.0 + pcfm(i,k) = 0.0 + ENDDO + ENDIF + ENDDO + + END SUBROUTINE coefkz +! +!**************************************************************************************** +! + SUBROUTINE coefkz2(nsrf, knon, paprs, pplay,t, & + pcfm, pcfh) + + USE dimphy + +!====================================================================== +! J'introduit un peu de diffusion sauf dans les endroits +! ou une forte inversion est presente +! On peut dire qu'il represente la convection peu profonde +! +! Arguments: +! nsrf-----input-I- indicateur de la nature du sol +! knon-----input-I- nombre de points a traiter +! paprs----input-R- pression a chaque intercouche (en Pa) +! pplay----input-R- pression au milieu de chaque couche (en Pa) +! t--------input-R- temperature (K) +! +! pcfm-----output-R- coefficients a calculer (vitesse) +! pcfh-----output-R- coefficients a calculer (chaleur et humidite) +!====================================================================== +! +! Arguments: +! + INTEGER, INTENT(IN) :: knon, nsrf + REAL, DIMENSION(klon, klev+1), INTENT(IN) :: paprs + REAL, DIMENSION(klon, klev), INTENT(IN) :: pplay + REAL, DIMENSION(klon, klev), INTENT(IN) :: t(klon,klev) + + REAL, DIMENSION(klon, klev), INTENT(OUT) :: pcfm, pcfh +! +! Quelques constantes et options: +! + REAL, PARAMETER :: prandtl=0.4 + REAL, PARAMETER :: kstable=0.002 +! REAL, PARAMETER :: kstable=0.001 + REAL, PARAMETER :: mixlen=35.0 ! constante controlant longueur de melange + REAL, PARAMETER :: seuil=-0.02 ! au-dela l'inversion est consideree trop faible +! PARAMETER (seuil=-0.04) +! PARAMETER (seuil=-0.06) +! PARAMETER (seuil=-0.09) + +! +! Variables locales: +! + INTEGER i, k, invb(knon) + REAL zl2(knon) + REAL zdthmin(knon), zdthdp + + INCLUDE "indicesol.h" + INCLUDE "YOMCST.h" +! +! Initialiser les sorties +! + DO k = 1, klev + DO i = 1, knon + pcfm(i,k) = 0.0 + pcfh(i,k) = 0.0 + ENDDO + ENDDO + +! +! Chercher la zone d'inversion forte +! + DO i = 1, knon + invb(i) = klev + zdthmin(i)=0.0 + ENDDO + DO k = 2, klev/2-1 + DO i = 1, knon + zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) & + - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1) + zdthdp = zdthdp * 100.0 + IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. & + zdthdp.LT.zdthmin(i) ) THEN + zdthmin(i) = zdthdp + invb(i) = k + ENDIF + ENDDO + ENDDO + +! +! Introduire une diffusion: +! + IF ( nsrf.EQ.is_oce ) THEN + DO k = 2, klev + DO i = 1, knon +!IM cf FH/GK IF ( (nsrf.NE.is_oce) .OR. ! si ce n'est pas sur l'ocean +!IM cf FH/GK . (invb(i).EQ.klev) .OR. ! s'il n'y a pas d'inversion + !IM cf JLD/ GKtest TERkz2 + ! IF ( (nsrf.EQ.is_ter) .OR. ! si on est sur la terre + ! fin GKtest + + +! s'il n'y a pas d'inversion ou si l'inversion est trop faible +! IF ( (nsrf.EQ.is_oce) .AND. & + IF ( (invb(i).EQ.klev) .OR. (zdthmin(i).GT.seuil) ) THEN + zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,klev+1)) & + /(paprs(i,2)-paprs(i,klev+1)) ))**2 + pcfm(i,k)= zl2(i)* kstable + pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different + ENDIF + ENDDO + ENDDO + ENDIF + + END SUBROUTINE coefkz2 +! +!**************************************************************************************** +! +END MODULE coef_diff_turb_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/coefcdrag.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/coefcdrag.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/coefcdrag.F90 (revision 1280) @@ -0,0 +1,144 @@ +! +! +! + SUBROUTINE coefcdrag (klon, knon, nsrf, zxli, & + speed, t, q, zgeop, psol, & + ts, qsurf, rugos, okri, ri1, & + cdram, cdrah, cdran, zri1, pref) + IMPLICIT none +!------------------------------------------------------------------------- +! Objet : calcul des cdrags pour le moment (cdram) et les flux de chaleur +! sensible et latente (cdrah), du cdrag neutre (cdran), +! du nombre de Richardson entre la surface et le niveau de reference +! (zri1) et de la pression au niveau de reference (pref). +! +! I. Musat, 01.07.2002 +!------------------------------------------------------------------------- +! +! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude) +! knon----input-I- nombre de points pour un type de surface +! nsrf----input-I- indice pour le type de surface; voir indicesol.h +! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li +! speed---input-R- module du vent au 1er niveau du modele +! t-------input-R- temperature de l'air au 1er niveau du modele +! q-------input-R- humidite de l'air au 1er niveau du modele +! zgeop---input-R- geopotentiel au 1er niveau du modele +! psol----input-R- pression au sol +! ts------input-R- temperature de l'air a la surface +! qsurf---input-R- humidite de l'air a la surface +! rugos---input-R- rugosite +! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce +! et zref par rapport au Ri entre la sfce et la 1ere couche +! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche +! +! cdram--output-R- cdrag pour le moment +! cdrah--output-R- cdrag pour les flux de chaleur latente et sensible +! cdran--output-R- cdrag neutre +! zri1---output-R- nb. Richardson entre la surface et la couche zgeop/RG +! pref---output-R- pression au niveau zgeop/RG +! + INTEGER, intent(in) :: klon, knon, nsrf + LOGICAL, intent(in) :: zxli + REAL, dimension(klon), intent(in) :: speed, t, q, zgeop, psol + REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, ri1 + LOGICAL, intent(in) :: okri +! + REAL, dimension(klon), intent(out) :: cdram, cdrah, cdran, zri1, pref +!------------------------------------------------------------------------- +! + include "YOMCST.h" + include "YOETHF.h" + include "indicesol.h" +! Quelques constantes : + REAL, parameter :: RKAR=0.40, CB=5.0, CC=5.0, CD=5.0, cepdu2=(0.1)**2 +! +! Variables locales : + INTEGER :: i + REAL, dimension(klon) :: zdu2, zdphi, ztsolv, ztvd + REAL, dimension(klon) :: zscf, friv, frih, zucf, zcr + REAL, dimension(klon) :: zcfm1, zcfh1 + REAL, dimension(klon) :: zcfm2, zcfh2 + REAL, dimension(klon) :: trm0, trm1 +!------------------------------------------------------------------------- + REAL :: fsta, fins, x + fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x)) + fins(x) = SQRT(1.0-18.0*x) +!------------------------------------------------------------------------- +! + DO i = 1, knon +! + zdphi(i) = zgeop(i) + zdu2(i) = max(cepdu2,speed(i)**2) + pref(i) = exp(log(psol(i)) - zdphi(i)/(RD*t(i)* & + (1.+ RETV * max(q(i),0.0)))) + ztsolv(i) = ts(i) + ztvd(i) = t(i) * (psol(i)/pref(i))**RKAPPA + trm0(i) = 1. + RETV * max(qsurf(i),0.0) + trm1(i) = 1. + RETV * max(q(i),0.0) + ztsolv(i) = ztsolv(i) * trm0(i) + ztvd(i) = ztvd(i) * trm1(i) + zri1(i) = zdphi(i)*(ztvd(i)-ztsolv(i))/(zdu2(i)*ztvd(i)) +! +! on teste zri1 par rapport au Richardson de la 1ere couche ri1 +! +!IM +++ + IF(1.EQ.0) THEN + IF (okri) THEN + IF (ri1(i).GE.0.0.AND.zri1(i).LT.0.0) THEN + zri1(i) = ri1(i) + ELSE IF(ri1(i).LT.0.0.AND.zri1(i).GE.0.0) THEN + zri1(i) = ri1(i) + ENDIF + ENDIF + ENDIF +!IM --- +! + cdran(i) = (RKAR/log(1.+zdphi(i)/(RG*rugos(i))))**2 + + IF (zri1(i) .ge. 0.) THEN +! +! situation stable : pour eviter les inconsistances dans les cas +! tres stables on limite zri1 a 20. cf Hess et al. (1995) +! + zri1(i) = min(20.,zri1(i)) +! + IF (.NOT.zxli) THEN + zscf(i) = SQRT(1.+CD*ABS(zri1(i))) + friv(i) = max(1. / (1.+2.*CB*zri1(i)/ zscf(i)), 0.1) + zcfm1(i) = cdran(i) * friv(i) + frih(i) = max(1./ (1.+3.*CB*zri1(i)*zscf(i)), 0.1 ) + zcfh1(i) = cdran(i) * frih(i) + cdram(i) = zcfm1(i) + cdrah(i) = zcfh1(i) + ELSE + cdram(i) = cdran(i)* fsta(zri1(i)) + cdrah(i) = cdran(i)* fsta(zri1(i)) + ENDIF +! + ELSE +! +! situation instable +! + IF (.NOT.zxli) THEN + zucf(i) = 1./(1.+3.0*CB*CC*cdran(i)*SQRT(ABS(zri1(i)) & + *(1.0+zdphi(i)/(RG*rugos(i))))) + zcfm2(i) = cdran(i)*max((1.-2.0*CB*zri1(i)*zucf(i)),0.1) + zcfh2(i) = cdran(i)*max((1.-3.0*CB*zri1(i)*zucf(i)),0.1) + cdram(i) = zcfm2(i) + cdrah(i) = zcfh2(i) + ELSE + cdram(i) = cdran(i)* fins(zri1(i)) + cdrah(i) = cdran(i)* fins(zri1(i)) + ENDIF +! +! cdrah sur l'ocean cf. Miller et al. (1992) +! + zcr(i) = (0.0016/(cdran(i)*SQRT(zdu2(i))))*ABS(ztvd(i)-ztsolv(i)) & + **(1./3.) + IF (nsrf.EQ.is_oce) cdrah(i) = cdran(i)*(1.0+zcr(i)**1.25) & + **(1./1.25) + ENDIF +! + END DO + RETURN + END SUBROUTINE coefcdrag Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/coefkzmin.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/coefkzmin.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/coefkzmin.F (revision 1280) @@ -0,0 +1,132 @@ +! + SUBROUTINE coefkzmin(knon,ypaprs,ypplay,yu,yv,yt,yq,ycdragm + . ,km,kn) + + USE dimphy + IMPLICIT NONE + + include "YOMCST.h" + +c....................................................................... +c Entrees modifies en attendant une version ou les zlev, et zlay soient +c disponibles. + + REAL ycdragm(klon) + + REAL yu(klon,klev), yv(klon,klev) + REAL yt(klon,klev), yq(klon,klev) + REAL ypaprs(klon,klev+1), ypplay(klon,klev) + REAL yustar(klon) + real yzlay(klon,klev),yzlev(klon,klev+1),yteta(klon,klev) + + integer i + +c....................................................................... +c +c En entree : +c ----------- +c +c zlev : altitude a chaque niveau (interface inferieure de la couche +c de meme indice) +c ustar : u* +c +c teta : temperature potentielle au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c +c en sortier : +c ------------ +c +c km : diffusivite turbulente de quantite de mouvement (au bas de chaque +c couche) +c (en sortie : la valeur a la fin du pas de temps) +c kn : diffusivite turbulente des scalaires (au bas de chaque couche) +c (en sortie : la valeur a la fin du pas de temps) +c +c....................................................................... + + real ustar(klon) + real kmin,qmin,pblhmin(klon),coriol(klon) + REAL zlev(klon,klev+1) + REAL teta(klon,klev) + + REAL km(klon,klev+1) + REAL kn(klon,klev+1) + integer knon + + + integer nlay,nlev + integer ig,k + + real,parameter :: kap=0.4 + + nlay=klev + nlev=klev+1 +c....................................................................... +c en attendant une version ou les zlev, et zlay soient +c disponibles. +c Debut de la partie qui doit etre unclue a terme dans clmain. +c + do i=1,knon + yzlay(i,1)=RD*yt(i,1)/(0.5*(ypaprs(i,1)+ypplay(i,1))) + . *(ypaprs(i,1)-ypplay(i,1))/RG + enddo + do k=2,klev + do i=1,knon + yzlay(i,k)=yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k)) + s /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG + enddo + enddo + do k=1,klev + do i=1,knon +cATTENTION:on passe la temperature potentielle virt. pour le calcul de K + yteta(i,k)=yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**rkappa + s *(1.+0.61*yq(i,k)) + enddo + enddo + do i=1,knon + yzlev(i,1)=0. + yzlev(i,klev+1)=2.*yzlay(i,klev)-yzlay(i,klev-1) + enddo + do k=2,klev + do i=1,knon + yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1)) + enddo + enddo + + yustar(1:knon) =SQRT(ycdragm(1:knon)* + $ (yu(1:knon,1)*yu(1:knon,1)+yv(1:knon,1)*yv(1:knon,1))) + +c Fin de la partie qui doit etre unclue a terme dans clmain. + +Cette routine est ecrite pour avoir en entree ustar, teta et zlev +c Ici, on a inclut le calcul de ces trois variables dans la routine +c coefkzmin en attendant une nouvelle version de la couche limite +c ou ces variables seront disponibles. + +c Debut de la routine coefkzmin proprement dite. + + ustar=yustar + teta=yteta + zlev=yzlev + + do ig=1,knon + coriol(ig)=1.e-4 + pblhmin(ig)=0.07*ustar(ig)/max(abs(coriol(ig)),2.546e-5) + enddo + + do k=2,klev + do ig=1,knon + if (teta(ig,2).gt.teta(ig,1)) then + qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2 + kmin=kap*zlev(ig,k)*qmin + else + kmin=0. ! kmin n'est utilise que pour les SL stables. + endif + kn(ig,k)=kmin + km(ig,k)=kmin + enddo + enddo + + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/comgeomphy.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/comgeomphy.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/comgeomphy.F90 (revision 1280) @@ -0,0 +1,23 @@ +module comgeomphy + real,save,allocatable :: airephy(:) + real,save,allocatable :: cuphy(:) + real,save,allocatable :: cvphy(:) + real,save,allocatable :: rlatd(:) + real,save,allocatable :: rlond(:) +!$OMP THREADPRIVATE(airephy,cuphy,cvphy,rlatd,rlond) +contains + + subroutine InitComgeomphy + USE mod_phys_lmdz_para + implicit none + + + allocate(airephy(klon_omp)) + allocate(cuphy(klon_omp)) + allocate(cvphy(klon_omp)) + allocate(rlatd(klon_omp)) + allocate(rlond(klon_omp)) + + end subroutine InitComgeomphy + +end module comgeomphy Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/comgeomphy.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/comgeomphy.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/comgeomphy.h (revision 1280) @@ -0,0 +1,9 @@ +! +! $Header$ +! +c +c +c Common de passage de la geometrie de la dynamique a la physique + real airephy(klon),cuphy(klon),cvphy(klon) + REAL rlatd(klon), rlond(klon) + common/comgeomphy/airephy,cuphy,cvphy,rlatd, rlond Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/compbl.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/compbl.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/compbl.h (revision 1280) @@ -0,0 +1,6 @@ + ! + ! $Header$ + ! + integer iflag_pbl + common/compbl/iflag_pbl +!$OMP THREADPRIVATE(/compbl/) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/comsoil.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/comsoil.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/comsoil.h (revision 1280) @@ -0,0 +1,7 @@ +! +! $Header$ +! + + common /comsoil/inertie_sol,inertie_sno,inertie_ice + real inertie_sol,inertie_sno,inertie_ice +!$OMP THREADPRIVATE(/comsoil/) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conccm.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conccm.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conccm.F (revision 1280) @@ -0,0 +1,835 @@ +! +! $Header$ +! + SUBROUTINE conccm (dtime,paprs,pplay,t,q,conv_q, + s d_t, d_q, rain, snow, kbascm, ktopcm) +c + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: le 14 mars 1996 +c Objet: Schema simple (avec flux de masse) pour la convection +c (schema standard du modele NCAR CCM2) +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +c +c Entree: + REAL dtime ! pas d'integration + REAL paprs(klon,klev+1) ! pression inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (g/g) + REAL conv_q(klon,klev) ! taux de convergence humidite (g/g/s) +c Sortie: + REAL d_t(klon,klev) ! incrementation temperature + REAL d_q(klon,klev) ! incrementation vapeur + REAL rain(klon) ! pluie (mm/s) + REAL snow(klon) ! neige (mm/s) + INTEGER kbascm(klon) ! niveau du bas de convection + INTEGER ktopcm(klon) ! niveau du haut de convection +c + REAL pt(klon,klev) + REAL pq(klon,klev) + REAL pres(klon,klev) + REAL dp(klon,klev) + REAL zgeom(klon,klev) + REAL cmfprs(klon) + REAL cmfprt(klon) + INTEGER ntop(klon) + INTEGER nbas(klon) + INTEGER i, k + REAL zlvdcp, zlsdcp, zdelta, zz, za, zb +c + LOGICAL usekuo ! utiliser convection profonde (schema Kuo) + PARAMETER (usekuo=.TRUE.) +c + REAL d_t_bis(klon,klev) + REAL d_q_bis(klon,klev) + REAL rain_bis(klon) + REAL snow_bis(klon) + INTEGER ibas_bis(klon) + INTEGER itop_bis(klon) + REAL d_ql_bis(klon,klev) + REAL rneb_bis(klon,klev) +c +c initialiser les variables de sortie (pour securite) + DO i = 1, klon + rain(i) = 0.0 + snow(i) = 0.0 + kbascm(i) = 0 + ktopcm(i) = 0 + ENDDO + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + ENDDO + ENDDO +c +c preparer les variables d'entree (attention: l'ordre des niveaux +c verticaux augmente du haut vers le bas) + DO k = 1, klev + DO i = 1, klon + pt(i,k) = t(i,klev-k+1) + pq(i,k) = q(i,klev-k+1) + pres(i,k) = pplay(i,klev-k+1) + dp(i,k) = paprs(i,klev+1-k)-paprs(i,klev+1-k+1) + ENDDO + ENDDO + DO i = 1, klon + zgeom(i,klev) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) + . * (paprs(i,1)-pplay(i,1)) + ENDDO + DO k = 2, klev + DO i = 1, klon + zgeom(i,klev+1-k) = zgeom(i,klev+1-k+1) + . + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) + . * (pplay(i,k-1)-pplay(i,k)) + ENDDO + ENDDO +c + CALL cmfmca(dtime, pres, dp, zgeom, pt, pq, + $ cmfprt, cmfprs, ntop, nbas) +C + DO k = 1, klev + DO i = 1, klon + d_q(i,klev+1-k) = pq(i,k) - q(i,klev+1-k) + d_t(i,klev+1-k) = pt(i,k) - t(i,klev+1-k) + ENDDO + ENDDO +c + DO i = 1, klon + rain(i) = cmfprt(i) * rhoh2o + snow(i) = cmfprs(i) * rhoh2o + kbascm(i) = klev+1 - nbas(i) + ktopcm(i) = klev+1 - ntop(i) + ENDDO +c + IF (usekuo) THEN + CALL conkuo(dtime, paprs, pplay, t, q, conv_q, + s d_t_bis, d_q_bis, d_ql_bis, rneb_bis, + s rain_bis, snow_bis, ibas_bis, itop_bis) + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = d_t(i,k) + d_t_bis(i,k) + d_q(i,k) = d_q(i,k) + d_q_bis(i,k) + ENDDO + ENDDO + DO i = 1, klon + rain(i) = rain(i) + rain_bis(i) + snow(i) = snow(i) + snow_bis(i) + kbascm(i) = MIN(kbascm(i),ibas_bis(i)) + ktopcm(i) = MAX(ktopcm(i),itop_bis(i)) + ENDDO + DO k = 1, klev ! eau liquide convective est + DO i = 1, klon ! dispersee dans l'air + zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q(i,k)) + zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q(i,k)) + zdelta = MAX(0.,SIGN(1.,RTT-t(i,k))) + zz = d_ql_bis(i,k) ! re-evap. de l'eau liquide + zb = MAX(0.0,zz) + za = - MAX(0.0,zz) * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta) + d_t(i,k) = d_t(i,k) + za + d_q(i,k) = d_q(i,k) + zb + ENDDO + ENDDO + ENDIF +c + RETURN + END + SUBROUTINE cmfmca(deltat, p, dp, gz, + $ tb, shb, + $ cmfprt, cmfprs, cnt, cnb) + USE dimphy + IMPLICIT none +C----------------------------------------------------------------------- +C Moist convective mass flux procedure: +C If stratification is unstable to nonentraining parcel ascent, +C complete an adjustment making use of a simple cloud model +C +C Code generalized to allow specification of parcel ("updraft") +C properties, as well as convective transport of an arbitrary +C number of passive constituents (see cmrb array). +C----------------------------Code History------------------------------- +C Original version: J. J. Hack, March 22, 1990 +C Standardized: J. Rosinski, June 1992 +C Reviewed: J. Hack, G. Taylor, August 1992 +c Adaptation au LMD: Z.X. Li, mars 1996 (reference: Hack 1994, +c J. Geophys. Res. vol 99, D3, 5551-5568). J'ai +c introduit les constantes et les fonctions thermo- +c dynamiques du Centre Europeen. J'ai elimine le +c re-indicage du code en esperant que cela pourra +c simplifier la lecture et la comprehension. +C----------------------------------------------------------------------- +cym#include "dimensions.h" +cym#include "dimphy.h" + INTEGER pcnst ! nombre de traceurs passifs + PARAMETER (pcnst=1) +C------------------------------Arguments-------------------------------- +C Input arguments +C + REAL deltat ! time step (seconds) + REAL p(klon,klev) ! pressure + REAL dp(klon,klev) ! delta-p + REAL gz(klon,klev) ! geopotential (a partir du sol) +c + REAL thtap(klon) ! PBL perturbation theta + REAL shp(klon) ! PBL perturbation specific humidity + REAL pblh(klon) ! PBL height (provided by PBL routine) + REAL cmrp(klon,pcnst) ! constituent perturbations in PBL +c +c Updated arguments: +c + REAL tb(klon,klev) ! temperature (t bar) + REAL shb(klon,klev) ! specific humidity (sh bar) + REAL cmrb(klon,klev,pcnst) ! constituent mixing ratios (cmr bar) +C +C Output arguments +C + REAL cmfdt(klon,klev) ! dT/dt due to moist convection + REAL cmfdq(klon,klev) ! dq/dt due to moist convection + REAL cmfmc(klon,klev ) ! moist convection cloud mass flux + REAL cmfdqr(klon,klev) ! dq/dt due to convective rainout + REAL cmfsl(klon,klev ) ! convective lw static energy flux + REAL cmflq(klon,klev ) ! convective total water flux + REAL cmfprt(klon) ! convective precipitation rate + REAL cmfprs(klon) ! convective snowfall rate + REAL qc(klon,klev) ! dq/dt due to rainout terms + INTEGER cnt(klon) ! top level of convective activity + INTEGER cnb(klon) ! bottom level of convective activity +C------------------------------Parameters------------------------------- + REAL c0 ! rain water autoconversion coefficient + PARAMETER (c0=1.0e-4) + REAL dzmin ! minimum convective depth for precipitation + PARAMETER (dzmin=0.0) + REAL betamn ! minimum overshoot parameter + PARAMETER (betamn=0.10) + REAL cmftau ! characteristic adjustment time scale + PARAMETER (cmftau=3600.) + INTEGER limcnv ! top interface level limit for convection + PARAMETER (limcnv=1) + REAL tpmax ! maximum acceptable t perturbation (degrees C) + PARAMETER (tpmax=1.50) + REAL shpmax ! maximum acceptable q perturbation (g/g) + PARAMETER (shpmax=1.50e-3) + REAL tiny ! arbitrary small num used in transport estimates + PARAMETER (tiny=1.0e-36) + REAL eps ! convergence criteria (machine dependent) + PARAMETER (eps=1.0e-13) + REAL tmelt ! freezing point of water(req'd for rain vs snow) + PARAMETER (tmelt=273.15) + REAL ssfac ! supersaturation bound (detrained air) + PARAMETER (ssfac=1.001) +C +C---------------------------Local workspace----------------------------- + REAL gam(klon,klev) ! L/cp (d(qsat)/dT) + REAL sb(klon,klev) ! dry static energy (s bar) + REAL hb(klon,klev) ! moist static energy (h bar) + REAL shbs(klon,klev) ! sat. specific humidity (sh bar star) + REAL hbs(klon,klev) ! sat. moist static energy (h bar star) + REAL shbh(klon,klev+1) ! specific humidity on interfaces + REAL sbh(klon,klev+1) ! s bar on interfaces + REAL hbh(klon,klev+1) ! h bar on interfaces + REAL cmrh(klon,klev+1) ! interface constituent mixing ratio + REAL prec(klon) ! instantaneous total precipitation + REAL dzcld(klon) ! depth of convective layer (m) + REAL beta(klon) ! overshoot parameter (fraction) + REAL betamx ! local maximum on overshoot + REAL eta(klon) ! convective mass flux (kg/m^2 s) + REAL etagdt ! eta*grav*deltat + REAL cldwtr(klon) ! cloud water (mass) + REAL rnwtr(klon) ! rain water (mass) + REAL sc (klon) ! dry static energy ("in-cloud") + REAL shc (klon) ! specific humidity ("in-cloud") + REAL hc (klon) ! moist static energy ("in-cloud") + REAL cmrc(klon) ! constituent mix rat ("in-cloud") + REAL dq1(klon) ! shb convective change (lower lvl) + REAL dq2(klon) ! shb convective change (mid level) + REAL dq3(klon) ! shb convective change (upper lvl) + REAL ds1(klon) ! sb convective change (lower lvl) + REAL ds2(klon) ! sb convective change (mid level) + REAL ds3(klon) ! sb convective change (upper lvl) + REAL dcmr1(klon) ! cmrb convective change (lower lvl) + REAL dcmr2(klon) ! cmrb convective change (mid level) + REAL dcmr3(klon) ! cmrb convective change (upper lvl) + REAL flotab(klon) ! hc - hbs (mesure d'instabilite) + LOGICAL ldcum(klon) ! .true. si la convection existe + LOGICAL etagt0 ! true if eta > 0.0 + REAL dt ! current 2 delta-t (model time step) + REAL cats ! modified characteristic adj. time + REAL rdt ! 1./dt + REAL qprime ! modified specific humidity pert. + REAL tprime ! modified thermal perturbation + REAL pblhgt ! bounded pbl height (max[pblh,1m]) + REAL fac1 ! intermediate scratch variable + REAL shprme ! intermediate specific humidity pert. + REAL qsattp ! saturation mixing ratio for +C ! thermally perturbed PBL parcels + REAL dz ! local layer depth + REAL b1 ! bouyancy measure in detrainment lvl + REAL b2 ! bouyancy measure in condensation lvl + REAL g ! bounded vertical gradient of hb + REAL tmass ! total mass available for convective exchange + REAL denom ! intermediate scratch variable + REAL qtest1! used in negative q test (middle lvl) + REAL qtest2! used in negative q test (lower lvl) + REAL fslkp ! flux lw static energy (bot interface) + REAL fslkm ! flux lw static energy (top interface) + REAL fqlkp ! flux total water (bottom interface) + REAL fqlkm ! flux total water (top interface) + REAL botflx! bottom constituent mixing ratio flux + REAL topflx! top constituent mixing ratio flux + REAL efac1 ! ratio cmrb to convectively induced change (bot lvl) + REAL efac2 ! ratio cmrb to convectively induced change (mid lvl) + REAL efac3 ! ratio cmrb to convectively induced change (top lvl) +c + INTEGER i,k ! indices horizontal et vertical + INTEGER km1 ! k-1 (index offset) + INTEGER kp1 ! k+1 (index offset) + INTEGER m ! constituent index + INTEGER ktp ! temporary index used to track top + INTEGER is ! nombre de points a ajuster +C + REAL tmp1, tmp2, tmp3, tmp4 + REAL zx_t, zx_p, zx_q, zx_qs, zx_gam + REAL zcor, zdelta, zcvm5 +C + REAL qhalf, sh1, sh2, shbs1, shbs2 +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" + qhalf(sh1,sh2,shbs1,shbs2) = MIN(MAX(sh1,sh2), + $ (shbs2*sh1 + shbs1*sh2)/(shbs1+shbs2)) +C +C----------------------------------------------------------------------- +c pas de traceur pour l'instant + DO m = 1, pcnst + DO k = 1, klev + DO i = 1, klon + cmrb(i,k,m) = 0.0 + ENDDO + ENDDO + ENDDO +c +c Les perturbations de la couche limite sont zero pour l'instant +c + DO m = 1, pcnst + DO i = 1, klon + cmrp(i,m) = 0.0 + ENDDO + ENDDO + DO i = 1, klon + thtap(i) = 0.0 + shp(i) = 0.0 + pblh(i) = 1.0 + ENDDO +C +C Ensure that characteristic adjustment time scale (cmftau) assumed +C in estimate of eta isn't smaller than model time scale (deltat) +C + dt = deltat + cats = MAX(dt,cmftau) + rdt = 1.0/dt +C +C Compute sb,hb,shbs,hbs +C + DO k = 1, klev + DO i = 1, klon + zx_t = tb(i,k) + zx_p = p(i,k) + zx_q = shb(i,k) + zdelta=MAX(0.,SIGN(1.,RTT-zx_t)) + zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta + zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q) + zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p + zx_qs=MIN(0.5,zx_qs) + zcor=1./(1.-retv*zx_qs) + zx_qs=zx_qs*zcor + zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor) + shbs(i,k) = zx_qs + gam(i,k) = zx_gam + ENDDO + ENDDO +C + DO k=limcnv,klev + DO i=1,klon + sb (i,k) = RCPD*tb(i,k) + gz(i,k) + hb (i,k) = sb(i,k) + RLVTT*shb(i,k) + hbs(i,k) = sb(i,k) + RLVTT*shbs(i,k) + ENDDO + ENDDO +C +C Compute sbh, shbh +C + DO k=limcnv+1,klev + km1 = k - 1 + DO i=1,klon + sbh (i,k) =0.5*(sb(i,km1) + sb(i,k)) + shbh(i,k) =qhalf(shb(i,km1),shb(i,k),shbs(i,km1),shbs(i,k)) + hbh (i,k) =sbh(i,k) + RLVTT*shbh(i,k) + ENDDO + ENDDO +C +C Specify properties at top of model (not used, but filling anyway) +C + DO i=1,klon + sbh (i,limcnv) = sb(i,limcnv) + shbh(i,limcnv) = shb(i,limcnv) + hbh (i,limcnv) = hb(i,limcnv) + ENDDO +C +C Zero vertically independent control, tendency & diagnostic arrays +C + DO i=1,klon + prec(i) = 0.0 + dzcld(i) = 0.0 + cnb(i) = 0 + cnt(i) = klev+1 + ENDDO + + DO k = 1, klev + DO i = 1,klon + cmfdt(i,k) = 0. + cmfdq(i,k) = 0. + cmfdqr(i,k) = 0. + cmfmc(i,k) = 0. + cmfsl(i,k) = 0. + cmflq(i,k) = 0. + ENDDO + ENDDO +C +C Begin moist convective mass flux adjustment procedure. +C Formalism ensures that negative cloud liquid water can never occur +C + DO 70 k=klev-1,limcnv+1,-1 + km1 = k - 1 + kp1 = k + 1 + DO 10 i=1,klon + eta (i) = 0.0 + beta (i) = 0.0 + ds1 (i) = 0.0 + ds2 (i) = 0.0 + ds3 (i) = 0.0 + dq1 (i) = 0.0 + dq2 (i) = 0.0 + dq3 (i) = 0.0 +C +C Specification of "cloud base" conditions +C + qprime = 0.0 + tprime = 0.0 +C +C Assign tprime within the PBL to be proportional to the quantity +C thtap (which will be bounded by tpmax), passed to this routine by +C the PBL routine. Don't allow perturbation to produce a dry +C adiabatically unstable parcel. Assign qprime within the PBL to be +C an appropriately modified value of the quantity shp (which will be +C bounded by shpmax) passed to this routine by the PBL routine. The +C quantity qprime should be less than the local saturation value +C (qsattp=qsat[t+tprime,p]). In both cases, thtap and shp are +C linearly reduced toward zero as the PBL top is approached. +C + pblhgt = MAX(pblh(i),1.0) + IF (gz(i,kp1)/RG.LE.pblhgt .AND. dzcld(i).EQ.0.0) THEN + fac1 = MAX(0.0,1.0-gz(i,kp1)/RG/pblhgt) + tprime = MIN(thtap(i),tpmax)*fac1 + qsattp = shbs(i,kp1) + RCPD/RLVTT*gam(i,kp1)*tprime + shprme = MIN(MIN(shp(i),shpmax)*fac1, + $ MAX(qsattp-shb(i,kp1),0.0)) + qprime = MAX(qprime,shprme) + ELSE + tprime = 0.0 + qprime = 0.0 + ENDIF +C +C Specify "updraft" (in-cloud) thermodynamic properties +C + sc (i) = sb (i,kp1) + RCPD*tprime + shc(i) = shb(i,kp1) + qprime + hc (i) = sc (i ) + RLVTT*shc(i) + flotab(i) = hc(i) - hbs(i,k) + dz = dp(i,k)*RD*tb(i,k)/RG/p(i,k) + IF (flotab(i).gt.0.0) THEN + dzcld(i) = dzcld(i) + dz + ELSE + dzcld(i) = 0.0 + ENDIF + 10 CONTINUE +C +C Check on moist convective instability +C + is = 0 + DO i = 1, klon + IF (flotab(i).GT.0.0) THEN + ldcum(i) = .TRUE. + is = is + 1 + ELSE + ldcum(i) = .FALSE. + ENDIF + ENDDO +C + IF (is.EQ.0) THEN + DO i=1,klon + dzcld(i) = 0.0 + ENDDO + GOTO 70 + ENDIF +C +C Current level just below top level => no overshoot +C + IF (k.le.limcnv+1) THEN + DO i=1,klon + IF (ldcum(i)) THEN + cldwtr(i) = sb(i,k)-sc(i)+flotab(i)/(1.0+gam(i,k)) + cldwtr(i) = MAX(0.0,cldwtr(i)) + beta(i) = 0.0 + ENDIF + ENDDO + GOTO 20 + ENDIF +C +C First guess at overshoot parameter using crude buoyancy closure +C 10% overshoot assumed as a minimum and 1-c0*dz maximum to start +C If pre-existing supersaturation in detrainment layer, beta=0 +C cldwtr is temporarily equal to RLVTT*l (l=> liquid water) +C + DO i=1,klon + IF (ldcum(i)) THEN + cldwtr(i) = sb(i,k)-sc(i)+flotab(i)/(1.0+gam(i,k)) + cldwtr(i) = MAX(0.0,cldwtr(i)) + betamx = 1.0 - c0*MAX(0.0,(dzcld(i)-dzmin)) + b1 = (hc(i) - hbs(i,km1))*dp(i,km1) + b2 = (hc(i) - hbs(i,k ))*dp(i,k ) + beta(i) = MAX(betamn,MIN(betamx, 1.0+b1/b2)) + IF (hbs(i,km1).le.hb(i,km1)) beta(i) = 0.0 + ENDIF + ENDDO +C +C Bound maximum beta to ensure physically realistic solutions +C +C First check constrains beta so that eta remains positive +C (assuming that eta is already positive for beta equal zero) +c La premiere contrainte de beta est que le flux eta doit etre positif. +C + DO i=1,klon + IF (ldcum(i)) THEN + tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i)) + $ - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1) + tmp2 = (1.0+gam(i,k))*(sc(i)-sbh(i,k)) + IF ((beta(i)*tmp2-tmp1).GT.0.0) THEN + betamx = 0.99*(tmp1/tmp2) + beta(i) = MAX(0.0,MIN(betamx,beta(i))) + ENDIF +C +C Second check involves supersaturation of "detrainment layer" +C small amount of supersaturation acceptable (by ssfac factor) +c La 2e contrainte est que la convection ne doit pas sursaturer +c la "detrainment layer", Neanmoins, une petite sursaturation +c est acceptee (facteur ssfac). +C + IF (hb(i,km1).lt.hbs(i,km1)) THEN + tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i)) + $ - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1) + tmp1 = tmp1/dp(i,k) + tmp2 = gam(i,km1)*(sbh(i,k)-sc(i) + cldwtr(i)) - + $ hbh(i,k) + hc(i) - sc(i) + sbh(i,k) + tmp3 = (1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i,k) + tmp4 = (dt/cats)*(hc(i)-hbs(i,k))*tmp2 + $ / (dp(i,km1)*(hbs(i,km1)-hb(i,km1))) + tmp3 + IF ((beta(i)*tmp4-tmp1).GT.0.0) THEN + betamx = ssfac*(tmp1/tmp4) + beta(i) = MAX(0.0,MIN(betamx,beta(i))) + ENDIF + ELSE + beta(i) = 0.0 + ENDIF +C +C Third check to avoid introducing 2 delta x thermodynamic +C noise in the vertical ... constrain adjusted h (or theta e) +C so that the adjustment doesn't contribute to "kinks" in h +C + g = MIN(0.0,hb(i,k)-hb(i,km1)) + tmp3 = (hb(i,k)-hb(i,km1)-g)*(cats/dt) / (hc(i)-hbs(i,k)) + tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i)) + $ - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1) + tmp1 = tmp1/dp(i,k) + tmp1 = tmp3*tmp1 + (hc(i) - hbh(i,kp1))/dp(i,k) + tmp2 = tmp3*(1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i,k) + $ + (hc(i)-hbh(i,k)-cldwtr(i)) + $ *(1.0/dp(i,k)+1.0/dp(i,kp1)) + IF ((beta(i)*tmp2-tmp1).GT.0.0) THEN + betamx = 0.0 + IF (tmp2.NE.0.0) betamx = tmp1/tmp2 + beta(i) = MAX(0.0,MIN(betamx,beta(i))) + ENDIF + ENDIF + ENDDO +C +C Calculate mass flux required for stabilization. +C +C Ensure that the convective mass flux, eta, is positive by +C setting negative values of eta to zero.. +C Ensure that estimated mass flux cannot move more than the +C minimum of total mass contained in either layer k or layer k+1. +C Also test for other pathological cases that result in non- +C physical states and adjust eta accordingly. +C + 20 CONTINUE + DO i=1,klon + IF (ldcum(i)) THEN + beta(i) = MAX(0.0,beta(i)) + tmp1 = hc(i) - hbs(i,k) + tmp2 = ((1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i)) - + $ beta(i)*(1.0+gam(i,k))*(sc(i)-sbh(i,k)))/dp(i,k) - + $ (hbh(i,kp1)-hc(i))/dp(i,kp1) + eta(i) = tmp1/(tmp2*RG*cats) + tmass = MIN(dp(i,k),dp(i,kp1))/RG + IF (eta(i).GT.tmass*rdt .OR. eta(i).LE.0.0) eta(i) = 0.0 +C +C Check on negative q in top layer (bound beta) +C + IF(shc(i)-shbh(i,k).LT.0.0 .AND. beta(i)*eta(i).NE.0.0)THEN + denom = eta(i)*RG*dt*(shc(i) - shbh(i,k))/dp(i,km1) + beta(i) = MAX(0.0,MIN(-0.999*shb(i,km1)/denom,beta(i))) + ENDIF +C +C Check on negative q in middle layer (zero eta) +C + qtest1 = shb(i,k) + eta(i)*RG*dt*((shc(i) - shbh(i,kp1)) - + $ (1.0 - beta(i))*cldwtr(i)/RLVTT - + $ beta(i)*(shc(i) - shbh(i,k)))/dp(i,k) + IF (qtest1.le.0.0) eta(i) = 0.0 +C +C Check on negative q in lower layer (bound eta) +C + fac1 = -(shbh(i,kp1) - shc(i))/dp(i,kp1) + qtest2 = shb(i,kp1) - eta(i)*RG*dt*fac1 + IF (qtest2 .lt. 0.0) THEN + eta(i) = 0.99*shb(i,kp1)/(RG*dt*fac1) + ENDIF + ENDIF + ENDDO +C +C +C Calculate cloud water, rain water, and thermodynamic changes +C + DO 30 i=1,klon + IF (ldcum(i)) THEN + etagdt = eta(i)*RG*dt + cldwtr(i) = etagdt*cldwtr(i)/RLVTT/RG + rnwtr(i) = (1.0 - beta(i))*cldwtr(i) + ds1(i) = etagdt*(sbh(i,kp1) - sc(i))/dp(i,kp1) + dq1(i) = etagdt*(shbh(i,kp1) - shc(i))/dp(i,kp1) + ds2(i) = (etagdt*(sc(i) - sbh(i,kp1)) + + $ RLVTT*RG*cldwtr(i) - beta(i)*etagdt* + $ (sc(i) - sbh(i,k)))/dp(i,k) + dq2(i) = (etagdt*(shc(i) - shbh(i,kp1)) - + $ RG*rnwtr(i) - beta(i)*etagdt* + $ (shc(i) - shbh(i,k)))/dp(i,k) + ds3(i) = beta(i)*(etagdt*(sc(i) - sbh(i,k)) - + $ RLVTT*RG*cldwtr(i))/dp(i,km1) + dq3(i) = beta(i)*etagdt*(shc(i) - shbh(i,k))/dp(i,km1) +C +C Isolate convective fluxes for later diagnostics +C + fslkp = eta(i)*(sc(i) - sbh(i,kp1)) + fslkm = beta(i)*(eta(i)*(sc(i) - sbh(i,k)) - + $ RLVTT*cldwtr(i)*rdt) + fqlkp = eta(i)*(shc(i) - shbh(i,kp1)) + fqlkm = beta(i)*eta(i)*(shc(i) - shbh(i,k)) +C +C +C Update thermodynamic profile (update sb, hb, & hbs later) +C + tb (i,kp1) = tb(i,kp1) + ds1(i) / RCPD + tb (i,k ) = tb(i,k ) + ds2(i) / RCPD + tb (i,km1) = tb(i,km1) + ds3(i) / RCPD + shb(i,kp1) = shb(i,kp1) + dq1(i) + shb(i,k ) = shb(i,k ) + dq2(i) + shb(i,km1) = shb(i,km1) + dq3(i) + prec(i) = prec(i) + rnwtr(i)/rhoh2o +C +C Update diagnostic information for final budget +C Tracking temperature & specific humidity tendencies, +C rainout term, convective mass flux, convective liquid +C water static energy flux, and convective total water flux +C + cmfdt (i,kp1) = cmfdt (i,kp1) + ds1(i)/RCPD*rdt + cmfdt (i,k ) = cmfdt (i,k ) + ds2(i)/RCPD*rdt + cmfdt (i,km1) = cmfdt (i,km1) + ds3(i)/RCPD*rdt + cmfdq (i,kp1) = cmfdq (i,kp1) + dq1(i)*rdt + cmfdq (i,k ) = cmfdq (i,k ) + dq2(i)*rdt + cmfdq (i,km1) = cmfdq (i,km1) + dq3(i)*rdt + cmfdqr(i,k ) = cmfdqr(i,k ) + (RG*rnwtr(i)/dp(i,k))*rdt + cmfmc (i,kp1) = cmfmc (i,kp1) + eta(i) + cmfmc (i,k ) = cmfmc (i,k ) + beta(i)*eta(i) + cmfsl (i,kp1) = cmfsl (i,kp1) + fslkp + cmfsl (i,k ) = cmfsl (i,k ) + fslkm + cmflq (i,kp1) = cmflq (i,kp1) + RLVTT*fqlkp + cmflq (i,k ) = cmflq (i,k ) + RLVTT*fqlkm + qc (i,k ) = (RG*rnwtr(i)/dp(i,k))*rdt + ENDIF + 30 CONTINUE +C +C Next, convectively modify passive constituents +C + DO 50 m=1,pcnst + DO 40 i=1,klon + IF (ldcum(i)) THEN +C +C If any of the reported values of the constituent is negative in +C the three adjacent levels, nothing will be done to the profile +C + IF ((cmrb(i,kp1,m).LT.0.0) .OR. + $ (cmrb(i,k,m).LT.0.0) .OR. + $ (cmrb(i,km1,m).LT.0.0)) GOTO 40 +C +C Specify constituent interface values (linear interpolation) +C + cmrh(i,k ) = 0.5*(cmrb(i,km1,m) + cmrb(i,k ,m)) + cmrh(i,kp1) = 0.5*(cmrb(i,k ,m) + cmrb(i,kp1,m)) +C +C Specify perturbation properties of constituents in PBL +C + pblhgt = MAX(pblh(i),1.0) + IF (gz(i,kp1)/RG.LE.pblhgt .AND. dzcld(i).EQ.0.) THEN + fac1 = MAX(0.0,1.0-gz(i,kp1)/RG/pblhgt) + cmrc(i) = cmrb(i,kp1,m) + cmrp(i,m)*fac1 + ELSE + cmrc(i) = cmrb(i,kp1,m) + ENDIF +C +C Determine fluxes, flux divergence => changes due to convection +C Logic must be included to avoid producing negative values. A bit +C messy since there are no a priori assumptions about profiles. +C Tendency is modified (reduced) when pending disaster detected. +C + etagdt = eta(i)*RG*dt + botflx = etagdt*(cmrc(i) - cmrh(i,kp1)) + topflx = beta(i)*etagdt*(cmrc(i)-cmrh(i,k)) + dcmr1(i) = -botflx/dp(i,kp1) + efac1 = 1.0 + efac2 = 1.0 + efac3 = 1.0 +C + IF (cmrb(i,kp1,m)+dcmr1(i) .LT. 0.0) THEN + efac1 = MAX(tiny,ABS(cmrb(i,kp1,m)/dcmr1(i)) - eps) + ENDIF +C + IF (efac1.EQ.tiny .OR. efac1.GT.1.0) efac1 = 0.0 + dcmr1(i) = -efac1*botflx/dp(i,kp1) + dcmr2(i) = (efac1*botflx - topflx)/dp(i,k) +C + IF (cmrb(i,k,m)+dcmr2(i) .LT. 0.0) THEN + efac2 = MAX(tiny,ABS(cmrb(i,k ,m)/dcmr2(i)) - eps) + ENDIF +C + IF (efac2.EQ.tiny .OR. efac2.GT.1.0) efac2 = 0.0 + dcmr2(i) = (efac1*botflx - efac2*topflx)/dp(i,k) + dcmr3(i) = efac2*topflx/dp(i,km1) +C + IF (cmrb(i,km1,m)+dcmr3(i) .LT. 0.0) THEN + efac3 = MAX(tiny,ABS(cmrb(i,km1,m)/dcmr3(i)) - eps) + ENDIF +C + IF (efac3.EQ.tiny .OR. efac3.GT.1.0) efac3 = 0.0 + efac3 = MIN(efac2,efac3) + dcmr2(i) = (efac1*botflx - efac3*topflx)/dp(i,k) + dcmr3(i) = efac3*topflx/dp(i,km1) +C + cmrb(i,kp1,m) = cmrb(i,kp1,m) + dcmr1(i) + cmrb(i,k ,m) = cmrb(i,k ,m) + dcmr2(i) + cmrb(i,km1,m) = cmrb(i,km1,m) + dcmr3(i) + ENDIF + 40 CONTINUE + 50 CONTINUE ! end of m=1,pcnst loop +C + IF (k.EQ.limcnv+1) GOTO 60 ! on ne pourra plus glisser +c +c Dans la procedure de glissage ascendant, les variables thermo- +c dynamiques des couches k et km1 servent au calcul des couches +c superieures. Elles ont donc besoin d'une mise-a-jour. +C + DO i = 1, klon + IF (ldcum(i)) THEN + zx_t = tb(i,k) + zx_p = p(i,k) + zx_q = shb(i,k) + zdelta=MAX(0.,SIGN(1.,RTT-zx_t)) + zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta + zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q) + zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p + zx_qs=MIN(0.5,zx_qs) + zcor=1./(1.-retv*zx_qs) + zx_qs=zx_qs*zcor + zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor) + shbs(i,k) = zx_qs + gam(i,k) = zx_gam +c + zx_t = tb(i,km1) + zx_p = p(i,km1) + zx_q = shb(i,km1) + zdelta=MAX(0.,SIGN(1.,RTT-zx_t)) + zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta + zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q) + zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p + zx_qs=MIN(0.5,zx_qs) + zcor=1./(1.-retv*zx_qs) + zx_qs=zx_qs*zcor + zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor) + shbs(i,km1) = zx_qs + gam(i,km1) = zx_gam +C + sb (i,k ) = sb(i,k ) + ds2(i) + sb (i,km1) = sb(i,km1) + ds3(i) + hb (i,k ) = sb(i,k ) + RLVTT*shb(i,k) + hb (i,km1) = sb(i,km1) + RLVTT*shb(i,km1) + hbs(i,k ) = sb(i,k ) + RLVTT*shbs(i,k ) + hbs(i,km1) = sb(i,km1) + RLVTT*shbs(i,km1) +C + sbh (i,k) = 0.5*(sb(i,k) + sb(i,km1)) + shbh(i,k) = qhalf(shb(i,km1),shb(i,k) + $ ,shbs(i,km1),shbs(i,k)) + hbh (i,k) = sbh(i,k) + RLVTT*shbh(i,k) + sbh (i,km1) = 0.5*(sb(i,km1) + sb(i,k-2)) + shbh(i,km1) = qhalf(shb(i,k-2),shb(i,km1), + $ shbs(i,k-2),shbs(i,km1)) + hbh (i,km1) = sbh(i,km1) + RLVTT*shbh(i,km1) + ENDIF + ENDDO +C +C Ensure that dzcld is reset if convective mass flux zero +C specify the current vertical extent of the convective activity +C top of convective layer determined by size of overshoot param. +C + 60 CONTINUE + DO i=1,klon + etagt0 = eta(i).gt.0.0 + IF (.not.etagt0) dzcld(i) = 0.0 + IF (etagt0 .and. beta(i).gt.betamn) THEN + ktp = km1 + ELSE + ktp = k + ENDIF + IF (etagt0) THEN + cnt(i) = MIN(cnt(i),ktp) + cnb(i) = MAX(cnb(i),k) + ENDIF + ENDDO + 70 CONTINUE ! end of k loop +C +C determine whether precipitation, prec, is frozen (snow) or not +C + DO i=1,klon + IF (tb(i,klev).LT.tmelt .AND. tb(i,klev-1).lt.tmelt) THEN + cmfprs(i) = prec(i)*rdt + ELSE + cmfprt(i) = prec(i)*rdt + ENDIF + ENDDO +C + RETURN ! we're all done ... return to calling procedure + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/concvl.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/concvl.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/concvl.F (revision 1280) @@ -0,0 +1,457 @@ + +! +! $Header$ +! + SUBROUTINE concvl (iflag_con,iflag_clos, + . dtime,paprs,pplay, + . t,q,t_wake,q_wake,s_wake,u,v,tra,ntra, + . ALE,ALP,work1,work2, + . d_t,d_q,d_u,d_v,d_tra, + . rain, snow, kbas, ktop, sigd, + . upwd,dnwd,dnwdbis,Ma,mip,Vprecip, + . cape,cin,tvp,Tconv,iflag, + . pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr, + . qcondc,wd,pmflxr,pmflxs, + . da,phi,mp,dd_t,dd_q,lalim_conv,wght_th) +*************************************************************** +* * +* CONCVL * +* * +* * +* written by : Sandrine Bony-Lena, 17/05/2003, 11.16.04 * +* modified by : * +*************************************************************** +* +c + USE dimphy + USE infotrac, ONLY : nbtr + IMPLICIT none +c====================================================================== +c Auteur(s): S. Bony-Lena (LMD/CNRS) date: ??? +c Objet: schema de convection de Emanuel (1991) interface +c====================================================================== +c Arguments: +c dtime--input-R-pas d'integration (s) +c s-------input-R-la valeur "s" pour chaque couche +c sigs----input-R-la valeur "sigma" de chaque couche +c sig-----input-R-la valeur de "sigma" pour chaque niveau +c psolpa--input-R-la pression au sol (en Pa) +C pskapa--input-R-exponentiel kappa de psolpa +c h-------input-R-enthalpie potentielle (Cp*T/P**kappa) +c q-------input-R-vapeur d'eau (en kg/kg) +c +c work*: input et output: deux variables de travail, +c on peut les mettre a 0 au debut +c ALE-----input-R-energie disponible pour soulevement +c ALP-----input-R-puissance disponible pour soulevement +c +C d_h-----output-R-increment de l'enthalpie potentielle (h) +c d_q-----output-R-increment de la vapeur d'eau +c rain----output-R-la pluie (mm/s) +c snow----output-R-la neige (mm/s) +c upwd----output-R-saturated updraft mass flux (kg/m**2/s) +c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s) +c dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s) +c Ma------output-R-adiabatic ascent mass flux (kg/m2/s) +c mip-----output-R-mass flux shed by adiabatic ascent (kg/m2/s) +c Vprecip-output-R-vertical profile of precipitations (kg/m2/s) +c Tconv---output-R-environment temperature seen by convective scheme (K) +c Cape----output-R-CAPE (J/kg) +c Cin ----output-R-CIN (J/kg) +c Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee +c adiabatiquement a partir du niveau 1 (K) +c deltapb-output-R-distance entre LCL et base de la colonne (<0 ; Pa) +c Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de la glace +c dd_t-----output-R-increment de la temperature du aux descentes precipitantes +c dd_q-----output-R-increment de la vapeur d'eau du aux desc precip +c====================================================================== +c +#include "dimensions.h" +c + INTEGER iflag_con,iflag_clos +c + REAL dtime, paprs(klon,klev+1),pplay(klon,klev) + REAL t(klon,klev),q(klon,klev),u(klon,klev),v(klon,klev) + REAL t_wake(klon,klev),q_wake(klon,klev) + Real s_wake(klon) + REAL tra(klon,klev,nbtr) + INTEGER ntra + REAL work1(klon,klev),work2(klon,klev),ptop2(klon) + REAL pmflxr(klon,klev+1),pmflxs(klon,klev+1) + REAL ALE(klon),ALP(klon) +c + REAL d_t(klon,klev),d_q(klon,klev),d_u(klon,klev),d_v(klon,klev) + REAL dd_t(klon,klev),dd_q(klon,klev) + REAL d_tra(klon,klev,nbtr) + REAL rain(klon),snow(klon) +c + INTEGER kbas(klon),ktop(klon) + REAL em_ph(klon,klev+1),em_p(klon,klev) + REAL upwd(klon,klev),dnwd(klon,klev),dnwdbis(klon,klev) + REAL Ma(klon,klev), mip(klon,klev),Vprecip(klon,klev) + real da(klon,klev),phi(klon,klev,klev),mp(klon,klev) + REAL cape(klon),cin(klon),tvp(klon,klev) + REAL Tconv(klon,klev) +c +cCR:test: on passe lentr et alim_star des thermiques + INTEGER lalim_conv(klon) + REAL wght_th(klon,klev) + REAL em_sig1feed ! sigma at lower bound of feeding layer + REAL em_sig2feed ! sigma at upper bound of feeding layer + REAL em_wght(klev) ! weight density determining the feeding mixture +con enleve le save +c SAVE em_sig1feed,em_sig2feed,em_wght +c + INTEGER iflag(klon) + REAL rflag(klon) + REAL pbase(klon),bbase(klon) + REAL dtvpdt1(klon,klev),dtvpdq1(klon,klev) + REAL dplcldt(klon),dplcldr(klon) + REAL qcondc(klon,klev) + REAL wd(klon) + REAL Plim1(klon),Plim2(klon),asupmax(klon,klev) + REAL supmax0(klon),asupmaxmin(klon) +c + REAL sigd(klon) + REAL zx_t,zdelta,zx_qs,zcor +c +! INTEGER iflag_mix +! SAVE iflag_mix + INTEGER noff, minorig + INTEGER i,k,itra + REAL qs(klon,klev),qs_wake(klon,klev) +cLF REAL cbmf(klon) +cLF SAVE cbmf + REAL, SAVE, ALLOCATABLE :: cbmf(:) +c$OMP THREADPRIVATE(cbmf)! + REAL cbmflast(klon) + INTEGER ifrst + SAVE ifrst + DATA ifrst /0/ +c$OMP THREADPRIVATE(ifrst) + +c +C Variables supplementaires liees au bilan d'energie +c Real paire(klon) +cLF Real ql(klon,klev) +c Save paire +cLF Save ql +cLF Real t1(klon,klev),q1(klon,klev) +cLF Save t1,q1 +c Data paire /1./ + REAL, SAVE, ALLOCATABLE :: ql(:,:), q1(:,:), t1(:,:) +c$OMP THREADPRIVATE(ql, q1, t1) +c +C Variables liees au bilan d'energie et d'enthalpi + REAL ztsol(klon) + REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + $ , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot + SAVE h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + $ , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot +c$OMP THREADPRIVATE(h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot) +c$OMP THREADPRIVATE(h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot) + REAL d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec + REAL d_h_vcol_phy + REAL fs_bound, fq_bound + SAVE d_h_vcol_phy +c$OMP THREADPRIVATE(d_h_vcol_phy) + REAL zero_v(klon) + CHARACTER*15 ztit + INTEGER ip_ebil ! PRINT level for energy conserv. diag. + SAVE ip_ebil + DATA ip_ebil/2/ +c$OMP THREADPRIVATE(ip_ebil) + INTEGER if_ebil ! level for energy conserv. dignostics + SAVE if_ebil + DATA if_ebil/2/ +c$OMP THREADPRIVATE(if_ebil) +c+jld ec_conser + REAL d_t_ec(klon,klev) ! tendance du a la conersion Ec -> E thermique + REAL ZRCPD +c-jld ec_conser +cLF + INTEGER nloc + logical, save :: first=.true. +c$OMP THREADPRIVATE(first) + INTEGER, SAVE :: itap, igout +c$OMP THREADPRIVATE(itap, igout) +c +#include "YOMCST.h" +#include "YOMCST2.h" +#include "YOETHF.h" +#include "FCTTRE.h" +#include "iniprint.h" +c + if (first) then +c Allocate some variables LF 04/2008 +c + allocate(cbmf(klon)) + allocate(ql(klon,klev)) + allocate(t1(klon,klev)) + allocate(q1(klon,klev)) + itap=0 + igout=klon/2+1/klon + endif +c Incrementer le compteur de la physique + itap = itap + 1 + +c Copy T into Tconv + DO k = 1,klev + DO i = 1,klon + Tconv(i,k) = T(i,k) + ENDDO + ENDDO +c + IF (if_ebil.ge.1) THEN + DO i=1,klon + ztsol(i) = t(i,1) + zero_v(i)=0. + Do k = 1,klev + ql(i,k) = 0. + ENDDO + END DO + END IF +c +cym + snow(:)=0 + +c IF (ifrst .EQ. 0) THEN +c ifrst = 1 + if (first) then + first=.false. +c +C=========================================================================== +C READ IN PARAMETERS FOR THE CLOSURE AND THE MIXING DISTRIBUTION +C=========================================================================== +C + if (iflag_con.eq.3) then +c CALL cv3_inicp() + CALL cv3_inip() + endif +c +C=========================================================================== +C READ IN PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS +C=========================================================================== +C +cc$$$ open (56,file='supcrit.data') +cc$$$ read (56,*) Supcrit1, Supcrit2 +cc$$$ close (56) +c + print*, 'supcrit1, supcrit2' ,supcrit1, supcrit2 +C +C=========================================================================== +C Initialisation pour les bilans d'eau et d'energie +C=========================================================================== + IF (if_ebil.ge.1) d_h_vcol_phy=0. +c + DO i = 1, klon + cbmf(i) = 0. + sigd(i) = 0. + ENDDO + ENDIF !(ifrst .EQ. 0) + + DO k = 1, klev+1 + DO i=1,klon + em_ph(i,k) = paprs(i,k) / 100.0 + pmflxs(i,k)=0. + ENDDO + ENDDO +c + DO k = 1, klev + DO i=1,klon + em_p(i,k) = pplay(i,k) / 100.0 + ENDDO + ENDDO +c +! +! Feeding layer +! + em_sig1feed = 1. + em_sig2feed = 0.97 +c em_sig2feed = 0.8 +! Relative Weight densities + do k=1,klev + em_wght(k)=1. + end do +cCRtest: couche alim des tehrmiques ponderee par a* +c DO i = 1, klon +c do k=1,lalim_conv(i) +c em_wght(k)=wght_th(i,k) +c print*,'em_wght=',em_wght(k),wght_th(i,k) +c end do +c END DO + + if (iflag_con .eq. 4) then + DO k = 1, klev + DO i = 1, klon + zx_t = t(i,k) + zdelta=MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0) + zcor=1./(1.-retv*zx_qs) + qs(i,k)=zx_qs*zcor + ENDDO + DO i = 1, klon + zx_t = t_wake(i,k) + zdelta=MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0) + zcor=1./(1.-retv*zx_qs) + qs_wake(i,k)=zx_qs*zcor + ENDDO + ENDDO + else ! iflag_con=3 (modif de puristes qui fait la diffce pour la convergence numerique) + DO k = 1, klev + DO i = 1, klon + zx_t = t(i,k) + zdelta=MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0 + zx_qs= MIN(0.5,zx_qs) + zcor=1./(1.-retv*zx_qs) + zx_qs=zx_qs*zcor + qs(i,k)=zx_qs + ENDDO + DO i = 1, klon + zx_t = t_wake(i,k) + zdelta=MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0 + zx_qs= MIN(0.5,zx_qs) + zcor=1./(1.-retv*zx_qs) + zx_qs=zx_qs*zcor + qs_wake(i,k)=zx_qs + ENDDO + ENDDO + endif ! iflag_con +c +C------------------------------------------------------------------ + +C Main driver for convection: +C iflag_con=3 -> nvlle version de KE (JYG) +C iflag_con = 30 -> equivalent to convect3 +C iflag_con = 4 -> equivalent to convect1/2 +c +c + if (iflag_con.eq.30) then + + CALL cv_driver(klon,klev,klev+1,ntra,iflag_con, + : t,q,qs,u,v,tra, + $ em_p,em_ph,iflag, + $ d_t,d_q,d_u,d_v,d_tra,rain, + $ pmflxr,cbmf,work1,work2, + $ kbas,ktop, + $ dtime,Ma,upwd,dnwd,dnwdbis,qcondc,wd,cape, + $ da,phi,mp) + + else + +cLF necessary for gathered fields + nloc=klon + CALL cva_driver(klon,klev,klev+1,ntra,nloc, + $ iflag_con,iflag_mix,iflag_clos,dtime, + : t,q,qs,t_wake,q_wake,qs_wake,s_wake,u,v,tra, + $ em_p,em_ph, + . ALE,ALP, + . em_sig1feed,em_sig2feed,em_wght, + . iflag,d_t,d_q,d_u,d_v,d_tra,rain,kbas,ktop, + $ cbmf,work1,work2,ptop2,sigd, + $ Ma,mip,Vprecip,upwd,dnwd,dnwdbis,qcondc,wd, + $ cape,cin,tvp, + $ dd_t,dd_q,Plim1,Plim2,asupmax,supmax0, + $ asupmaxmin,lalim_conv) + endif +C------------------------------------------------------------------ + + DO i = 1,klon + rain(i) = rain(i)/86400. + rflag(i)=iflag(i) + ENDDO + + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = dtime*d_t(i,k) + d_q(i,k) = dtime*d_q(i,k) + d_u(i,k) = dtime*d_u(i,k) + d_v(i,k) = dtime*d_v(i,k) + ENDDO + ENDDO +c + if (iflag_con.eq.30) then + DO itra = 1,ntra + DO k = 1, klev + DO i = 1, klon + d_tra(i,k,itra) =dtime*d_tra(i,k,itra) + ENDDO + ENDDO + ENDDO + endif + + DO k = 1, klev + DO i = 1, klon + t1(i,k) = t(i,k)+ d_t(i,k) + q1(i,k) = q(i,k)+ d_q(i,k) + ENDDO + ENDDO +c +cc IF (if_ebil.ge.2) THEN +cc ztit='after convect' +cc CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime +cc e , t1,q1,ql,qs,u,v,paprs,pplay +cc s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) +cc call diagphy(paire,ztit,ip_ebil +cc e , zero_v, zero_v, zero_v, zero_v, zero_v +cc e , zero_v, rain, zero_v, ztsol +cc e , d_h_vcol, d_qt, d_ec +cc s , fs_bound, fq_bound ) +cc END IF +C +c +c les traceurs ne sont pas mis dans cette version de convect4: + if (iflag_con.eq.4) then + DO itra = 1,ntra + DO k = 1, klev + DO i = 1, klon + d_tra(i,k,itra) = 0. + ENDDO + ENDDO + ENDDO + endif +c print*, 'concvl->: dd_t,dd_q ',dd_t(1,1),dd_q(1,1) + + DO k = 1, klev + DO i = 1, klon + dtvpdt1(i,k) = 0. + dtvpdq1(i,k) = 0. + ENDDO + ENDDO + DO i = 1, klon + dplcldt(i) = 0. + dplcldr(i) = 0. + ENDDO +c + if(prt_level.GE.20) THEN + DO k=1,klev +! print*,'physiq apres_add_con i k it d_u d_v d_t d_q qdl0',igout +! .,k,itap,d_u_con(igout,k) ,d_v_con(igout,k), d_t_con(igout,k), +! .d_q_con(igout,k),dql0(igout,k) +! print*,'phys apres_add_con itap Ma cin ALE ALP wak t q undi t q' +! .,itap,Ma(igout,k),cin(igout),ALE(igout), ALP(igout), +! . t_wake(igout,k),q_wake(igout,k),t_undi(igout,k),q_undi(igout,k) +! print*,'phy apres_add_con itap CON rain snow EMA wk1 wk2 Vpp mip' +! .,itap,rain_con(igout),snow_con(igout),ema_work1(igout,k), +! .ema_work2(igout,k),Vprecip(igout,k), mip(igout,k) +! print*,'phy apres_add_con itap upwd dnwd dnwd0 cape tvp Tconv ' +! .,itap,upwd(igout,k),dnwd(igout,k),dnwd0(igout,k),cape(igout), +! .tvp(igout,k),Tconv(igout,k) +! print*,'phy apres_add_con itap dtvpdt dtvdq dplcl dplcldr qcondc' +! .,itap,dtvpdt1(igout,k),dtvpdq1(igout,k),dplcldt(igout), +! .dplcldr(igout),qcondc(igout,k) +! print*,'phy apres_add_con itap wd pmflxr Kpmflxr Kp1 Kpmflxs Kp1' +! .,itap,wd(igout),pmflxr(igout,k),pmflxr(igout,k+1),pmflxs(igout,k) +! .,pmflxs(igout,k+1) +! print*,'phy apres_add_con itap da phi mp ftd fqd lalim wgth', +! .itap,da(igout,k),phi(igout,k,k),mp(igout,k),ftd(igout,k), +! . fqd(igout,k),lalim_conv(igout),wght_th(igout,k) + ENDDO + endif !(prt_level.EQ.20) THEN +c + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/condsurf.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/condsurf.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/condsurf.F (revision 1280) @@ -0,0 +1,139 @@ +c $Header$ +c + SUBROUTINE condsurf( jour, jourvrai, lmt_bils ) + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + IMPLICIT none +c +c I. Musat 05.2005 +c +c Lire chaque jour le bilan de chaleur au sol issu +c d'un run atmospherique afin de l'utiliser dans +c dans un run "slab" ocean +c ----------------------------------------- +c jour : input , numero du jour a lire +c jourvrai : input , vrai jour de la simulation +c +c lmt_bils: bilan chaleur au sol (a utiliser pour "slab-ocean") +c +#include "netcdf.inc" + INTEGER nid, nvarid + INTEGER debut(2) + INTEGER epais(2) +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "indicesol.h" +#include "temps.h" +#include "clesphys.h" +c + INTEGER nannemax + PARAMETER ( nannemax = 60 ) +c + INTEGER jour, jourvrai + REAL lmt_bils(klon) !bilan chaleur au sol +c +c Variables locales: + INTEGER ig, i, kt, ierr + LOGICAL ok + INTEGER anneelim,anneemax + CHARACTER*20 fich + + REAL :: lmt_bils_glo(klon_glo) + +cc +cc ..................................................................... +cc +cc Pour lire le fichier limit correspondant vraiment a l'annee de la +cc simulation en cours , il suffit de mettre ok_limitvrai = .TRUE. +cc +cc ...................................................................... +c +c + + IF (jour.LT.0 .OR. jour.GT.(360-1)) THEN + PRINT*,'Le jour demande n est pas correct: ', jour + CALL ABORT + ENDIF +c + anneelim = annee_ref + anneemax = annee_ref + nannemax +c +c + IF( ok_limitvrai ) THEN + DO kt = 1, nannemax + IF(jourvrai.LE. (kt-1)*360 + 359 ) THEN + WRITE(fich,'("limit",i4,".nc")') anneelim +c PRINT *,' Fichier Limite ',fich + GO TO 100 + ENDIF + anneelim = anneelim + 1 + ENDDO + + PRINT *,' PBS ! Le jour a lire sur le fichier limit ne se ' + PRINT *,' trouve pas sur les ',nannemax,' annees a partir de ' + PRINT *,' l annee de debut', annee_ref + CALL EXIT(1) +c +100 CONTINUE +c + ELSE + + WRITE(fich,'("limitNEW.nc")') +c PRINT *,' Fichier Limite ',fich + ENDIF +c +c Ouvrir le fichier en format NetCDF: +c +c$OMP MASTER + IF (is_mpi_root) THEN + ierr = NF_OPEN (fich, NF_NOWRITE,nid) + IF (ierr.NE.NF_NOERR) THEN + WRITE(6,*)' Pb d''ouverture du fichier ', fich + WRITE(6,*)' Le fichier limit ',fich,' (avec 4 chiffres , pour' + WRITE(6,*)' l an 2000 ) , n existe pas ! ' + WRITE(6,*)' ierr = ', ierr + CALL EXIT(1) + ENDIF +c DO k = 1, jour +c La tranche de donnees a lire: +c + debut(1) = 1 + debut(2) = jourvrai + epais(1) = klon_glo + epais(2) = 1 +c Bilan flux de chaleur au sol: +c + ierr = NF_INQ_VARID (nid, "BILS", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "condsurf: Le champ est absent" + CALL abort + ENDIF + PRINT*,'debut,epais',debut,epais,'jour,jourvrai',jour,jourvrai +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,debut,epais,lmt_bils_glo) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,debut,epais,lmt_bils_glo) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "condsurf: Lecture echouee pour " + CALL abort + ENDIF +c ENDDO !k = 1, jour +c +c Fermer le fichier: +c + ierr = NF_CLOSE(nid) + + ENDIF ! is_mpi_root==0 + +c$OMP END MASTER + CALL scatter(lmt_bils_glo,lmt_bils) + +c +c +c PRINT*, 'lmt_bils est lu pour jour: ', jour +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conema3.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conema3.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conema3.F (revision 1280) @@ -0,0 +1,420 @@ +! +! $Header$ +! + SUBROUTINE conema3 (dtime,paprs,pplay,t,q,u,v,tra,ntra, + . work1,work2,d_t,d_q,d_u,d_v,d_tra, + . rain, snow, kbas, ktop, + . upwd,dnwd,dnwdbis,bas,top,Ma,cape,tvp,rflag, + . pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr, + . qcond_incld) + + USE dimphy + USE infotrac, ONLY : nbtr + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: schema de convection de Emanuel (1991) interface +c Mai 1998: Interface modifiee pour implementation dans LMDZ +c====================================================================== +c Arguments: +c dtime---input-R-pas d'integration (s) +c paprs---input-R-pression inter-couches (Pa) +c pplay---input-R-pression au milieu des couches (Pa) +c t-------input-R-temperature (K) +c q-------input-R-humidite specifique (kg/kg) +c u-------input-R-vitesse du vent zonal (m/s) +c v-------input-R-vitesse duvent meridien (m/s) +c tra-----input-R-tableau de rapport de melange des traceurs +c work*: input et output: deux variables de travail, +c on peut les mettre a 0 au debut +c +C d_t-----output-R-increment de la temperature +c d_q-----output-R-increment de la vapeur d'eau +c d_u-----output-R-increment de la vitesse zonale +c d_v-----output-R-increment de la vitesse meridienne +c d_tra---output-R-increment du contenu en traceurs +c rain----output-R-la pluie (mm/s) +c snow----output-R-la neige (mm/s) +c kbas----output-R-bas du nuage (integer) +c ktop----output-R-haut du nuage (integer) +c upwd----output-R-saturated updraft mass flux (kg/m**2/s) +c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s) +c dnwdbis-output-R-unsaturated downdraft mass flux (kg/m**2/s) +c bas-----output-R-bas du nuage (real) +c top-----output-R-haut du nuage (real) +c Ma------output-R-flux ascendant non dilue (kg/m**2/s) +c cape----output-R-CAPE +c tvp-----output-R-virtual temperature of the lifted parcel +c rflag---output-R-flag sur le fonctionnement de convect +c pbase---output-R-pression a la base du nuage (Pa) +c bbase---output-R-buoyancy a la base du nuage (K) +c dtvpdt1-output-R-derivative of parcel virtual temp wrt T1 +c dtvpdq1-output-R-derivative of parcel virtual temp wrt Q1 +c dplcldt-output-R-derivative of the PCP pressure wrt T1 +c dplcldr-output-R-derivative of the PCP pressure wrt Q1 +c====================================================================== +c +#include "dimensions.h" +#include "conema3.h" + INTEGER i, l,m,itra + INTEGER ntra ! if no tracer transport + ! is needed, set ntra = 1 (or 0) + REAL dtime +c + REAL d_t2(klon,klev), d_q2(klon,klev) ! sbl + REAL d_u2(klon,klev), d_v2(klon,klev) ! sbl + REAL em_d_t2(klev), em_d_q2(klev) ! sbl + REAL em_d_u2(klev), em_d_v2(klev) ! sbl +c + REAL paprs(klon,klev+1), pplay(klon,klev) + REAL t(klon,klev), q(klon,klev), d_t(klon,klev), d_q(klon,klev) + REAL u(klon,klev), v(klon,klev), tra(klon,klev,ntra) + REAL d_u(klon,klev), d_v(klon,klev), d_tra(klon,klev,ntra) + REAL work1(klon,klev), work2(klon,klev) + REAL upwd(klon,klev), dnwd(klon,klev), dnwdbis(klon,klev) + REAL rain(klon) + REAL snow(klon) + REAL cape(klon), tvp(klon,klev), rflag(klon) + REAL pbase(klon), bbase(klon) + REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev) + REAL dplcldt(klon), dplcldr(klon) + INTEGER kbas(klon), ktop(klon) + + REAL wd(klon) + REAL qcond_incld(klon,klev) +c + LOGICAL,SAVE :: first=.true. +c$OMP THREADPRIVATE(first) + +cym REAL em_t(klev) + REAL,ALLOCATABLE,SAVE :: em_t(:) +c$OMP THREADPRIVATE(em_t) +cym REAL em_q(klev) + REAL,ALLOCATABLE,SAVE :: em_q(:) +c$OMP THREADPRIVATE(em_q) +cym REAL em_qs(klev) + REAL,ALLOCATABLE,SAVE :: em_qs(:) +c$OMP THREADPRIVATE(em_qs) +cym REAL em_u(klev), em_v(klev), em_tra(klev,nbtr) + REAL,ALLOCATABLE,SAVE :: em_u(:),em_v(:),em_tra(:,:) +c$OMP THREADPRIVATE(em_u,em_v,em_tra) +cym REAL em_ph(klev+1), em_p(klev) + REAL,ALLOCATABLE,SAVE ::em_ph(:),em_p(:) +c$OMP THREADPRIVATE(em_ph,em_p) +cym REAL em_work1(klev), em_work2(klev) + REAL,ALLOCATABLE,SAVE ::em_work1(:),em_work2(:) +c$OMP THREADPRIVATE(em_work1,em_work2) +cym REAL em_precip, em_d_t(klev), em_d_q(klev) + REAL,SAVE :: em_precip +c$OMP THREADPRIVATE(em_precip) + REAL,ALLOCATABLE,SAVE :: em_d_t(:),em_d_q(:) +c$OMP THREADPRIVATE(em_d_t,em_d_q) +cym REAL em_d_u(klev), em_d_v(klev), em_d_tra(klev,nbtr) + REAL,ALLOCATABLE,SAVE ::em_d_u(:),em_d_v(:),em_d_tra(:,:) +c$OMP THREADPRIVATE(em_d_u,em_d_v,em_d_tra) +cym REAL em_upwd(klev), em_dnwd(klev), em_dnwdbis(klev) + REAL,ALLOCATABLE,SAVE :: em_upwd(:),em_dnwd(:),em_dnwdbis(:) +c$OMP THREADPRIVATE(em_upwd,em_dnwd,em_dnwdbis) + REAL em_dtvpdt1(klev), em_dtvpdq1(klev) + REAL em_dplcldt, em_dplcldr +cym SAVE em_t,em_q, em_qs, em_ph, em_p, em_work1, em_work2 +cym SAVE em_u,em_v, em_tra +cym SAVE em_d_u,em_d_v, em_d_tra +cym SAVE em_precip, em_d_t, em_d_q, em_upwd, em_dnwd, em_dnwdbis + + INTEGER em_bas, em_top + SAVE em_bas, em_top +c$OMP THREADPRIVATE(em_bas,em_top) + REAL em_wd + REAL em_qcond(klev) + REAL em_qcondc(klev) +c + REAL zx_t, zx_qs, zdelta, zcor + INTEGER iflag + REAL sigsum +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c VARIABLES A SORTIR +cccccccccccccccccccccccccccccccccccccccccccccccccc + +cym REAL emmip(klev) !variation de flux ascnon dilue i et i+1 + REAL,ALLOCATABLE,SAVE ::emmip(:) +c$OMP THREADPRIVATE(emmip) +cym SAVE emmip +cym real emMke(klev) + REAL,ALLOCATABLE,SAVE ::emMke(:) +c$OMP THREADPRIVATE(emMke) +cym save emMke + real top + real bas +cym real emMa(klev) + REAL,ALLOCATABLE,SAVE ::emMa(:) +c$OMP THREADPRIVATE(emMa) +cym save emMa + real Ma(klon,klev) + real Ment(klev,klev) + real Qent(klev,klev) + real TPS(klev),TLS(klev) + real SIJ(klev,klev) + real em_CAPE, em_TVP(klev) + real em_pbase, em_bbase + integer iw,j,k,ix,iy + +c -- sb: pour schema nuages: + + integer iflagcon + integer em_ifc(klev) + + real em_pradj + real em_cldf(klev), em_cldq(klev) + real em_ftadj(klev), em_fradj(klev) + + integer ifc(klon,klev) + real pradj(klon) + real cldf(klon,klev), cldq(klon,klev) + real ftadj(klon,klev), fqadj(klon,klev) + +c sb -- + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" + + if (first) then + + allocate(em_t(klev)) + allocate(em_q(klev)) + allocate(em_qs(klev)) + allocate(em_u(klev), em_v(klev), em_tra(klev,nbtr)) + allocate(em_ph(klev+1), em_p(klev)) + allocate(em_work1(klev), em_work2(klev)) + allocate(em_d_t(klev), em_d_q(klev)) + allocate(em_d_u(klev), em_d_v(klev), em_d_tra(klev,nbtr)) + allocate(em_upwd(klev), em_dnwd(klev), em_dnwdbis(klev)) + allocate(emmip(klev)) + allocate(emMke(klev)) + allocate(emMa(klev)) + + first=.false. + endif + + qcond_incld(:,:) = 0. +c +c@$$ print*,'debut conema' + + DO 999 i = 1, klon + DO l = 1, klev+1 + em_ph(l) = paprs(i,l) / 100.0 + ENDDO +c + DO l = 1, klev + em_p(l) = pplay(i,l) / 100.0 + em_t(l) = t(i,l) + em_q(l) = q(i,l) + em_u(l) = u(i,l) + em_v(l) = v(i,l) + do itra = 1, ntra + em_tra(l,itra) = tra(i,l,itra) + enddo +c@$$ print*,'em_t',em_t +c@$$ print*,'em_q',em_q +c@$$ print*,'em_qs',em_qs +c@$$ print*,'em_u',em_u +c@$$ print*,'em_v',em_v +c@$$ print*,'em_tra',em_tra +c@$$ print*,'em_p',em_p + + +c + zx_t = em_t(l) + zdelta=MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(l)/100.0 + zx_qs=MIN(0.5,zx_qs) +c@$$ print*,'zx_qs',zx_qs + zcor=1./(1.-retv*zx_qs) + zx_qs=zx_qs*zcor + em_qs(l) = zx_qs +c@$$ print*,'em_qs',em_qs +c + em_work1(l) = work1(i,l) + em_work2(l) = work2(i,l) + emMke(l)=0 +c emMa(l)=0 +c Ma(i,l)=0 + + em_dtvpdt1(l) = 0. + em_dtvpdq1(l) = 0. + dtvpdt1(i,l) = 0. + dtvpdq1(i,l) = 0. + ENDDO +c + em_dplcldt = 0. + em_dplcldr = 0. + rain(i) = 0.0 + snow(i) = 0.0 + kbas(i) = 1 + ktop(i) = 1 +c ajout SB: + bas = 1 + top = 1 + + +c sb3d write(*,1792) (em_work1(m),m=1,klev) +1792 format('sig avant convect ',/,10(1X,E13.5)) +c +c sb d write(*,1793) (em_work2(m),m=1,klev) +1793 format('w avant convect ',/,10(1X,E13.5)) + +c@$$ print*,'avant convect' +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + +c print*,'avant convect i=',i + CALL convect3(dtime,epmax,ok_adj_ema, + . em_t, em_q, em_qs,em_u ,em_v , + . em_tra, em_p, em_ph, + . klev, klev+1, klev-1,ntra, dtime, iflag, + . em_d_t, em_d_q,em_d_u,em_d_v, + . em_d_tra, em_precip, + . em_bas, em_top,em_upwd, em_dnwd, em_dnwdbis, + . em_work1, em_work2,emmip,emMke,emMa,Ment, + . Qent,TPS,TLS,SIJ,em_CAPE,em_TVP,em_pbase,em_bbase, + . em_dtvpdt1,em_dtvpdq1,em_dplcldt,em_dplcldr, ! sbl + . em_d_t2,em_d_q2,em_d_u2,em_d_v2,em_wd,em_qcond,em_qcondc)!sbl +c print*,'apres convect ' +c +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c -- sb: Appel schema statistique de nuages couple a la convection +c (Bony et Emanuel 2001): + +c -- creer cvthermo.h qui contiendra les cstes thermo de LMDZ: + + iflagcon = 3 +c CALL cv_thermo(iflagcon) + +c -- appel schema de nuages: + +c CALL CLOUDS_SUB_LS(klev,em_q,em_qs,em_t +c i ,em_p,em_ph,dtime,em_qcondc +c o ,em_cldf,em_cldq,em_pradj,em_ftadj,em_fradj,em_ifc) + + do k = 1, klev + cldf(i,k) = em_cldf(k) ! cloud fraction (0-1) + cldq(i,k) = em_cldq(k) ! in-cloud water content (kg/kg) + ftadj(i,k) = em_ftadj(k) ! (dT/dt)_{LS adj} (K/s) + fqadj(i,k) = em_fradj(k) ! (dq/dt)_{LS adj} (kg/kg/s) + ifc(i,k) = em_ifc(k) ! flag convergence clouds_gno (1 ou 2) + enddo + pradj(i) = em_pradj ! precip from LS supersat adj (mm/day) + +c sb -- +c +c SB: + if (iflag.ne.1 .and. iflag.ne.4) then + em_CAPE = 0. + do l = 1, klev + em_upwd(l) = 0. + em_dnwd(l) = 0. + em_dnwdbis(l) = 0. + emMa(l) = 0. + em_TVP(l) = 0. + enddo + endif +c fin SB +c +c If sig has been set to zero, then set Ma to zero +c + sigsum = 0. + do k = 1,klev + sigsum = sigsum + em_work1(k) + enddo + if (sigsum .eq. 0.0) then + do k = 1,klev + emMa(k) = 0. + enddo + endif +c +c sb3d print*,'i, iflag=',i,iflag +c +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c SORTIE DES ICB ET INB +c en fait inb et icb correspondent au niveau ou se trouve +c le nuage,le numero d'interface +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c modif SB: + if (iflag.EQ.1 .or. iflag.EQ.4) then + top=em_top + bas=em_bas + kbas(i) = em_bas + ktop(i) = em_top + endif + + pbase(i) = em_pbase + bbase(i) = em_bbase + rain(i) = em_precip/ 86400.0 + snow(i) = 0.0 + cape(i) = em_CAPE + wd(i) = em_wd + rflag(i) = float(iflag) +c SB kbas(i) = em_bas +c SB ktop(i) = em_top + dplcldt(i) = em_dplcldt + dplcldr(i) = em_dplcldr + DO l = 1, klev + d_t2(i,l) = dtime * em_d_t2(l) + d_q2(i,l) = dtime * em_d_q2(l) + d_u2(i,l) = dtime * em_d_u2(l) + d_v2(i,l) = dtime * em_d_v2(l) + + d_t(i,l) = dtime * em_d_t(l) + d_q(i,l) = dtime * em_d_q(l) + d_u(i,l) = dtime * em_d_u(l) + d_v(i,l) = dtime * em_d_v(l) + do itra = 1, ntra + d_tra(i,l,itra) = dtime * em_d_tra(l,itra) + enddo + upwd(i,l) = em_upwd(l) + dnwd(i,l) = em_dnwd(l) + dnwdbis(i,l) = em_dnwdbis(l) + work1(i,l) = em_work1(l) + work2(i,l) = em_work2(l) + Ma(i,l)=emMa(l) + tvp(i,l)=em_TVP(l) + dtvpdt1(i,l) = em_dtvpdt1(l) + dtvpdq1(i,l) = em_dtvpdq1(l) + + if (iflag_clw.eq.0) then + qcond_incld(i,l) = em_qcondc(l) + else if (iflag_clw.eq.1) then + qcond_incld(i,l) = em_qcond(l) + endif + ENDDO + 999 CONTINUE + +c On calcule une eau liquide diagnostique en fonction de la +c precip. + if ( iflag_clw.eq.2 ) then + do l=1,klev + do i=1,klon + if (ktop(i)-kbas(i).gt.0.and. + s l.ge.kbas(i).and.l.le.ktop(i)) then + qcond_incld(i,l)=rain(i)*8.e4 +c s *(pplay(i,l )-paprs(i,ktop(i)+1)) + s /(pplay(i,kbas(i))-pplay(i,ktop(i))) +c s **2 + else + qcond_incld(i,l)=0. + endif + enddo + print*,'l=',l,', qcond_incld=',qcond_incld(1,l) + enddo + endif + + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conema3.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conema3.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conema3.h (revision 1280) @@ -0,0 +1,17 @@ +! +! $Header$ +!-- Modified by : Filiberti M-A 06/2005 +! + real epmax ! 0.993 + logical ok_adj_ema ! F + integer iflag_clw ! 0 + integer iflag_cvl_sigd + real sig1feed ! 1. + real sig2feed ! 0.95 + + common/comconema1/epmax,ok_adj_ema,iflag_clw,sig1feed,sig2feed + common/comconema2/iflag_cvl_sigd + +! common/comconema/epmax,ok_adj_ema,iflag_clw +!$OMP THREADPRIVATE(/comconema1/) +!$OMP THREADPRIVATE(/comconema2/) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conemav.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conemav.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conemav.F (revision 1280) @@ -0,0 +1,151 @@ +! +! $Header$ +! + SUBROUTINE conemav (dtime,paprs,pplay,t,q,u,v,tra,ntra, + . work1,work2,d_t,d_q,d_u,d_v,d_tra, + . rain, snow, kbas, ktop, + . upwd,dnwd,dnwdbis,Ma,cape,tvp,iflag, + . pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr) + +c + USE dimphy + USE infotrac, ONLY : nbtr + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: schema de convection de Emanuel (1991) interface +c====================================================================== +c Arguments: +c dtime--input-R-pas d'integration (s) +c s-------input-R-la valeur "s" pour chaque couche +c sigs----input-R-la valeur "sigma" de chaque couche +c sig-----input-R-la valeur de "sigma" pour chaque niveau +c psolpa--input-R-la pression au sol (en Pa) +C pskapa--input-R-exponentiel kappa de psolpa +c h-------input-R-enthalpie potentielle (Cp*T/P**kappa) +c q-------input-R-vapeur d'eau (en kg/kg) +c +c work*: input et output: deux variables de travail, +c on peut les mettre a 0 au debut +c ALE-----input-R-energie disponible pour soulevement +c +C d_h-----output-R-increment de l'enthalpie potentielle (h) +c d_q-----output-R-increment de la vapeur d'eau +c rain----output-R-la pluie (mm/s) +c snow----output-R-la neige (mm/s) +c upwd----output-R-saturated updraft mass flux (kg/m**2/s) +c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s) +c dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s) +c Cape----output-R-CAPE (J/kg) +c Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee +c adiabatiquement a partir du niveau 1 (K) +c deltapb-output-R-distance entre LCL et base de la colonne (<0 ; Pa) +c Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de la glace +c====================================================================== +c +#include "dimensions.h" +c +c + REAL dtime, paprs(klon,klev+1),pplay(klon,klev) + REAL t(klon,klev),q(klon,klev),u(klon,klev),v(klon,klev) + REAL tra(klon,klev,nbtr) + INTEGER ntra + REAL work1(klon,klev),work2(klon,klev) +c + REAL d_t(klon,klev),d_q(klon,klev),d_u(klon,klev),d_v(klon,klev) + REAL d_tra(klon,klev,nbtr) + REAL rain(klon),snow(klon) +c + INTEGER kbas(klon),ktop(klon) + REAL em_ph(klon,klev+1),em_p(klon,klev) + REAL upwd(klon,klev),dnwd(klon,klev),dnwdbis(klon,klev) + REAL Ma(klon,klev),cape(klon),tvp(klon,klev) + INTEGER iflag(klon) + REAL rflag(klon) + REAL pbase(klon),bbase(klon) + REAL dtvpdt1(klon,klev),dtvpdq1(klon,klev) + REAL dplcldt(klon),dplcldr(klon) +c + REAL zx_t,zdelta,zx_qs,zcor +c + INTEGER noff, minorig + INTEGER i,k,itra + REAL qs(klon,klev) + REAL,ALLOCATABLE,SAVE :: cbmf(:) +c$OMP THREADPRIVATE(cbmf) + INTEGER ifrst + SAVE ifrst + DATA ifrst /0/ +c$OMP THREADPRIVATE(ifrst) +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +c +c + IF (ifrst .EQ. 0) THEN + ifrst = 1 + allocate(cbmf(klon)) + DO i = 1, klon + cbmf(i) = 0. + ENDDO + ENDIF + + DO k = 1, klev+1 + DO i=1,klon + em_ph(i,k) = paprs(i,k) / 100.0 + ENDDO + ENDDO +c + DO k = 1, klev + DO i=1,klon + em_p(i,k) = pplay(i,k) / 100.0 + ENDDO + ENDDO + +c + DO k = 1, klev + DO i = 1, klon + zx_t = t(i,k) + zdelta=MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0) + zcor=1./(1.-retv*zx_qs) + qs(i,k)=zx_qs*zcor + ENDDO + ENDDO +c + noff = 2 + minorig = 2 + CALL convect1(klon,klev,klev+1,noff,minorig,t,q,qs,u,v, + $ em_p,em_ph,iflag, + $ d_t,d_q,d_u,d_v,rain,cbmf,dtime,Ma) +c + DO i = 1,klon + rain(i) = rain(i)/86400. + rflag(i)=iflag(i) + ENDDO +c call dump2d(iim,jjm-1,rflag(2:klon-1),'FLAG CONVECTION ') +c if (klon.eq.1) then +c print*,'IFLAG ',iflag +c else +c write(*,'(96i1)') (iflag(i),i=2,klon-1) +c endif + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = dtime*d_t(i,k) + d_q(i,k) = dtime*d_q(i,k) + d_u(i,k) = dtime*d_u(i,k) + d_v(i,k) = dtime*d_v(i,k) + ENDDO + DO itra = 1,ntra + DO i = 1, klon + d_tra(i,k,itra) = 0. + ENDDO + ENDDO + ENDDO + +c +c +c + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conf_phys.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conf_phys.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conf_phys.F90 (revision 1280) @@ -0,0 +1,1651 @@ + +! +! $Id$ +! +! +! +module conf_phys_m + + implicit none + +contains + + subroutine conf_phys(ok_journe, ok_mensuel, ok_instan, ok_hf, & + ok_LES,& + solarlong0,seuil_inversion, & + fact_cldcon, facttemps,ok_newmicro,iflag_radia,& + iflag_cldcon, & + iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, & + ok_ade, ok_aie, aerosol_couple, & + flag_aerosol, new_aod, & + bl95_b0, bl95_b1,& + iflag_thermals,nsplit_thermals,tau_thermals, & + iflag_thermals_ed,iflag_thermals_optflux, & + iflag_coupl,iflag_clos,iflag_wake, read_climoz) + + use IOIPSL + USE surface_data + USE carbon_cycle_mod, ONLY : carbon_cycle_tr, carbon_cycle_cpl + + include "conema3.h" + include "fisrtilp.h" + include "nuage.h" + include "YOMCST.h" + include "YOMCST2.h" +!IM : on inclut/initialise les taux de CH4, N2O, CFC11 et CFC12 +include "clesphys.h" +include "compbl.h" +include "control.h" +include "comsoil.h" +! +! Configuration de la "physique" de LMDZ a l'aide de la fonction +! GETIN de IOIPSL +! +! LF 05/2001 +! + +! +! type_ocean: type d'ocean (force, slab, couple) +! version_ocean: version d'ocean (opa8/nemo pour type_ocean=couple ou +! sicOBS pour type_ocean=slab) +! ok_veget: type de modele de vegetation +! ok_journe: sorties journalieres +! ok_hf: sorties haute frequence +! ok_mensuel: sorties mensuelles +! ok_instan: sorties instantanees +! ok_ade, ok_aie: apply or not aerosol direct and indirect effects +! bl95_b*: parameters in the formula to link CDNC to aerosol mass conc +! + + +! Sortie: + logical :: ok_newmicro + integer :: iflag_radia + logical :: ok_journe, ok_mensuel, ok_instan, ok_hf + logical :: ok_LES + LOGICAL :: ok_ade, ok_aie, aerosol_couple + INTEGER :: flag_aerosol + LOGICAL :: new_aod + REAL :: bl95_b0, bl95_b1 + real :: fact_cldcon, facttemps,ratqsbas,ratqshaut,tau_ratqs + integer :: iflag_cldcon + integer :: iflag_ratqs + + character (len = 6),SAVE :: type_ocean_omp, version_ocean_omp, ocean_omp + CHARACTER(len = 8),SAVE :: aer_type_omp + logical,SAVE :: ok_veget_omp, ok_newmicro_omp + logical,SAVE :: ok_journe_omp, ok_mensuel_omp, ok_instan_omp, ok_hf_omp + logical,SAVE :: ok_LES_omp + LOGICAL,SAVE :: ok_ade_omp, ok_aie_omp, aerosol_couple_omp + INTEGER, SAVE :: flag_aerosol_omp + LOGICAL, SAVE :: new_aod_omp + REAL,SAVE :: bl95_b0_omp, bl95_b1_omp + REAL,SAVE :: freq_ISCCP_omp, ecrit_ISCCP_omp + REAL,SAVE :: freq_COSP_omp + real,SAVE :: fact_cldcon_omp, facttemps_omp,ratqsbas_omp + real,SAVE :: ratqshaut_omp + real,SAVE :: tau_ratqs_omp + integer,SAVE :: iflag_radia_omp + integer,SAVE :: iflag_rrtm_omp + integer,SAVE :: iflag_cldcon_omp, ip_ebil_phy_omp + integer,SAVE :: iflag_ratqs_omp + + Real,SAVE :: f_cdrag_ter_omp,f_cdrag_oce_omp + Real,SAVE :: f_rugoro_omp + +! Local + integer :: numout = 6 + real :: zzz + + real :: seuil_inversion + real,save :: seuil_inversion_omp + + integer :: iflag_thermals,nsplit_thermals + integer,SAVE :: iflag_thermals_ed_omp,iflag_thermals_optflux_omp + integer :: iflag_thermals_ed,iflag_thermals_optflux + integer,SAVE :: iflag_thermals_omp,nsplit_thermals_omp + real :: tau_thermals + real,save :: tau_thermals_omp + integer :: iflag_coupl + integer :: iflag_clos + integer :: iflag_wake + integer,SAVE :: iflag_coupl_omp,iflag_clos_omp,iflag_wake_omp + integer,SAVE :: iflag_cvl_sigd_omp + REAL, SAVE :: supcrit1_omp, supcrit2_omp + INTEGER, SAVE :: iflag_mix_omp + real, save :: scut_omp, qqa1_omp, qqa2_omp, gammas_omp, Fmax_omp, alphas_omp + + REAL,SAVE :: R_ecc_omp,R_peri_omp,R_incl_omp,solaire_omp,co2_ppm_omp + REAL,SAVE :: RCO2_omp,CH4_ppb_omp,RCH4_omp,N2O_ppb_omp,RN2O_omp,CFC11_ppt_omp + REAL,SAVE :: RCFC11_omp,CFC12_ppt_omp,RCFC12_omp,epmax_omp + LOGICAL,SAVE :: ok_adj_ema_omp + INTEGER,SAVE :: iflag_clw_omp + REAL,SAVE :: cld_lc_lsc_omp,cld_lc_con_omp,cld_tau_lsc_omp,cld_tau_con_omp + REAL,SAVE :: ffallv_lsc_omp, ffallv_con_omp,coef_eva_omp + LOGICAL,SAVE :: reevap_ice_omp + INTEGER,SAVE :: iflag_pdf_omp + REAL,SAVE :: rad_froid_omp, rad_chau1_omp, rad_chau2_omp + REAL,SAVE :: inertie_sol_omp,inertie_sno_omp,inertie_ice_omp + REAL,SAVE :: qsol0_omp + REAL :: solarlong0 + REAL,SAVE :: solarlong0_omp + INTEGER,SAVE :: top_height_omp,overlap_omp + REAL,SAVE :: cdmmax_omp,cdhmax_omp,ksta_omp,ksta_ter_omp + LOGICAL,SAVE :: ok_kzmin_omp + REAL, SAVE :: fmagic_omp, pmagic_omp + INTEGER,SAVE :: iflag_pbl_omp,lev_histhf_omp,lev_histday_omp,lev_histmth_omp + Integer,save :: lev_histins_omp, lev_histLES_omp + CHARACTER*4, SAVE :: type_run_omp + LOGICAL,SAVE :: ok_isccp_omp + LOGICAL,SAVE :: ok_cosp_omp + REAL,SAVE :: lonmin_ins_omp, lonmax_ins_omp, latmin_ins_omp, latmax_ins_omp + REAL,SAVE :: ecrit_hf_omp, ecrit_day_omp, ecrit_mth_omp, ecrit_reg_omp + REAL,SAVE :: ecrit_ins_omp + REAL,SAVE :: ecrit_LES_omp + REAL,SAVE :: ecrit_tra_omp + REAL,SAVE :: cvl_corr_omp + LOGICAL,SAVE :: ok_lic_melt_omp +! + LOGICAL,SAVE :: cycle_diurne_omp,soil_model_omp,new_oliq_omp + LOGICAL,SAVE :: ok_orodr_omp, ok_orolf_omp, ok_limitvrai_omp + INTEGER, SAVE :: nbapp_rad_omp, iflag_con_omp + LOGICAL,SAVE :: ok_strato_omp + LOGICAL,SAVE :: ok_hines_omp + LOGICAL,SAVE :: carbon_cycle_tr_omp + LOGICAL,SAVE :: carbon_cycle_cpl_omp + + integer, intent(out):: read_climoz ! read ozone climatology, OpenMP shared + ! Allowed values are 0, 1 and 2 + ! 0: do not read an ozone climatology + ! 1: read a single ozone climatology that will be used day and night + ! 2: read two ozone climatologies, the average day and night + ! climatology and the daylight climatology + +!$OMP MASTER +!Config Key = type_ocean +!Config Desc = Type d'ocean +!Config Def = force +!Config Help = Type d'ocean utilise: force, slab,couple +! + type_ocean_omp = 'force ' + call getin('type_ocean', type_ocean_omp) +! +!Config Key = version_ocean +!Config Desc = Version d'ocean +!Config Def = xxxxxx +!Config Help = Version d'ocean utilise: opa8/nemo/sicOBS/xxxxxx +! + version_ocean_omp = 'xxxxxx' + call getin('version_ocean', version_ocean_omp) + +!Config Key = OCEAN +!Config Desc = Old parameter name for type_ocean +!Config Def = yyyyyy +!Config Help = This is only for testing purpose +! + ocean_omp = 'yyyyyy' + call getin('OCEAN', ocean_omp) + IF (ocean_omp /= 'yyyyyy') THEN + WRITE(numout,*)'ERROR!! Old variable name OCEAN used in parmeter file.' + WRITE(numout,*)'Variable OCEAN has been replaced by the variable type_ocean.' + WRITE(numout,*)'You have to update your parameter file physiq.def to succed running' + CALL abort_gcm('conf_phys','Variable OCEAN no longer existing, use variable name type_ocean',1) + END IF + +! +!Config Key = VEGET +!Config Desc = Type de modele de vegetation +!Config Def = .false. +!Config Help = Type de modele de vegetation utilise +! + ok_veget_omp = .false. + call getin('VEGET', ok_veget_omp) +! +!Config Key = OK_journe +!Config Desc = Pour des sorties journalieres +!Config Def = .false. +!Config Help = Pour creer le fichier histday contenant les sorties +! journalieres +! + ok_journe_omp = .false. + call getin('OK_journe', ok_journe_omp) +! +!Config Key = ok_hf +!Config Desc = Pour des sorties haute frequence +!Config Def = .false. +!Config Help = Pour creer le fichier histhf contenant les sorties +! haute frequence ( 3h ou 6h) +! + ok_hf_omp = .false. + call getin('ok_hf', ok_hf_omp) +! +!Config Key = OK_mensuel +!Config Desc = Pour des sorties mensuelles +!Config Def = .true. +!Config Help = Pour creer le fichier histmth contenant les sorties +! mensuelles +! + ok_mensuel_omp = .true. + call getin('OK_mensuel', ok_mensuel_omp) +! +!Config Key = OK_instan +!Config Desc = Pour des sorties instantanees +!Config Def = .false. +!Config Help = Pour creer le fichier histins contenant les sorties +! instantanees +! + ok_instan_omp = .false. + call getin('OK_instan', ok_instan_omp) +! +!Config Key = ok_ade +!Config Desc = Aerosol direct effect or not? +!Config Def = .false. +!Config Help = Used in radlwsw.F +! + ok_ade_omp = .false. + call getin('ok_ade', ok_ade_omp) + +! +!Config Key = ok_aie +!Config Desc = Aerosol indirect effect or not? +!Config Def = .false. +!Config Help = Used in nuage.F and radlwsw.F +! + ok_aie_omp = .false. + call getin('ok_aie', ok_aie_omp) + +! +!Config Key = aerosol_couple +!Config Desc = read aerosol in file or calcul by inca +!Config Def = .false. +!Config Help = Used in physiq.F +! + aerosol_couple_omp = .false. + CALL getin('aerosol_couple',aerosol_couple_omp) + +! +!Config Key = flag_aerosol +!Config Desc = which aerosol is use for coupled model +!Config Def = 1 +!Config Help = Used in physiq.F +! +! - flag_aerosol=1 => so4 only (defaut) +! - flag_aerosol=2 => bc only +! - flag_aerosol=3 => pom only +! - flag_aerosol=4 => seasalt only +! - flag_aerosol=5 => dust only +! - flag_aerosol=6 => all aerosol + + flag_aerosol_omp = 1 + CALL getin('flag_aerosol',flag_aerosol_omp) + +! Temporary variable for testing purpose!! +!Config Key = new_aod +!Config Desc = which calcul of aeropt +!Config Def = false +!Config Help = Used in physiq.F +! + new_aod_omp = .true. + CALL getin('new_aod',new_aod_omp) + +! +!Config Key = aer_type +!Config Desc = Use a constant field for the aerosols +!Config Def = scenario +!Config Help = Used in readaerosol.F90 +! + aer_type_omp = 'scenario' + call getin('aer_type', aer_type_omp) + +! +!Config Key = bl95_b0 +!Config Desc = Parameter in CDNC-maer link (Boucher&Lohmann 1995) +!Config Def = .false. +!Config Help = Used in nuage.F +! + bl95_b0_omp = 2. + call getin('bl95_b0', bl95_b0_omp) + +!Config Key = bl95_b1 +!Config Desc = Parameter in CDNC-maer link (Boucher&Lohmann 1995) +!Config Def = .false. +!Config Help = Used in nuage.F +! + bl95_b1_omp = 0.2 + call getin('bl95_b1', bl95_b1_omp) + +!Config Key = freq_ISCCP +!Config Desc = Frequence d'appel du simulateur ISCCP en secondes; +! par defaut 10800, i.e. 3 heures +!Config Def = 10800. +!Config Help = Used in ini_histISCCP.h +! + freq_ISCCP_omp = 10800. + call getin('freq_ISCCP', freq_ISCCP_omp) +! +!Config Key = ecrit_ISCCP +!Config Desc = Frequence d'ecriture des resultats du simulateur ISCCP en nombre de jours; +! par defaut 1., i.e. 1 jour +!Config Def = 1. +!Config Help = Used in ini_histISCCP.h +! +! + ecrit_ISCCP_omp = 1. + call getin('ecrit_ISCCP', ecrit_ISCCP_omp) + +!Config Key = freq_COSP +!Config Desc = Frequence d'appel du simulateur COSP en secondes; +! par defaut 10800, i.e. 3 heures +!Config Def = 10800. +!Config Help = Used in ini_histdayCOSP.h +! + freq_COSP_omp = 10800. + call getin('freq_COSP', freq_COSP_omp) + +! +!Config Key = ip_ebil_phy +!Config Desc = Niveau de sortie pour les diags bilan d'energie +!Config Def = 0 +!Config Help = +! + ip_ebil_phy_omp = 0 + call getin('ip_ebil_phy', ip_ebil_phy_omp) +! +!Config Key = seuil_inversion +!Config Desc = Seuil ur dTh pour le choix entre les schemas de CL +!Config Def = -0.1 +!Config Help = +! + seuil_inversion_omp = -0.1 + call getin('seuil_inversion', seuil_inversion_omp) + +!! +!! Constante solaire & Parametres orbitaux & taux gaz effet de serre BEG +!! +!Config Key = R_ecc +!Config Desc = Excentricite +!Config Def = 0.016715 +!Config Help = +! +!valeur AMIP II + R_ecc_omp = 0.016715 + call getin('R_ecc', R_ecc_omp) +!! +!Config Key = R_peri +!Config Desc = Equinoxe +!Config Def = +!Config Help = +! +! +!valeur AMIP II + R_peri_omp = 102.7 + call getin('R_peri', R_peri_omp) +!! +!Config Key = R_incl +!Config Desc = Inclinaison +!Config Def = +!Config Help = +! +! +!valeur AMIP II + R_incl_omp = 23.441 + call getin('R_incl', R_incl_omp) +!! +!Config Key = solaire +!Config Desc = Constante solaire en W/m2 +!Config Def = 1365. +!Config Help = +! +! +!valeur AMIP II + solaire_omp = 1365. + call getin('solaire', solaire_omp) +!! +!Config Key = co2_ppm +!Config Desc = concentration du gaz carbonique en ppmv +!Config Def = 348. +!Config Help = +! +! +!valeur AMIP II + co2_ppm_omp = 348. + call getin('co2_ppm', co2_ppm_omp) +!! +!Config Key = RCO2 +!Config Desc = Concentration du CO2 +!Config Def = co2_ppm * 1.0e-06 * 44.011/28.97 +!Config Def = 348. * 1.0e-06 * 44.011/28.97 +!Config Help = +! +! RCO2 = 5.286789092164308E-04 +!ancienne valeur + RCO2_omp = co2_ppm_omp * 1.0e-06 * 44.011/28.97 ! pour co2_ppm=348. + +!! call getin('RCO2', RCO2) +!! +!Config Key = RCH4 +!Config Desc = Concentration du CH4 +!Config Def = 1.65E-06* 16.043/28.97 +!Config Help = +! +! +!valeur AMIP II +!OK RCH4 = 1.65E-06* 16.043/28.97 +! RCH4 = 9.137366240938903E-07 +! +!ancienne valeur +! RCH4 = 1.72E-06* 16.043/28.97 +!OK call getin('RCH4', RCH4) + zzz = 1650. + call getin('CH4_ppb', zzz) + CH4_ppb_omp = zzz + RCH4_omp = CH4_ppb_omp * 1.0E-09 * 16.043/28.97 +!! +!Config Key = RN2O +!Config Desc = Concentration du N2O +!Config Def = 306.E-09* 44.013/28.97 +!Config Help = +! +! +!valeur AMIP II +!OK RN2O = 306.E-09* 44.013/28.97 +! RN2O = 4.648939592682085E-07 +! +!ancienne valeur +! RN2O = 310.E-09* 44.013/28.97 +!OK call getin('RN2O', RN2O) + zzz=306. + call getin('N2O_ppb', zzz) + N2O_ppb_omp = zzz + RN2O_omp = N2O_ppb_omp * 1.0E-09 * 44.013/28.97 +!! +!Config Key = RCFC11 +!Config Desc = Concentration du CFC11 +!Config Def = 280.E-12* 137.3686/28.97 +!Config Help = +! +! +!OK RCFC11 = 280.E-12* 137.3686/28.97 + zzz = 280. + call getin('CFC11_ppt',zzz) + CFC11_ppt_omp = zzz + RCFC11_omp=CFC11_ppt_omp* 1.0E-12 * 137.3686/28.97 +! RCFC11 = 1.327690990680013E-09 +!OK call getin('RCFC11', RCFC11) +!! +!Config Key = RCFC12 +!Config Desc = Concentration du CFC12 +!Config Def = 484.E-12* 120.9140/28.97 +!Config Help = +! +! +!OK RCFC12 = 484.E-12* 120.9140/28.97 + zzz = 484. + call getin('CFC12_ppt',zzz) + CFC12_ppt_omp = zzz + RCFC12_omp = CFC12_ppt_omp * 1.0E-12 * 120.9140/28.97 +! RCFC12 = 2.020102726958923E-09 +!OK call getin('RCFC12', RCFC12) + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +! Constantes precedemment dans dyn3d/conf_gcm + +!Config Key = cycle_diurne +!Config Desc = Cycle ddiurne +!Config Def = y +!Config Help = Cette option permet d'eteidre le cycle diurne. +!Config Peut etre util pour accelerer le code ! + cycle_diurne_omp = .TRUE. + CALL getin('cycle_diurne',cycle_diurne_omp) + +!Config Key = soil_model +!Config Desc = Modele de sol +!Config Def = y +!Config Help = Choix du modele de sol (Thermique ?) +!Config Option qui pourait un string afin de pouvoir +!Config plus de choix ! Ou meme une liste d'options ! + soil_model_omp = .TRUE. + CALL getin('soil_model',soil_model_omp) + +!Config Key = new_oliq +!Config Desc = Nouvelle eau liquide +!Config Def = y +!Config Help = Permet de mettre en route la +!Config nouvelle parametrisation de l'eau liquide ! + new_oliq_omp = .TRUE. + CALL getin('new_oliq',new_oliq_omp) + +!Config Key = ok_orodr +!Config Desc = Orodr ??? +!Config Def = y +!Config Help = Y en a pas comprendre ! +!Config + ok_orodr_omp = .TRUE. + CALL getin('ok_orodr',ok_orodr_omp) + +!Config Key = ok_orolf +!Config Desc = Orolf ?? +!Config Def = y +!Config Help = Connais pas ! + ok_orolf_omp = .TRUE. + CALL getin('ok_orolf', ok_orolf_omp) + +!Config Key = ok_limitvrai +!Config Desc = Force la lecture de la bonne annee +!Config Def = n +!Config Help = On peut forcer le modele a lire le +!Config fichier SST de la bonne annee. C'est une tres bonne +!Config idee, pourquoi ne pas mettre toujours a y ??? + ok_limitvrai_omp = .FALSE. + CALL getin('ok_limitvrai',ok_limitvrai_omp) + +!Config Key = nbapp_rad +!Config Desc = Frequence d'appel au rayonnement +!Config Def = 12 +!Config Help = Nombre d'appels des routines de rayonnements +!Config par jour. + nbapp_rad_omp = 12 + CALL getin('nbapp_rad',nbapp_rad_omp) + +!Config Key = iflag_con +!Config Desc = Flag de convection +!Config Def = 2 +!Config Help = Flag pour la convection les options suivantes existent : +!Config 1 pour LMD, +!Config 2 pour Tiedtke, +!Config 3 pour CCM(NCAR) + iflag_con_omp = 2 + CALL getin('iflag_con',iflag_con_omp) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! +!! Constante solaire & Parametres orbitaux & taux gaz effet de serre END +!! +!! KE +! + +!Config key = cvl_corr +!Config Desc = Facteur multiplication des precip convectives dans KE +!Config Def = 1.00 +!Config Help = 1.02 pour un moderne ou un pre-ind. A ajuster pour un glaciaire + cvl_corr_omp = 1.00 + CALL getin('cvl_corr', cvl_corr_omp) + + +!Config Key = epmax +!Config Desc = Efficacite precip +!Config Def = 0.993 +!Config Help = +! + epmax_omp = .993 + call getin('epmax', epmax_omp) +! +!Config Key = ok_adj_ema +!Config Desc = +!Config Def = false +!Config Help = +! + ok_adj_ema_omp = .false. + call getin('ok_adj_ema',ok_adj_ema_omp) +! +!Config Key = iflag_clw +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_clw_omp = 0 + call getin('iflag_clw',iflag_clw_omp) +! +!Config Key = cld_lc_lsc +!Config Desc = +!Config Def = 2.6e-4 +!Config Help = +! + cld_lc_lsc_omp = 2.6e-4 + call getin('cld_lc_lsc',cld_lc_lsc_omp) +! +!Config Key = cld_lc_con +!Config Desc = +!Config Def = 2.6e-4 +!Config Help = +! + cld_lc_con_omp = 2.6e-4 + call getin('cld_lc_con',cld_lc_con_omp) +! +!Config Key = cld_tau_lsc +!Config Desc = +!Config Def = 3600. +!Config Help = +! + cld_tau_lsc_omp = 3600. + call getin('cld_tau_lsc',cld_tau_lsc_omp) +! +!Config Key = cld_tau_con +!Config Desc = +!Config Def = 3600. +!Config Help = +! + cld_tau_con_omp = 3600. + call getin('cld_tau_con',cld_tau_con_omp) +! +!Config Key = ffallv_lsc +!Config Desc = +!Config Def = 1. +!Config Help = +! + ffallv_lsc_omp = 1. + call getin('ffallv_lsc',ffallv_lsc_omp) +! +!Config Key = ffallv_con +!Config Desc = +!Config Def = 1. +!Config Help = +! + ffallv_con_omp = 1. + call getin('ffallv_con',ffallv_con_omp) +! +!Config Key = coef_eva +!Config Desc = +!Config Def = 2.e-5 +!Config Help = +! + coef_eva_omp = 2.e-5 + call getin('coef_eva',coef_eva_omp) +! +!Config Key = reevap_ice +!Config Desc = +!Config Def = .false. +!Config Help = +! + reevap_ice_omp = .false. + call getin('reevap_ice',reevap_ice_omp) + +!Config Key = iflag_ratqs +!Config Desc = +!Config Def = 1 +!Config Help = +! + iflag_ratqs_omp = 1 + call getin('iflag_ratqs',iflag_ratqs_omp) + +! +!Config Key = iflag_radia +!Config Desc = +!Config Def = 1 +!Config Help = +! + iflag_radia_omp = 1 + call getin('iflag_radia',iflag_radia_omp) + +! +!Config Key = iflag_rrtm +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_rrtm_omp = 0 + call getin('iflag_rrtm',iflag_rrtm_omp) + +! +!Config Key = iflag_cldcon +!Config Desc = +!Config Def = 1 +!Config Help = +! + iflag_cldcon_omp = 1 + call getin('iflag_cldcon',iflag_cldcon_omp) + +! +!Config Key = iflag_pdf +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_pdf_omp = 0 + call getin('iflag_pdf',iflag_pdf_omp) +! +!Config Key = fact_cldcon +!Config Desc = +!Config Def = 0.375 +!Config Help = +! + fact_cldcon_omp = 0.375 + call getin('fact_cldcon',fact_cldcon_omp) + +! +!Config Key = facttemps +!Config Desc = +!Config Def = 1.e-4 +!Config Help = +! + facttemps_omp = 1.e-4 + call getin('facttemps',facttemps_omp) + +! +!Config Key = ok_newmicro +!Config Desc = +!Config Def = .true. +!Config Help = +! + ok_newmicro_omp = .true. + call getin('ok_newmicro',ok_newmicro_omp) +! +!Config Key = ratqsbas +!Config Desc = +!Config Def = 0.01 +!Config Help = +! + ratqsbas_omp = 0.01 + call getin('ratqsbas',ratqsbas_omp) +! +!Config Key = ratqshaut +!Config Desc = +!Config Def = 0.3 +!Config Help = +! + ratqshaut_omp = 0.3 + call getin('ratqshaut',ratqshaut_omp) + +!Config Key = tau_ratqs +!Config Desc = +!Config Def = 1800. +!Config Help = +! + tau_ratqs_omp = 1800. + call getin('tau_ratqs',tau_ratqs_omp) + +! +!----------------------------------------------------------------------- +! Longitude solaire pour le calcul de l'ensoleillement en degre +! si on veut imposer la saison. Sinon, solarlong0=-999.999 +!Config Key = solarlong0 +!Config Desc = +!Config Def = -999.999 +!Config Help = +! + solarlong0_omp = -999.999 + call getin('solarlong0',solarlong0_omp) +! +!----------------------------------------------------------------------- +! Valeur imposee de l'humidite du sol pour le modele bucket. +!Config Key = qsol0 +!Config Desc = +!Config Def = -1. +!Config Help = +! + qsol0_omp = -1. + call getin('qsol0',qsol0_omp) +! +!----------------------------------------------------------------------- +! +!Config Key = inertie_ice +!Config Desc = +!Config Def = 2000. +!Config Help = +! + inertie_ice_omp = 2000. + call getin('inertie_ice',inertie_ice_omp) +! +!Config Key = inertie_sno +!Config Desc = +!Config Def = 2000. +!Config Help = +! + inertie_sno_omp = 2000. + call getin('inertie_sno',inertie_sno_omp) +! +!Config Key = inertie_sol +!Config Desc = +!Config Def = 2000. +!Config Help = +! + inertie_sol_omp = 2000. + call getin('inertie_sol',inertie_sol_omp) + +! +!Config Key = rad_froid +!Config Desc = +!Config Def = 35.0 +!Config Help = +! + rad_froid_omp = 35.0 + call getin('rad_froid',rad_froid_omp) + +! +!Config Key = rad_chau1 +!Config Desc = +!Config Def = 13.0 +!Config Help = +! + rad_chau1_omp = 13.0 + call getin('rad_chau1',rad_chau1_omp) + +! +!Config Key = rad_chau2 +!Config Desc = +!Config Def = 9.0 +!Config Help = +! + rad_chau2_omp = 9.0 + call getin('rad_chau2',rad_chau2_omp) + +! +!Config Key = top_height +!Config Desc = +!Config Def = 3 +!Config Help = +! + top_height_omp = 3 + call getin('top_height',top_height_omp) + +! +!Config Key = overlap +!Config Desc = +!Config Def = 3 +!Config Help = +! + overlap_omp = 3 + call getin('overlap',overlap_omp) + + +! +! +!Config Key = cdmmax +!Config Desc = +!Config Def = 1.3E-3 +!Config Help = +! + cdmmax_omp = 1.3E-3 + call getin('cdmmax',cdmmax_omp) + +! +!Config Key = cdhmax +!Config Desc = +!Config Def = 1.1E-3 +!Config Help = +! + cdhmax_omp = 1.1E-3 + call getin('cdhmax',cdhmax_omp) + +!261103 +! +!Config Key = ksta +!Config Desc = +!Config Def = 1.0e-10 +!Config Help = +! + ksta_omp = 1.0e-10 + call getin('ksta',ksta_omp) + +! +!Config Key = ksta_ter +!Config Desc = +!Config Def = 1.0e-10 +!Config Help = +! + ksta_ter_omp = 1.0e-10 + call getin('ksta_ter',ksta_ter_omp) + +! +!Config Key = ok_kzmin +!Config Desc = +!Config Def = .true. +!Config Help = +! + ok_kzmin_omp = .true. + call getin('ok_kzmin',ok_kzmin_omp) + +! +!Config Key = fmagic +!Config Desc = additionnal multiplicator factor used for albedo +!Config Def = 1. +!Config Help = additionnal multiplicator factor used in albedo.F +! + fmagic_omp = 1. + call getin('fmagic',fmagic_omp) + +! +!Config Key = pmagic +!Config Desc = additional factor used for albedo +!Config Def = 0. +!Config Help = additional factor used in albedo.F +! + pmagic_omp = 0. + call getin('pmagic',pmagic_omp) + + +!Config Key = ok_lic_melt +!Config Desc = Prise en compte de la fonte de la calotte dans le bilan d'eau +!Config Def = .false. +!Config Help = mettre a .false. pour assurer la conservation en eau + ok_lic_melt_omp = .false. + call getin('ok_lic_melt', ok_lic_melt_omp) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! PARAMETER FOR THE PLANETARY BOUNDARY LAYER +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!Config Key = iflag_pbl +!Config Desc = +!Config Def = 1 +!Config Help = +! + iflag_pbl_omp = 1 + call getin('iflag_pbl',iflag_pbl_omp) +! +!Config Key = iflag_thermals +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_thermals_omp = 0 + call getin('iflag_thermals',iflag_thermals_omp) +! +! +!Config Key = iflag_thermals_ed +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_thermals_ed_omp = 0 + call getin('iflag_thermals_ed',iflag_thermals_ed_omp) +! +! +!Config Key = iflag_thermals_optflux +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_thermals_optflux_omp = 0 + call getin('iflag_thermals_optflux',iflag_thermals_optflux_omp) +! +! +!Config Key = nsplit_thermals +!Config Desc = +!Config Def = 1 +!Config Help = +! + nsplit_thermals_omp = 1 + call getin('nsplit_thermals',nsplit_thermals_omp) + +!Config Key = tau_thermals +!Config Desc = +!Config Def = 0. +!Config Help = +! + tau_thermals_omp = 0. + call getin('tau_thermals',tau_thermals_omp) + +! +!Config Key = iflag_coupl +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_coupl_omp = 0 + call getin('iflag_coupl',iflag_coupl_omp) + +! +!Config Key = iflag_clos +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_clos_omp = 1 + call getin('iflag_clos',iflag_clos_omp) +! +!Config Key = iflag_cvl_sigd +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_cvl_sigd_omp = 0 + call getin('iflag_cvl_sigd',iflag_cvl_sigd_omp) + +!Config Key = iflag_wake +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_wake_omp = 0 + call getin('iflag_wake',iflag_wake_omp) + +! +!Config Key = lev_histhf +!Config Desc = +!Config Def = 1 +!Config Help = +! + lev_histhf_omp = 1 + call getin('lev_histhf',lev_histhf_omp) + +! +!Config Key = lev_histday +!Config Desc = +!Config Def = 1 +!Config Help = +! + lev_histday_omp = 1 + call getin('lev_histday',lev_histday_omp) + +! +!Config Key = lev_histmth +!Config Desc = +!Config Def = 2 +!Config Help = +! + lev_histmth_omp = 2 + call getin('lev_histmth',lev_histmth_omp) +! +!Config Key = lev_histins +!Config Desc = +!Config Def = 1 +!Config Help = +! + lev_histins_omp = 1 + call getin('lev_histins',lev_histins_omp) + ! +!Config Key = lev_histLES +!Config Desc = +!Config Def = 1 +!Config Help = +! + lev_histLES_omp = 1 + call getin('lev_histLES',lev_histLES_omp) + ! +!Config Key = type_run +!Config Desc = +!Config Def = 'AMIP'/'CFMIP' ou 'CLIM'/'ENSP' +!Config Help = +! + type_run_omp = 'AMIP' + call getin('type_run',type_run_omp) + +! +!Config Key = ok_isccp +!Config Desc = +!Config Def = .true. +!Config Help = +! +! ok_isccp = .true. + ok_isccp_omp = .false. + call getin('ok_isccp',ok_isccp_omp) + +! +!Config Key = ok_cosp +!Config Desc = +!Config Def = .false. +!Config Help = +! + ok_cosp_omp = .false. + call getin('ok_cosp',ok_cosp_omp) + +! +! coordonnees (lonmin_ins, lonmax_ins, latmin_ins, latmax_ins) pour la zone +! avec sorties instantannees tous les pas de temps de la physique => "histbilKP_ins.nc" +! +!Config Key = lonmin_ins +!Config Desc = 100. +!Config Def = longitude minimale sorties "bilKP_ins" +!Config Help = +! + lonmin_ins_omp = 100. + call getin('lonmin_ins',lonmin_ins_omp) +! +!Config Key = lonmax_ins +!Config Desc = 130. +!Config Def = longitude maximale sorties "bilKP_ins" +!Config Help = +! + lonmax_ins_omp = 130. + call getin('lonmax_ins',lonmax_ins_omp) +! +!Config Key = latmin_ins +!Config Desc = -20. +!Config Def = latitude minimale sorties "bilKP_ins" +!Config Help = +! + latmin_ins_omp = -20. + call getin('latmin_ins',latmin_ins_omp) +! +!Config Key = latmax_ins +!Config Desc = 20. +!Config Def = latitude maximale sorties "bilKP_ins" +!Config Help = +! + latmax_ins_omp = 20. + call getin('latmax_ins',latmax_ins_omp) +! +!Config Key = ecrit_hf +!Config Desc = +!Config Def = 1./8. !toutes les 3h +!Config Help = +! + ecrit_hf_omp = 1./8. + call getin('ecrit_hf',ecrit_hf_omp) +! +!Config Key = ecrit_ins +!Config Desc = +!Config Def = 1./48. ! toutes les 1/2 h +!Config Help = +! + ecrit_ins_omp = 1./48. + call getin('ecrit_ins',ecrit_ins_omp) +! +!Config Key = ecrit_day +!Config Desc = +!Config Def = 1.0 !tous les jours +!Config Help = nombre de jours pour ecriture fichier histday.nc +! + ecrit_day_omp = 1.0 + call getin('ecrit_day',ecrit_day_omp) +! +!Config Key = ecrit_mth +!Config Desc = +!Config Def = 30. !tous les 30jours (1 fois par mois) +!Config Help = +! + ecrit_mth_omp = 30. + call getin('ecrit_mth',ecrit_mth_omp) +! +!Config Key = ecrit_tra +!Config Desc = +!Config Def = 30. !tous les 30jours (1 fois par mois) +!Config Help = +! + ecrit_tra_omp = 30. + call getin('ecrit_tra',ecrit_tra_omp) +! +!Config Key = ecrit_reg +!Config Desc = +!Config Def = 0.25 !4 fois par jour +!Config Help = +! + ecrit_reg_omp = 0.25 !4 fois par jour + call getin('ecrit_reg',ecrit_reg_omp) +! +! +! +! PARAMETRES CDRAG +! +!Config Key = f_cdrag_ter +!Config Desc = +!Config Def = 0.8 +!Config Help = +! + f_cdrag_ter_omp = 0.8 + call getin('f_cdrag_ter',f_cdrag_ter_omp) +! +!Config Key = f_cdrag_oce +!Config Desc = +!Config Def = 0.8 +!Config Help = +! + f_cdrag_oce_omp = 0.8 + call getin('f_cdrag_oce',f_cdrag_oce_omp) +! +! RUGORO +!Config Key = f_rugoro +!Config Desc = +!Config Def = 0. +!Config Help = +! + f_rugoro_omp = 0. + call getin('f_rugoro',f_rugoro_omp) + +! PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS +! +!Config Key = supcrit1 +!Config Desc = +!Config Def = .540 +!Config Help = +! + supcrit1_omp = .540 + call getin('supcrit1',supcrit1_omp) + +! +!Config Key = supcrit2 +!Config Desc = +!Config Def = .600 +!Config Help = +! + supcrit2_omp = .600 + call getin('supcrit2',supcrit2_omp) + +! +! PARAMETERS FOR THE MIXING DISTRIBUTION +! +! +!Config Key = iflag_mix +!Config Desc = +!Config Def = 1 +!Config Help = +! + iflag_mix_omp = 1 + call getin('iflag_mix',iflag_mix_omp) + +! +!Config Key = scut +!Config Desc = +!Config Def = 0.95 +!Config Help = +! + scut_omp = 0.95 + call getin('scut',scut_omp) + +! +!Config Key = qqa1 +!Config Desc = +!Config Def = 1.0 +!Config Help = +! + qqa1_omp = 1.0 + call getin('qqa1',qqa1_omp) + +! +!Config Key = qqa2 +!Config Desc = +!Config Def = 0.0 +!Config Help = +! + qqa2_omp = 0.0 + call getin('qqa2',qqa2_omp) + +! +!Config Key = gammas +!Config Desc = +!Config Def = 0.05 +!Config Help = +! + gammas_omp = 0.05 + call getin('gammas',gammas_omp) + +! +!Config Key = Fmax +!Config Desc = +!Config Def = 0.65 +!Config Help = +! + Fmax_omp = 0.65 + call getin('Fmax',Fmax_omp) + +! +!Config Key = alphas +!Config Desc = +!Config Def = -5. +!Config Help = +! + alphas_omp = -5. + call getin('alphas',alphas_omp) + +!Config key = ok_strato +!Config Desc = activation de la version strato +!Config Def = .FALSE. +!Config Help = active la version stratosphérique de LMDZ de F. Lott + + ok_strato_omp=.FALSE. + CALL getin('ok_strato',ok_strato_omp) + +!Config key = ok_hines +!Config Desc = activation de la parametrisation de hines +!Config Def = .FALSE. +!Config Help = Clefs controlant la parametrization de Hines +! Et la sponge layer (Runs Stratospheriques) + + ok_hines_omp=.FALSE. + CALL getin('ok_hines',ok_hines_omp) + +!Config Key = OK_LES +!Config Desc = Pour des sorties LES +!Config Def = .false. +!Config Help = Pour creer le fichier histLES contenant les sorties +! LES +! + ok_LES_omp = .false. + call getin('OK_LES', ok_LES_omp) +! +!Config Key = ecrit_LES +!Config Desc = Frequence d'ecriture des resultats du LES en nombre de jours; +! par defaut 1., i.e. 1 jour +!Config Def = 1./8. +!Config Help = ... +! +! + ecrit_LES_omp = 1./8. + call getin('ecrit_LES', ecrit_LES_omp) +! + read_climoz = 0 ! default value + call getin('read_climoz', read_climoz) + + carbon_cycle_tr_omp=.FALSE. + CALL getin('carbon_cycle_tr',carbon_cycle_tr_omp) + + carbon_cycle_cpl_omp=.FALSE. + CALL getin('carbon_cycle_cpl',carbon_cycle_cpl_omp) + +!$OMP END MASTER +!$OMP BARRIER + + R_ecc = R_ecc_omp + R_peri = R_peri_omp + R_incl = R_incl_omp + solaire = solaire_omp + co2_ppm = co2_ppm_omp + RCO2 = RCO2_omp + CH4_ppb = CH4_ppb_omp + RCH4 = RCH4_omp + N2O_ppb = N2O_ppb_omp + RN2O = RN2O_omp + CFC11_ppt = CFC11_ppt_omp + RCFC11 = RCFC11_omp + CFC12_ppt = CFC12_ppt_omp + RCFC12 = RCFC12_omp + + cycle_diurne = cycle_diurne_omp + soil_model = soil_model_omp + new_oliq = new_oliq_omp + ok_orodr = ok_orodr_omp + ok_orolf = ok_orolf_omp + ok_limitvrai = ok_limitvrai_omp + nbapp_rad = nbapp_rad_omp + iflag_con = iflag_con_omp + + epmax = epmax_omp + ok_adj_ema = ok_adj_ema_omp + iflag_clw = iflag_clw_omp + cld_lc_lsc = cld_lc_lsc_omp + cld_lc_con = cld_lc_con_omp + cld_tau_lsc = cld_tau_lsc_omp + cld_tau_con = cld_tau_con_omp + ffallv_lsc = ffallv_lsc_omp + ffallv_con = ffallv_con_omp + coef_eva = coef_eva_omp + reevap_ice = reevap_ice_omp + iflag_pdf = iflag_pdf_omp + solarlong0 = solarlong0_omp + qsol0 = qsol0_omp + inertie_sol = inertie_sol_omp + inertie_ice = inertie_ice_omp + inertie_sno = inertie_sno_omp + rad_froid = rad_froid_omp + rad_chau1 = rad_chau1_omp + rad_chau2 = rad_chau2_omp + top_height = top_height_omp + overlap = overlap_omp + cdmmax = cdmmax_omp + cdhmax = cdhmax_omp + ksta = ksta_omp + ksta_ter = ksta_ter_omp + ok_kzmin = ok_kzmin_omp + fmagic = fmagic_omp + pmagic = pmagic_omp + iflag_pbl = iflag_pbl_omp + lev_histhf = lev_histhf_omp + lev_histday = lev_histday_omp + lev_histmth = lev_histmth_omp + lev_histins = lev_histins_omp + lev_histLES = lev_histLES_omp + + type_ocean = type_ocean_omp + version_ocean = version_ocean_omp + ok_veget = ok_veget_omp + ok_newmicro = ok_newmicro_omp + ok_journe = ok_journe_omp + ok_hf = ok_hf_omp + ok_mensuel = ok_mensuel_omp + ok_instan = ok_instan_omp + freq_ISCCP = freq_ISCCP_omp + ecrit_ISCCP = ecrit_ISCCP_omp + freq_COSP = freq_COSP_omp + ok_ade = ok_ade_omp + ok_aie = ok_aie_omp + aerosol_couple = aerosol_couple_omp + flag_aerosol=flag_aerosol_omp + new_aod=new_aod_omp + aer_type = aer_type_omp + bl95_b0 = bl95_b0_omp + bl95_b1 = bl95_b1_omp + fact_cldcon = fact_cldcon_omp + facttemps = facttemps_omp + ratqsbas = ratqsbas_omp + ratqshaut = ratqshaut_omp + tau_ratqs = tau_ratqs_omp + + iflag_radia = iflag_radia_omp + iflag_rrtm = iflag_rrtm_omp + iflag_cldcon = iflag_cldcon_omp + iflag_ratqs = iflag_ratqs_omp + ip_ebil_phy = ip_ebil_phy_omp + iflag_thermals = iflag_thermals_omp + iflag_thermals_ed = iflag_thermals_ed_omp + iflag_thermals_optflux = iflag_thermals_optflux_omp + nsplit_thermals = nsplit_thermals_omp + tau_thermals = tau_thermals_omp + iflag_coupl = iflag_coupl_omp + iflag_clos = iflag_clos_omp + iflag_wake = iflag_wake_omp + iflag_cvl_sigd = iflag_cvl_sigd_omp + type_run = type_run_omp + ok_isccp = ok_isccp_omp + ok_cosp = ok_cosp_omp + seuil_inversion=seuil_inversion_omp + lonmin_ins = lonmin_ins_omp + lonmax_ins = lonmax_ins_omp + latmin_ins = latmin_ins_omp + latmax_ins = latmax_ins_omp + ecrit_hf = ecrit_hf_omp + ecrit_ins = ecrit_ins_omp + ecrit_day = ecrit_day_omp + ecrit_mth = ecrit_mth_omp + ecrit_tra = ecrit_tra_omp + ecrit_reg = ecrit_reg_omp + cvl_corr = cvl_corr_omp + ok_lic_melt = ok_lic_melt_omp + f_cdrag_ter=f_cdrag_ter_omp + f_cdrag_oce=f_cdrag_oce_omp + f_rugoro=f_rugoro_omp + supcrit1 = supcrit1_omp + supcrit2 = supcrit2_omp + iflag_mix = iflag_mix_omp + scut = scut_omp + qqa1 = qqa1_omp + qqa2 = qqa2_omp + gammas = gammas_omp + Fmax = Fmax_omp + alphas = alphas_omp + ok_strato = ok_strato_omp + ok_hines = ok_hines_omp + ok_LES = ok_LES_omp + ecrit_LES = ecrit_LES_omp + carbon_cycle_tr = carbon_cycle_tr_omp + carbon_cycle_cpl = carbon_cycle_cpl_omp + +! Test of coherence between type_ocean and version_ocean + IF (type_ocean=='couple' .AND. (version_ocean/='opa8' .AND. version_ocean/='nemo') ) THEN + WRITE(numout,*)' ERROR version_ocean=',version_ocean,' not valid in coupled configuration' + CALL abort_gcm('conf_phys','version_ocean not valid',1) + END IF + + IF (type_ocean=='slab' .AND. version_ocean=='xxxxxx') THEN + version_ocean='sicOBS' + ELSE IF (type_ocean=='slab' .AND. version_ocean/='sicOBS') THEN + WRITE(numout,*)' ERROR version_ocean=',version_ocean,' not valid with slab ocean' + CALL abort_gcm('conf_phys','version_ocean not valid',1) + END IF + +! Test sur new_aod. Ce flag permet de retrouver les resultats de l'AR4 +! il n'est utilisable que lors du couplage avec le SO4 seul + IF (ok_ade .OR. ok_aie) THEN + IF ( .NOT. new_aod .AND. flag_aerosol .NE. 1) THEN + CALL abort_gcm('conf_phys','new_aod=.FALSE. not compatible avec flag_aerosol=1',1) + END IF + END IF + +!$OMP MASTER + + write(numout,*)' ##############################################' + write(numout,*)' Configuration des parametres de la physique: ' + write(numout,*)' Type ocean = ', type_ocean + write(numout,*)' Version ocean = ', version_ocean + write(numout,*)' Config veget = ', ok_veget + write(numout,*)' Sortie journaliere = ', ok_journe + write(numout,*)' Sortie haute frequence = ', ok_hf + write(numout,*)' Sortie mensuelle = ', ok_mensuel + write(numout,*)' Sortie instantanee = ', ok_instan + write(numout,*)' Frequence appel simulateur ISCCP, freq_ISCCP =', freq_ISCCP + write(numout,*)' Frequence appel simulateur ISCCP, ecrit_ISCCP =', ecrit_ISCCP + write(numout,*)' Frequence appel simulateur COSP, freq_COSP =', freq_COSP + write(numout,*)' Sortie bilan d''energie, ip_ebil_phy =', ip_ebil_phy + write(numout,*)' Excentricite = ',R_ecc + write(numout,*)' Equinoxe = ',R_peri + write(numout,*)' Inclinaison =',R_incl + write(numout,*)' Constante solaire =',solaire + write(numout,*)' co2_ppm =',co2_ppm + write(numout,*)' RCO2 = ',RCO2 + write(numout,*)' CH4_ppb =',CH4_ppb,' RCH4 = ',RCH4 + write(numout,*)' N2O_ppb =',N2O_ppb,' RN2O = ',RN2O + write(numout,*)' CFC11_ppt=',CFC11_ppt,' RCFC11 = ',RCFC11 + write(numout,*)' CFC12_ppt=',CFC12_ppt,' RCFC12 = ',RCFC12 + write(numout,*)' cvl_corr=', cvl_corr + write(numout,*)'ok_lic_melt=', ok_lic_melt + write(numout,*)'cycle_diurne=',cycle_diurne + write(numout,*)'soil_model=',soil_model + write(numout,*)'new_oliq=',new_oliq + write(numout,*)'ok_orodr=',ok_orodr + write(numout,*)'ok_orolf=',ok_orolf + write(numout,*)'ok_limitvrai=',ok_limitvrai + write(numout,*)'nbapp_rad=',nbapp_rad + write(numout,*)'iflag_con=',iflag_con + write(numout,*)' epmax = ', epmax + write(numout,*)' ok_adj_ema = ', ok_adj_ema + write(numout,*)' iflag_clw = ', iflag_clw + write(numout,*)' cld_lc_lsc = ', cld_lc_lsc + write(numout,*)' cld_lc_con = ', cld_lc_con + write(numout,*)' cld_tau_lsc = ', cld_tau_lsc + write(numout,*)' cld_tau_con = ', cld_tau_con + write(numout,*)' ffallv_lsc = ', ffallv_lsc + write(numout,*)' ffallv_con = ', ffallv_con + write(numout,*)' coef_eva = ', coef_eva + write(numout,*)' reevap_ice = ', reevap_ice + write(numout,*)' iflag_pdf = ', iflag_pdf + write(numout,*)' iflag_cldcon = ', iflag_cldcon + write(numout,*)' iflag_radia = ', iflag_radia + write(numout,*)' iflag_rrtm = ', iflag_rrtm + write(numout,*)' iflag_ratqs = ', iflag_ratqs + write(numout,*)' seuil_inversion = ', seuil_inversion + write(numout,*)' fact_cldcon = ', fact_cldcon + write(numout,*)' facttemps = ', facttemps + write(numout,*)' ok_newmicro = ',ok_newmicro + write(numout,*)' ratqsbas = ',ratqsbas + write(numout,*)' ratqshaut = ',ratqshaut + write(numout,*)' tau_ratqs = ',tau_ratqs + write(numout,*)' top_height = ',top_height + write(numout,*)' overlap = ',overlap + write(numout,*)' cdmmax = ',cdmmax + write(numout,*)' cdhmax = ',cdhmax + write(numout,*)' ksta = ',ksta + write(numout,*)' ksta_ter = ',ksta_ter + write(numout,*)' ok_kzmin = ',ok_kzmin + write(numout,*)' fmagic = ',fmagic + write(numout,*)' pmagic = ',pmagic + write(numout,*)' ok_ade = ',ok_ade + write(numout,*)' ok_aie = ',ok_aie + write(numout,*)' aerosol_couple = ', aerosol_couple + write(numout,*)' flag_aerosol = ', flag_aerosol + write(numout,*)' new_aod = ', new_aod + write(numout,*)' aer_type = ',aer_type + write(numout,*)' bl95_b0 = ',bl95_b0 + write(numout,*)' bl95_b1 = ',bl95_b1 + write(numout,*)' lev_histhf = ',lev_histhf + write(numout,*)' lev_histday = ',lev_histday + write(numout,*)' lev_histmth = ',lev_histmth + write(numout,*)' lev_histins = ',lev_histins + write(numout,*)' lev_histLES = ',lev_histLES + write(numout,*)' iflag_pbl = ', iflag_pbl + write(numout,*)' iflag_thermals = ', iflag_thermals + write(numout,*)' iflag_thermals_ed = ', iflag_thermals_ed + write(numout,*)' iflag_thermals_optflux = ', iflag_thermals_optflux + write(numout,*)' iflag_clos = ', iflag_clos + write(numout,*)' type_run = ',type_run + write(numout,*)' ok_isccp = ',ok_isccp + write(numout,*)' ok_cosp = ',ok_cosp + write(numout,*)' solarlong0 = ', solarlong0 + write(numout,*)' qsol0 = ', qsol0 + write(numout,*)' inertie_sol = ', inertie_sol + write(numout,*)' inertie_ice = ', inertie_ice + write(numout,*)' inertie_sno = ', inertie_sno + write(numout,*)' f_cdrag_ter = ',f_cdrag_ter + write(numout,*)' f_cdrag_oce = ',f_cdrag_oce + write(numout,*)' f_rugoro = ',f_rugoro + write(numout,*)' supcrit1 = ', supcrit1 + write(numout,*)' supcrit2 = ', supcrit2 + write(numout,*)' iflag_mix = ', iflag_mix + write(numout,*)' scut = ', scut + write(numout,*)' qqa1 = ', qqa1 + write(numout,*)' qqa2 = ', qqa2 + write(numout,*)' gammas = ', gammas + write(numout,*)' Fmax = ', Fmax + write(numout,*)' alphas = ', alphas + + write(numout,*)' lonmin lonmax latmin latmax bilKP_ins =',& + lonmin_ins, lonmax_ins, latmin_ins, latmax_ins + write(numout,*)' ecrit_ hf, ins, day, mth, reg, tra, ISCCP, LES',& + ecrit_hf, ecrit_ins, ecrit_day, ecrit_mth, ecrit_reg, ecrit_tra, ecrit_ISCCP, ecrit_LES + + write(numout,*) 'ok_strato = ', ok_strato + write(numout,*) 'ok_hines = ', ok_hines + write(numout,*) 'read_climoz = ', read_climoz + write(numout,*) 'carbon_cycle_tr = ', carbon_cycle_tr + write(numout,*) 'carbon_cycle_cpl = ', carbon_cycle_cpl + +!$OMP END MASTER + + return + + end subroutine conf_phys + +end module conf_phys_m +! +!################################################################# +! + + subroutine conf_interface(tau_calv) + + use IOIPSL + implicit none + +! Configuration de l'interace atm/surf +! +! tau_calv: temps de relaxation pour la fonte des glaciers + + REAL :: tau_calv + REAL,SAVE :: tau_calv_omp + +! Local + integer :: numout = 6 +! +!Config Key = tau_calv +!Config Desc = temps de relaxation pour fonte des glaciers en jours +!Config Def = 1 an +!Config Help = +! + tau_calv_omp = 360.*10. +!$OMP MASTER + call getin('tau_calv',tau_calv_omp) +!$OMP END MASTER +!$OMP BARRIER + + tau_calv=tau_calv_omp + +!$OMP MASTER + write(numout,*)' ##############################################' + WRITE(numout,*)' Configuration de l''interface atm/surfaces : ' + WRITE(numout,*)' tau_calv = ',tau_calv +!$OMP END MASTER + + return + + end subroutine conf_interface Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conflx.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conflx.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conflx.F (revision 1280) @@ -0,0 +1,1676 @@ +! +! $Header$ +! + SUBROUTINE conflx (dtime,pres_h,pres_f, + e t, q, con_t, con_q, pqhfl, w, + s d_t, d_q, rain, snow, + s pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, + s kcbot, kctop, kdtop, pmflxr, pmflxs) +c + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19941014 +c Objet: Schema flux de masse pour la convection +c (schema de Tiedtke avec qqs modifications mineures) +c Dec.97: Prise en compte des modifications introduites par +c Olivier Boucher et Alexandre Armengaud pour melange +c et lessivage des traceurs passifs. +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +c Entree: + REAL dtime ! pas d'integration (s) + REAL pres_h(klon,klev+1) ! pression half-level (Pa) + REAL pres_f(klon,klev)! pression full-level (Pa) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (g/g) + REAL w(klon,klev) ! vitesse verticale (Pa/s) + REAL con_t(klon,klev) ! convergence de temperature (K/s) + REAL con_q(klon,klev) ! convergence de l'eau vapeur (g/g/s) + REAL pqhfl(klon) ! evaporation (negative vers haut) mm/s +c Sortie: + REAL d_t(klon,klev) ! incrementation de temperature + REAL d_q(klon,klev) ! incrementation d'humidite + REAL pmfu(klon,klev) ! flux masse (kg/m2/s) panache ascendant + REAL pmfd(klon,klev) ! flux masse (kg/m2/s) panache descendant + REAL pen_u(klon,klev) + REAL pen_d(klon,klev) + REAL pde_u(klon,klev) + REAL pde_d(klon,klev) + REAL rain(klon) ! pluie (mm/s) + REAL snow(klon) ! neige (mm/s) + REAL pmflxr(klon,klev+1) + REAL pmflxs(klon,klev+1) + INTEGER kcbot(klon) ! niveau du bas de la convection + INTEGER kctop(klon) ! niveau du haut de la convection + INTEGER kdtop(klon) ! niveau du haut des downdrafts +c Local: + REAL pt(klon,klev) + REAL pq(klon,klev) + REAL pqs(klon,klev) + REAL pvervel(klon,klev) + LOGICAL land(klon) +c + REAL d_t_bis(klon,klev) + REAL d_q_bis(klon,klev) + REAL paprs(klon,klev+1) + REAL paprsf(klon,klev) + REAL zgeom(klon,klev) + REAL zcvgq(klon,klev) + REAL zcvgt(klon,klev) +cAA + REAL zmfu(klon,klev) + REAL zmfd(klon,klev) + REAL zen_u(klon,klev) + REAL zen_d(klon,klev) + REAL zde_u(klon,klev) + REAL zde_d(klon,klev) + REAL zmflxr(klon,klev+1) + REAL zmflxs(klon,klev+1) +cAA + +c + INTEGER i, k + REAL zdelta, zqsat +c +#include "FCTTRE.h" +c +c initialiser les variables de sortie (pour securite) + DO i = 1, klon + rain(i) = 0.0 + snow(i) = 0.0 + kcbot(i) = 0 + kctop(i) = 0 + kdtop(i) = 0 + ENDDO + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + pmfu(i,k) = 0.0 + pmfd(i,k) = 0.0 + pen_u(i,k) = 0.0 + pde_u(i,k) = 0.0 + pen_d(i,k) = 0.0 + pde_d(i,k) = 0.0 + zmfu(i,k) = 0.0 + zmfd(i,k) = 0.0 + zen_u(i,k) = 0.0 + zde_u(i,k) = 0.0 + zen_d(i,k) = 0.0 + zde_d(i,k) = 0.0 + ENDDO + ENDDO + DO k = 1, klev+1 + DO i = 1, klon + zmflxr(i,k) = 0.0 + zmflxs(i,k) = 0.0 + ENDDO + ENDDO +c +c calculer la nature du sol (pour l'instant, ocean partout) + DO i = 1, klon + land(i) = .FALSE. + ENDDO +c +c preparer les variables d'entree (attention: l'ordre des niveaux +c verticaux augmente du haut vers le bas) + DO k = 1, klev + DO i = 1, klon + pt(i,k) = t(i,klev-k+1) + pq(i,k) = q(i,klev-k+1) + paprsf(i,k) = pres_f(i,klev-k+1) + paprs(i,k) = pres_h(i,klev+1-k+1) + pvervel(i,k) = w(i,klev+1-k) + zcvgt(i,k) = con_t(i,klev-k+1) + zcvgq(i,k) = con_q(i,klev-k+1) +c + zdelta=MAX(0.,SIGN(1.,RTT-pt(i,k))) + zqsat=R2ES*FOEEW ( pt(i,k), zdelta ) / paprsf(i,k) + zqsat=MIN(0.5,zqsat) + zqsat=zqsat/(1.-RETV *zqsat) + pqs(i,k) = zqsat + ENDDO + ENDDO + DO i = 1, klon + paprs(i,klev+1) = pres_h(i,1) + zgeom(i,klev) = RD * pt(i,klev) + . / (0.5*(paprs(i,klev+1)+paprsf(i,klev))) + . * (paprs(i,klev+1)-paprsf(i,klev)) + ENDDO + DO k = klev-1, 1, -1 + DO i = 1, klon + zgeom(i,k) = zgeom(i,k+1) + . + RD * 0.5*(pt(i,k+1)+pt(i,k)) / paprs(i,k+1) + . * (paprsf(i,k+1)-paprsf(i,k)) + ENDDO + ENDDO +c +c appeler la routine principale +c + CALL flxmain(dtime, pt, pq, pqs, pqhfl, + . paprsf, paprs, zgeom, land, zcvgt, zcvgq, pvervel, + . rain, snow, kcbot, kctop, kdtop, + . zmfu, zmfd, zen_u, zde_u, zen_d, zde_d, + . d_t_bis, d_q_bis, zmflxr, zmflxs) +C +cAA-------------------------------------------------------- +cAA rem : De la meme facon que l'on effectue le reindicage +cAA pour la temperature t et le champ q +cAA on reindice les flux necessaires a la convection +cAA des traceurs +cAA-------------------------------------------------------- + DO k = 1, klev + DO i = 1, klon + d_q(i,klev+1-k) = dtime*d_q_bis(i,k) + d_t(i,klev+1-k) = dtime*d_t_bis(i,k) + ENDDO + ENDDO +c + DO i = 1, klon + pmfu(i,1)= 0. + pmfd(i,1)= 0. + pen_d(i,1)= 0. + pde_d(i,1)= 0. + ENDDO + + DO k = 2, klev + DO i = 1, klon + pmfu(i,klev+2-k)= zmfu(i,k) + pmfd(i,klev+2-k)= zmfd(i,k) + ENDDO + ENDDO +c + DO k = 1, klev + DO i = 1, klon + pen_u(i,klev+1-k)= zen_u(i,k) + pde_u(i,klev+1-k)= zde_u(i,k) + ENDDO + ENDDO +c + DO k = 1, klev-1 + DO i = 1, klon + pen_d(i,klev+1-k)= -zen_d(i,k+1) + pde_d(i,klev+1-k)= -zde_d(i,k+1) + ENDDO + ENDDO + + DO k = 1, klev+1 + DO i = 1, klon + pmflxr(i,klev+2-k)= zmflxr(i,k) + pmflxs(i,klev+2-k)= zmflxs(i,k) + ENDDO + ENDDO + + RETURN + END +c-------------------------------------------------------------------- + SUBROUTINE flxmain(pdtime, pten, pqen, pqsen, pqhfl, pap, paph, + . pgeo, ldland, ptte, pqte, pvervel, + . prsfc, pssfc, kcbot, kctop, kdtop, +c * ldcum, ktype, + . pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, + . dt_con, dq_con, pmflxr, pmflxs) + USE dimphy + IMPLICIT none +C ------------------------------------------------------------------ +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "YOECUMF.h" +C ---------------------------------------------------------------- + REAL pten(klon,klev), pqen(klon,klev), pqsen(klon,klev) + REAL ptte(klon,klev) + REAL pqte(klon,klev) + REAL pvervel(klon,klev) + REAL pgeo(klon,klev), pap(klon,klev), paph(klon,klev+1) + REAL pqhfl(klon) +c + REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev) + REAL plude(klon,klev) + REAL pmfu(klon,klev) + REAL prsfc(klon), pssfc(klon) + INTEGER kcbot(klon), kctop(klon), ktype(klon) + LOGICAL ldland(klon), ldcum(klon) +c + REAL ztenh(klon,klev), zqenh(klon,klev), zqsenh(klon,klev) + REAL zgeoh(klon,klev) + REAL zmfub(klon), zmfub1(klon) + REAL zmfus(klon,klev), zmfuq(klon,klev), zmful(klon,klev) + REAL zdmfup(klon,klev), zdpmel(klon,klev) + REAL zentr(klon), zhcbase(klon) + REAL zdqpbl(klon), zdqcv(klon), zdhpbl(klon) + REAL zrfl(klon) + REAL pmflxr(klon,klev+1) + REAL pmflxs(klon,klev+1) + INTEGER ilab(klon,klev), ictop0(klon) + LOGICAL llo1 + REAL dt_con(klon,klev), dq_con(klon,klev) + REAL zmfmax, zdh + REAL pdtime, zqumqe, zdqmin, zalvdcp, zhsat, zzz + REAL zhhat, zpbmpt, zgam, zeps, zfac + INTEGER i, k, ikb, itopm2, kcum +c + REAL pen_u(klon,klev), pde_u(klon,klev) + REAL pen_d(klon,klev), pde_d(klon,klev) +c + REAL ptd(klon,klev), pqd(klon,klev), pmfd(klon,klev) + REAL zmfds(klon,klev), zmfdq(klon,klev), zdmfdp(klon,klev) + INTEGER kdtop(klon) + LOGICAL lddraf(klon) +C--------------------------------------------------------------------- + LOGICAL firstcal + SAVE firstcal + DATA firstcal / .TRUE. / +c$OMP THREADPRIVATE(firstcal) +C--------------------------------------------------------------------- + IF (firstcal) THEN + CALL flxsetup + firstcal = .FALSE. + ENDIF +C--------------------------------------------------------------------- + DO i = 1, klon + ldcum(i) = .FALSE. + ENDDO + DO k = 1, klev + DO i = 1, klon + dt_con(i,k) = 0.0 + dq_con(i,k) = 0.0 + ENDDO + ENDDO +c---------------------------------------------------------------------- +c initialiser les variables et faire l'interpolation verticale +c---------------------------------------------------------------------- + CALL flxini(pten, pqen, pqsen, pgeo, + . paph, zgeoh, ztenh, zqenh, zqsenh, + . ptu, pqu, ptd, pqd, pmfd, zmfds, zmfdq, zdmfdp, + . pmfu, zmfus, zmfuq, zdmfup, + . zdpmel, plu, plude, ilab, pen_u, pde_u, pen_d, pde_d) +c--------------------------------------------------------------------- +c determiner les valeurs au niveau de base de la tour convective +c--------------------------------------------------------------------- + CALL flxbase(ztenh, zqenh, zgeoh, paph, + * ptu, pqu, plu, ldcum, kcbot, ilab) +c--------------------------------------------------------------------- +c calculer la convergence totale de l'humidite et celle en provenance +c de la couche limite, plus precisement, la convergence integree entre +c le sol et la base de la convection. Cette derniere convergence est +c comparee avec l'evaporation obtenue dans la couche limite pour +c determiner le type de la convection +c--------------------------------------------------------------------- + k=1 + DO i = 1, klon + zdqcv(i) = pqte(i,k)*(paph(i,k+1)-paph(i,k)) + zdhpbl(i) = 0.0 + zdqpbl(i) = 0.0 + ENDDO +c + DO k=2,klev + DO i = 1, klon + zdqcv(i)=zdqcv(i)+pqte(i,k)*(paph(i,k+1)-paph(i,k)) + IF (k.GE.kcbot(i)) THEN + zdqpbl(i)=zdqpbl(i)+pqte(i,k)*(paph(i,k+1)-paph(i,k)) + zdhpbl(i)=zdhpbl(i)+(RCPD*ptte(i,k)+RLVTT*pqte(i,k)) + . *(paph(i,k+1)-paph(i,k)) + ENDIF + ENDDO + ENDDO +c + DO i = 1, klon + ktype(i) = 2 + if (zdqcv(i).GT.MAX(0.,-1.5*pqhfl(i)*RG)) ktype(i) = 1 +ccc if (zdqcv(i).GT.MAX(0.,-1.1*pqhfl(i)*RG)) ktype(i) = 1 + ENDDO +c +c--------------------------------------------------------------------- +c determiner le flux de masse entrant a travers la base. +c on ignore, pour l'instant, l'effet du panache descendant +c--------------------------------------------------------------------- + DO i = 1, klon + ikb=kcbot(i) + zqumqe=pqu(i,ikb)+plu(i,ikb)-zqenh(i,ikb) + zdqmin=MAX(0.01*zqenh(i,ikb),1.E-10) + IF (zdqpbl(i).GT.0..AND.zqumqe.GT.zdqmin.AND.ldcum(i)) THEN + zmfub(i) = zdqpbl(i)/(RG*MAX(zqumqe,zdqmin)) + ELSE + zmfub(i) = 0.01 + ldcum(i)=.FALSE. + ENDIF + IF (ktype(i).EQ.2) THEN + zdh = RCPD*(ptu(i,ikb)-ztenh(i,ikb)) + RLVTT*zqumqe + zdh = RG * MAX(zdh,1.0E5*zdqmin) + IF (zdhpbl(i).GT.0..AND.ldcum(i))zmfub(i)=zdhpbl(i)/zdh + ENDIF + zmfmax = (paph(i,ikb)-paph(i,ikb-1)) / (RG*pdtime) + zmfub(i) = MIN(zmfub(i),zmfmax) + zentr(i) = ENTRSCV + IF (ktype(i).EQ.1) zentr(i) = ENTRPEN + ENDDO +C----------------------------------------------------------------------- +C DETERMINE CLOUD ASCENT FOR ENTRAINING PLUME +C----------------------------------------------------------------------- +c (A) calculer d'abord la hauteur "theorique" de la tour convective sans +c considerer l'entrainement ni le detrainement du panache, sachant +c ces derniers peuvent abaisser la hauteur theorique. +c + DO i = 1, klon + ikb=kcbot(i) + zhcbase(i)=RCPD*ptu(i,ikb)+zgeoh(i,ikb)+RLVTT*pqu(i,ikb) + ictop0(i)=kcbot(i)-1 + ENDDO +c + zalvdcp=RLVTT/RCPD + DO k=klev-1,3,-1 + DO i = 1, klon + zhsat=RCPD*ztenh(i,k)+zgeoh(i,k)+RLVTT*zqsenh(i,k) + zgam=R5LES*zalvdcp*zqsenh(i,k)/ + . ((1.-RETV *zqsenh(i,k))*(ztenh(i,k)-R4LES)**2) + zzz=RCPD*ztenh(i,k)*0.608 + zhhat=zhsat-(zzz+zgam*zzz)/(1.+zgam*zzz/RLVTT)* + . MAX(zqsenh(i,k)-zqenh(i,k),0.) + IF(k.LT.ictop0(i).AND.zhcbase(i).GT.zhhat) ictop0(i)=k + ENDDO + ENDDO +c +c (B) calculer le panache ascendant +c + CALL flxasc(pdtime,ztenh, zqenh, pten, pqen, pqsen, + . pgeo, zgeoh, pap, paph, pqte, pvervel, + . ldland, ldcum, ktype, ilab, + . ptu, pqu, plu, pmfu, zmfub, zentr, + . zmfus, zmfuq, zmful, plude, zdmfup, + . kcbot, kctop, ictop0, kcum, pen_u, pde_u) + IF (kcum.EQ.0) GO TO 1000 +C +C verifier l'epaisseur de la convection et changer eventuellement +c le taux d'entrainement/detrainement +C + DO i = 1, klon + zpbmpt=paph(i,kcbot(i))-paph(i,kctop(i)) + IF(ldcum(i).AND.ktype(i).EQ.1.AND.zpbmpt.LT.2.E4)ktype(i)=2 + IF(ldcum(i)) ictop0(i)=kctop(i) + IF(ktype(i).EQ.2) zentr(i)=ENTRSCV + ENDDO +c + IF (lmfdd) THEN ! si l'on considere le panache descendant +c +c calculer la precipitation issue du panache ascendant pour +c determiner l'existence du panache descendant dans la convection + DO i = 1, klon + zrfl(i)=zdmfup(i,1) + ENDDO + DO k=2,klev + DO i = 1, klon + zrfl(i)=zrfl(i)+zdmfup(i,k) + ENDDO + ENDDO +c +c determiner le LFS (level of free sinking: niveau de plonge libre) + CALL flxdlfs(ztenh, zqenh, zgeoh, paph, ptu, pqu, + * ldcum, kcbot, kctop, zmfub, zrfl, + * ptd, pqd, + * pmfd, zmfds, zmfdq, zdmfdp, + * kdtop, lddraf) +c +c calculer le panache descendant + CALL flxddraf(ztenh, zqenh, + * zgeoh, paph, zrfl, + * ptd, pqd, + * pmfd, zmfds, zmfdq, zdmfdp, + * lddraf, pen_d, pde_d) +c +c calculer de nouveau le flux de masse entrant a travers la base +c de la convection, sachant qu'il a ete modifie par le panache +c descendant + DO i = 1, klon + IF (lddraf(i)) THEN + ikb = kcbot(i) + llo1 = PMFD(i,ikb).LT.0. + zeps = 0. + IF ( llo1 ) zeps = CMFDEPS + zqumqe = pqu(i,ikb)+plu(i,ikb)- + . zeps*pqd(i,ikb)-(1.-zeps)*zqenh(i,ikb) + zdqmin = MAX(0.01*zqenh(i,ikb),1.E-10) + zmfmax = (paph(i,ikb)-paph(i,ikb-1)) / (RG*pdtime) + IF (zdqpbl(i).GT.0..AND.zqumqe.GT.zdqmin.AND.ldcum(i) + . .AND.zmfub(i).LT.zmfmax) THEN + zmfub1(i) = zdqpbl(i) / (RG*MAX(zqumqe,zdqmin)) + ELSE + zmfub1(i) = zmfub(i) + ENDIF + IF (ktype(i).EQ.2) THEN + zdh = RCPD*(ptu(i,ikb)-zeps*ptd(i,ikb)- + . (1.-zeps)*ztenh(i,ikb))+RLVTT*zqumqe + zdh = RG * MAX(zdh,1.0E5*zdqmin) + IF (zdhpbl(i).GT.0..AND.ldcum(i))zmfub1(i)=zdhpbl(i)/zdh + ENDIF + IF ( .NOT.((ktype(i).EQ.1.OR.ktype(i).EQ.2).AND. + . ABS(zmfub1(i)-zmfub(i)).LT.0.2*zmfub(i)) ) + . zmfub1(i) = zmfub(i) + ENDIF + ENDDO + DO k = 1, klev + DO i = 1, klon + IF (lddraf(i)) THEN + zfac = zmfub1(i)/MAX(zmfub(i),1.E-10) + pmfd(i,k) = pmfd(i,k)*zfac + zmfds(i,k) = zmfds(i,k)*zfac + zmfdq(i,k) = zmfdq(i,k)*zfac + zdmfdp(i,k) = zdmfdp(i,k)*zfac + pen_d(i,k) = pen_d(i,k)*zfac + pde_d(i,k) = pde_d(i,k)*zfac + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (lddraf(i)) zmfub(i)=zmfub1(i) + ENDDO +c + ENDIF ! fin de test sur lmfdd +c +c----------------------------------------------------------------------- +c calculer de nouveau le panache ascendant +c----------------------------------------------------------------------- + CALL flxasc(pdtime,ztenh, zqenh, pten, pqen, pqsen, + . pgeo, zgeoh, pap, paph, pqte, pvervel, + . ldland, ldcum, ktype, ilab, + . ptu, pqu, plu, pmfu, zmfub, zentr, + . zmfus, zmfuq, zmful, plude, zdmfup, + . kcbot, kctop, ictop0, kcum, pen_u, pde_u) +c +c----------------------------------------------------------------------- +c determiner les flux convectifs en forme finale, ainsi que +c la quantite des precipitations +c----------------------------------------------------------------------- + CALL flxflux(pdtime, pqen, pqsen, ztenh, zqenh, pap, paph, + . ldland, zgeoh, kcbot, kctop, lddraf, kdtop, ktype, ldcum, + . pmfu, pmfd, zmfus, zmfds, zmfuq, zmfdq, zmful, plude, + . zdmfup, zdmfdp, pten, prsfc, pssfc, zdpmel, itopm2, + . pmflxr, pmflxs) +c +c---------------------------------------------------------------------- +c calculer les tendances pour T et Q +c---------------------------------------------------------------------- + CALL flxdtdq(pdtime, itopm2, paph, ldcum, pten, + e zmfus, zmfds, zmfuq, zmfdq, zmful, zdmfup, zdmfdp, zdpmel, + s dt_con,dq_con) +c + 1000 CONTINUE + RETURN + END + SUBROUTINE flxini(pten, pqen, pqsen, pgeo, paph, pgeoh, ptenh, + . pqenh, pqsenh, ptu, pqu, ptd, pqd, pmfd, pmfds, pmfdq, + . pdmfdp, pmfu, pmfus, pmfuq, pdmfup, pdpmel, plu, plude, + . klab,pen_u, pde_u, pen_d, pde_d) + USE dimphy + IMPLICIT none +C---------------------------------------------------------------------- +C THIS ROUTINE INTERPOLATES LARGE-SCALE FIELDS OF T,Q ETC. +C TO HALF LEVELS (I.E. GRID FOR MASSFLUX SCHEME), +C AND INITIALIZES VALUES FOR UPDRAFTS +C---------------------------------------------------------------------- +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +C + REAL pten(klon,klev) ! temperature (environnement) + REAL pqen(klon,klev) ! humidite (environnement) + REAL pqsen(klon,klev) ! humidite saturante (environnement) + REAL pgeo(klon,klev) ! geopotentiel (g * metre) + REAL pgeoh(klon,klev) ! geopotentiel aux demi-niveaux + REAL paph(klon,klev+1) ! pression aux demi-niveaux + REAL ptenh(klon,klev) ! temperature aux demi-niveaux + REAL pqenh(klon,klev) ! humidite aux demi-niveaux + REAL pqsenh(klon,klev) ! humidite saturante aux demi-niveaux +C + REAL ptu(klon,klev) ! temperature du panache ascendant (p-a) + REAL pqu(klon,klev) ! humidite du p-a + REAL plu(klon,klev) ! eau liquide du p-a + REAL pmfu(klon,klev) ! flux de masse du p-a + REAL pmfus(klon,klev) ! flux de l'energie seche dans le p-a + REAL pmfuq(klon,klev) ! flux de l'humidite dans le p-a + REAL pdmfup(klon,klev) ! quantite de l'eau precipitee dans p-a + REAL plude(klon,klev) ! quantite de l'eau liquide jetee du +c p-a a l'environnement + REAL pdpmel(klon,klev) ! quantite de neige fondue +c + REAL ptd(klon,klev) ! temperature du panache descendant (p-d) + REAL pqd(klon,klev) ! humidite du p-d + REAL pmfd(klon,klev) ! flux de masse du p-d + REAL pmfds(klon,klev) ! flux de l'energie seche dans le p-d + REAL pmfdq(klon,klev) ! flux de l'humidite dans le p-d + REAL pdmfdp(klon,klev) ! quantite de precipitation dans p-d +c + REAL pen_u(klon,klev) ! quantite de masse entrainee pour p-a + REAL pde_u(klon,klev) ! quantite de masse detrainee pour p-a + REAL pen_d(klon,klev) ! quantite de masse entrainee pour p-d + REAL pde_d(klon,klev) ! quantite de masse detrainee pour p-d +C + INTEGER klab(klon,klev) + LOGICAL llflag(klon) + INTEGER k, i, icall + REAL zzs +C---------------------------------------------------------------------- +C SPECIFY LARGE SCALE PARAMETERS AT HALF LEVELS +C ADJUST TEMPERATURE FIELDS IF STATICLY UNSTABLE +C---------------------------------------------------------------------- + DO 130 k = 2, klev +c + DO i = 1, klon + pgeoh(i,k)=pgeo(i,k)+(pgeo(i,k-1)-pgeo(i,k))*0.5 + ptenh(i,k)=(MAX(RCPD*pten(i,k-1)+pgeo(i,k-1), + . RCPD*pten(i,k)+pgeo(i,k))-pgeoh(i,k))/RCPD + pqsenh(i,k)=pqsen(i,k-1) + llflag(i)=.TRUE. + ENDDO +c + icall=0 + CALL flxadjtq(paph(1,k),ptenh(1,k),pqsenh(1,k),llflag,icall) +c + DO i = 1, klon + pqenh(i,k)=MIN(pqen(i,k-1),pqsen(i,k-1)) + . +(pqsenh(i,k)-pqsen(i,k-1)) + pqenh(i,k)=MAX(pqenh(i,k),0.) + ENDDO +c + 130 CONTINUE +C + DO 140 i = 1, klon + ptenh(i,klev)=(RCPD*pten(i,klev)+pgeo(i,klev)- + 1 pgeoh(i,klev))/RCPD + pqenh(i,klev)=pqen(i,klev) + ptenh(i,1)=pten(i,1) + pqenh(i,1)=pqen(i,1) + pgeoh(i,1)=pgeo(i,1) + 140 CONTINUE +c + DO 160 k = klev-1, 2, -1 + DO 150 i = 1, klon + zzs = MAX(RCPD*ptenh(i,k)+pgeoh(i,k), + . RCPD*ptenh(i,k+1)+pgeoh(i,k+1)) + ptenh(i,k) = (zzs-pgeoh(i,k))/RCPD + 150 CONTINUE + 160 CONTINUE +C +C----------------------------------------------------------------------- +C INITIALIZE VALUES FOR UPDRAFTS AND DOWNDRAFTS +C----------------------------------------------------------------------- + DO k = 1, klev + DO i = 1, klon + ptu(i,k) = ptenh(i,k) + pqu(i,k) = pqenh(i,k) + plu(i,k) = 0. + pmfu(i,k) = 0. + pmfus(i,k) = 0. + pmfuq(i,k) = 0. + pdmfup(i,k) = 0. + pdpmel(i,k) = 0. + plude(i,k) = 0. +c + klab(i,k) = 0 +c + ptd(i,k) = ptenh(i,k) + pqd(i,k) = pqenh(i,k) + pmfd(i,k) = 0.0 + pmfds(i,k) = 0.0 + pmfdq(i,k) = 0.0 + pdmfdp(i,k) = 0.0 +c + pen_u(i,k) = 0.0 + pde_u(i,k) = 0.0 + pen_d(i,k) = 0.0 + pde_d(i,k) = 0.0 + ENDDO + ENDDO +C + RETURN + END + SUBROUTINE flxbase(ptenh, pqenh, pgeoh, paph, + * ptu, pqu, plu, ldcum, kcbot, klab) + USE dimphy + IMPLICIT none +C---------------------------------------------------------------------- +C THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q) +C +C INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS. +C IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS; +C klab=1 FOR SUBCLOUD LEVELS +C klab=2 FOR CONDENSATION LEVEL +C +C LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE +C (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX) +C---------------------------------------------------------------------- +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +C ---------------------------------------------------------------- + REAL ptenh(klon,klev), pqenh(klon,klev) + REAL pgeoh(klon,klev), paph(klon,klev+1) +C + REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev) + INTEGER klab(klon,klev), kcbot(klon) +C + LOGICAL llflag(klon), ldcum(klon) + INTEGER i, k, icall, is + REAL zbuo, zqold(klon) +C---------------------------------------------------------------------- +C INITIALIZE VALUES AT LIFTING LEVEL +C---------------------------------------------------------------------- + DO i = 1, klon + klab(i,klev)=1 + kcbot(i)=klev-1 + ldcum(i)=.FALSE. + ENDDO +C---------------------------------------------------------------------- +C DO ASCENT IN SUBCLOUD LAYER, +C CHECK FOR EXISTENCE OF CONDENSATION LEVEL, +C ADJUST T,Q AND L ACCORDINGLY +C CHECK FOR BUOYANCY AND SET FLAGS +C---------------------------------------------------------------------- + DO 290 k = klev-1, 2, -1 +c + is = 0 + DO i = 1, klon + IF (klab(i,k+1).EQ.1) is = is + 1 + llflag(i) = .FALSE. + IF (klab(i,k+1).EQ.1) llflag(i) = .TRUE. + ENDDO + IF (is.EQ.0) GOTO 290 +c + DO i = 1, klon + IF(llflag(i)) THEN + pqu(i,k) = pqu(i,k+1) + ptu(i,k) = ptu(i,k+1)+(pgeoh(i,k+1)-pgeoh(i,k))/RCPD + zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))- + . ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5 + IF (zbuo.GT.0.) klab(i,k) = 1 + zqold(i) = pqu(i,k) + ENDIF + ENDDO +c + icall=1 + CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall) +c + DO i = 1, klon + IF (llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN + klab(i,k) = 2 + plu(i,k) = plu(i,k) + zqold(i)-pqu(i,k) + zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))- + . ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5 + IF (zbuo.GT.0.) kcbot(i) = k + IF (zbuo.GT.0.) ldcum(i) = .TRUE. + ENDIF + ENDDO +c + 290 CONTINUE +c + RETURN + END + SUBROUTINE flxasc(pdtime, ptenh, pqenh, pten, pqen, pqsen, + . pgeo, pgeoh, pap, paph, pqte, pvervel, + . ldland, ldcum, ktype, klab, ptu, pqu, plu, + . pmfu, pmfub, pentr, pmfus, pmfuq, + . pmful, plude, pdmfup, kcbot, kctop, kctop0, kcum, + . pen_u, pde_u) + USE dimphy + IMPLICIT none +C---------------------------------------------------------------------- +C THIS ROUTINE DOES THE CALCULATIONS FOR CLOUD ASCENTS +C FOR CUMULUS PARAMETERIZATION +C---------------------------------------------------------------------- +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "YOECUMF.h" +C + REAL pdtime + REAL pten(klon,klev), ptenh(klon,klev) + REAL pqen(klon,klev), pqenh(klon,klev), pqsen(klon,klev) + REAL pgeo(klon,klev), pgeoh(klon,klev) + REAL pap(klon,klev), paph(klon,klev+1) + REAL pqte(klon,klev) + REAL pvervel(klon,klev) ! vitesse verticale en Pa/s +C + REAL pmfub(klon), pentr(klon) + REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev) + REAL plude(klon,klev) + REAL pmfu(klon,klev), pmfus(klon,klev) + REAL pmfuq(klon,klev), pmful(klon,klev) + REAL pdmfup(klon,klev) + INTEGER ktype(klon), klab(klon,klev), kcbot(klon), kctop(klon) + INTEGER kctop0(klon) + LOGICAL ldland(klon), ldcum(klon) +C + REAL pen_u(klon,klev), pde_u(klon,klev) + REAL zqold(klon) + REAL zdland(klon) + LOGICAL llflag(klon) + INTEGER k, i, is, icall, kcum + REAL ztglace, zdphi, zqeen, zseen, zscde, zqude + REAL zmfusk, zmfuqk, zmfulk, zbuo, zdnoprc, zprcon, zlnew +c + REAL zpbot(klon), zptop(klon), zrho(klon) + REAL zdprho, zentr, zpmid, zmftest, zmfmax + LOGICAL llo1, llo2 +c + REAL zwmax(klon), zzzmb + INTEGER klwmin(klon) ! level of maximum vertical velocity +C---------------------------------------------------------------------- + ztglace = RTT - 13. +c +c Chercher le niveau ou la vitesse verticale est maximale: + DO i = 1, klon + klwmin(i) = klev + zwmax(i) = 0.0 + ENDDO + DO k = klev, 3, -1 + DO i = 1, klon + IF (pvervel(i,k).LT.zwmax(i)) THEN + zwmax(i) = pvervel(i,k) + klwmin(i) = k + ENDIF + ENDDO + ENDDO +C---------------------------------------------------------------------- +C SET DEFAULT VALUES +C---------------------------------------------------------------------- + DO i = 1, klon + IF (.NOT.ldcum(i)) ktype(i)=0 + ENDDO +c + DO k=1,klev + DO i = 1, klon + plu(i,k)=0. + pmfu(i,k)=0. + pmfus(i,k)=0. + pmfuq(i,k)=0. + pmful(i,k)=0. + plude(i,k)=0. + pdmfup(i,k)=0. + IF(.NOT.ldcum(i).OR.ktype(i).EQ.3) klab(i,k)=0 + IF(.NOT.ldcum(i).AND.paph(i,k).LT.4.E4) kctop0(i)=k + ENDDO + ENDDO +c + DO i = 1, klon + IF (ldland(i)) THEN + zdland(i)=3.0E4 + zdphi=pgeoh(i,kctop0(i))-pgeoh(i,kcbot(i)) + IF (ptu(i,kctop0(i)).GE.ztglace) zdland(i)=zdphi + zdland(i)=MAX(3.0E4,zdland(i)) + zdland(i)=MIN(5.0E4,zdland(i)) + ENDIF + ENDDO +C +C Initialiser les valeurs au niveau d'ascendance +C + DO i = 1, klon + kctop(i) = klev-1 + IF (.NOT.ldcum(i)) THEN + kcbot(i) = klev-1 + pmfub(i) = 0. + pqu(i,klev) = 0. + ENDIF + pmfu(i,klev) = pmfub(i) + pmfus(i,klev) = pmfub(i)*(RCPD*ptu(i,klev)+pgeoh(i,klev)) + pmfuq(i,klev) = pmfub(i)*pqu(i,klev) + ENDDO +c + DO i = 1, klon + ldcum(i) = .FALSE. + ENDDO +C---------------------------------------------------------------------- +C DO ASCENT: SUBCLOUD LAYER (klab=1) ,CLOUDS (klab=2) +C BY DOING FIRST DRY-ADIABATIC ASCENT AND THEN +C BY ADJUSTING T,Q AND L ACCORDINGLY IN *flxadjtq*, +C THEN CHECK FOR BUOYANCY AND SET FLAGS ACCORDINGLY +C---------------------------------------------------------------------- + DO 480 k = klev-1,3,-1 +c + IF (LMFMID .AND. k.LT.klev-1 .AND. k.GT.klev/2) THEN + DO i = 1, klon + IF (.NOT.ldcum(i) .AND. klab(i,k+1).EQ.0 .AND. + . pqen(i,k).GT.0.9*pqsen(i,k)) THEN + ptu(i,k+1) = pten(i,k) +(pgeo(i,k)-pgeoh(i,k+1))/RCPD + pqu(i,k+1) = pqen(i,k) + plu(i,k+1) = 0.0 + zzzmb = MAX(CMFCMIN, -pvervel(i,k)/RG) + zmfmax = (paph(i,k)-paph(i,k-1))/(RG*pdtime) + pmfub(i) = MIN(zzzmb,zmfmax) + pmfu(i,k+1) = pmfub(i) + pmfus(i,k+1) = pmfub(i)*(RCPD*ptu(i,k+1)+pgeoh(i,k+1)) + pmfuq(i,k+1) = pmfub(i)*pqu(i,k+1) + pmful(i,k+1) = 0.0 + pdmfup(i,k+1) = 0.0 + kcbot(i) = k + klab(i,k+1) = 1 + ktype(i) = 3 + pentr(i) = ENTRMID + ENDIF + ENDDO + ENDIF +c + is = 0 + DO i = 1, klon + is = is + klab(i,k+1) + IF (klab(i,k+1) .EQ. 0) klab(i,k) = 0 + llflag(i) = .FALSE. + IF (klab(i,k+1) .GT. 0) llflag(i) = .TRUE. + ENDDO + IF (is .EQ. 0) GOTO 480 +c +c calculer le taux d'entrainement et de detrainement +c + DO i = 1, klon + pen_u(i,k) = 0.0 + pde_u(i,k) = 0.0 + zrho(i)=paph(i,k+1)/(RD*ptenh(i,k+1)) + zpbot(i)=paph(i,kcbot(i)) + zptop(i)=paph(i,kctop0(i)) + ENDDO +c + DO 125 i = 1, klon + IF(ldcum(i)) THEN + zdprho=(paph(i,k+1)-paph(i,k))/(RG*zrho(i)) + zentr=pentr(i)*pmfu(i,k+1)*zdprho + llo1=k.LT.kcbot(i) + IF(llo1) pde_u(i,k)=zentr + zpmid=0.5*(zpbot(i)+zptop(i)) + llo2=llo1.AND.ktype(i).EQ.2.AND. + . (zpbot(i)-paph(i,k).LT.0.2E5.OR. + . paph(i,k).GT.zpmid) + IF(llo2) pen_u(i,k)=zentr + llo2=llo1.AND.(ktype(i).EQ.1.OR.ktype(i).EQ.3).AND. + . (k.GE.MAX(klwmin(i),kctop0(i)+2).OR.pap(i,k).GT.zpmid) + IF(llo2) pen_u(i,k)=zentr + llo1=pen_u(i,k).GT.0..AND.(ktype(i).EQ.1.OR.ktype(i).EQ.2) + IF(llo1) THEN + zentr=zentr*(1.+3.*(1.-MIN(1.,(zpbot(i)-pap(i,k))/1.5E4))) + pen_u(i,k)=pen_u(i,k)*(1.+3.*(1.-MIN(1., + . (zpbot(i)-pap(i,k))/1.5E4))) + pde_u(i,k)=pde_u(i,k)*(1.+3.*(1.-MIN(1., + . (zpbot(i)-pap(i,k))/1.5E4))) + ENDIF + IF(llo2.AND.pqenh(i,k+1).GT.1.E-5) + . pen_u(i,k)=zentr+MAX(pqte(i,k),0.)/pqenh(i,k+1)* + . zrho(i)*zdprho + ENDIF + 125 CONTINUE +c +C---------------------------------------------------------------------- +c DO ADIABATIC ASCENT FOR ENTRAINING/DETRAINING PLUME +C---------------------------------------------------------------------- +c + DO 420 i = 1, klon + IF (llflag(i)) THEN + IF (k.LT.kcbot(i)) THEN + zmftest = pmfu(i,k+1)+pen_u(i,k)-pde_u(i,k) + zmfmax = MIN(zmftest,(paph(i,k)-paph(i,k-1))/(RG*pdtime)) + pen_u(i,k)=MAX(pen_u(i,k)-MAX(0.0,zmftest-zmfmax),0.0) + ENDIF + pde_u(i,k)=MIN(pde_u(i,k),0.75*pmfu(i,k+1)) +c calculer le flux de masse du niveau k a partir de celui du k+1 + pmfu(i,k)=pmfu(i,k+1)+pen_u(i,k)-pde_u(i,k) +c calculer les valeurs Su, Qu et l du niveau k dans le panache montant + zqeen=pqenh(i,k+1)*pen_u(i,k) + zseen=(RCPD*ptenh(i,k+1)+pgeoh(i,k+1))*pen_u(i,k) + zscde=(RCPD*ptu(i,k+1)+pgeoh(i,k+1))*pde_u(i,k) + zqude=pqu(i,k+1)*pde_u(i,k) + plude(i,k)=plu(i,k+1)*pde_u(i,k) + zmfusk=pmfus(i,k+1)+zseen-zscde + zmfuqk=pmfuq(i,k+1)+zqeen-zqude + zmfulk=pmful(i,k+1) -plude(i,k) + plu(i,k)=zmfulk*(1./MAX(CMFCMIN,pmfu(i,k))) + pqu(i,k)=zmfuqk*(1./MAX(CMFCMIN,pmfu(i,k))) + ptu(i,k)=(zmfusk*(1./MAX(CMFCMIN,pmfu(i,k)))- + 1 pgeoh(i,k))/RCPD + ptu(i,k)=MAX(100.,ptu(i,k)) + ptu(i,k)=MIN(400.,ptu(i,k)) + zqold(i)=pqu(i,k) + ELSE + zqold(i)=0.0 + ENDIF + 420 CONTINUE +c +C---------------------------------------------------------------------- +c DO CORRECTIONS FOR MOIST ASCENT BY ADJUSTING T,Q AND L +C---------------------------------------------------------------------- +c + icall = 1 + CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall) +C + DO 440 i = 1, klon + IF(llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN + klab(i,k) = 2 + plu(i,k) = plu(i,k)+zqold(i)-pqu(i,k) + zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))- + . ptenh(i,k)*(1.+RETV*pqenh(i,k)) + IF (klab(i,k+1).EQ.1) zbuo=zbuo+0.5 + IF (zbuo.GT.0..AND.pmfu(i,k).GE.0.1*pmfub(i)) THEN + kctop(i) = k + ldcum(i) = .TRUE. + zdnoprc = 1.5E4 + IF (ldland(i)) zdnoprc = zdland(i) + zprcon = CPRCON + IF ((zpbot(i)-paph(i,k)).LT.zdnoprc) zprcon = 0.0 + zlnew=plu(i,k)/(1.+zprcon*(pgeoh(i,k)-pgeoh(i,k+1))) + pdmfup(i,k)=MAX(0.,(plu(i,k)-zlnew)*pmfu(i,k)) + plu(i,k)=zlnew + ELSE + klab(i,k)=0 + pmfu(i,k)=0. + ENDIF + ENDIF + 440 CONTINUE + DO 455 i = 1, klon + IF (llflag(i)) THEN + pmful(i,k)=plu(i,k)*pmfu(i,k) + pmfus(i,k)=(RCPD*ptu(i,k)+pgeoh(i,k))*pmfu(i,k) + pmfuq(i,k)=pqu(i,k)*pmfu(i,k) + ENDIF + 455 CONTINUE +C + 480 CONTINUE +C---------------------------------------------------------------------- +C DETERMINE CONVECTIVE FLUXES ABOVE NON-BUOYANCY LEVEL +C (NOTE: CLOUD VARIABLES LIKE T,Q AND L ARE NOT +C AFFECTED BY DETRAINMENT AND ARE ALREADY KNOWN +C FROM PREVIOUS CALCULATIONS ABOVE) +C---------------------------------------------------------------------- + DO i = 1, klon + IF (kctop(i).EQ.klev-1) ldcum(i) = .FALSE. + kcbot(i) = MAX(kcbot(i),kctop(i)) + ENDDO +c + ldcum(1)=ldcum(1) +c + is = 0 + DO i = 1, klon + if (ldcum(i)) is = is + 1 + ENDDO + kcum = is + IF (is.EQ.0) GOTO 800 +c + DO 530 i = 1, klon + IF (ldcum(i)) THEN + k=kctop(i)-1 + pde_u(i,k)=(1.-CMFCTOP)*pmfu(i,k+1) + plude(i,k)=pde_u(i,k)*plu(i,k+1) + pmfu(i,k)=pmfu(i,k+1)-pde_u(i,k) + zlnew=plu(i,k) + pdmfup(i,k)=MAX(0.,(plu(i,k)-zlnew)*pmfu(i,k)) + plu(i,k)=zlnew + pmfus(i,k)=(RCPD*ptu(i,k)+pgeoh(i,k))*pmfu(i,k) + pmfuq(i,k)=pqu(i,k)*pmfu(i,k) + pmful(i,k)=plu(i,k)*pmfu(i,k) + plude(i,k-1)=pmful(i,k) + ENDIF + 530 CONTINUE +C + 800 CONTINUE + RETURN + END + SUBROUTINE flxflux(pdtime, pqen, pqsen, ptenh, pqenh, pap + . , paph, ldland, pgeoh, kcbot, kctop, lddraf, kdtop + . , ktype, ldcum, pmfu, pmfd, pmfus, pmfds + . , pmfuq, pmfdq, pmful, plude, pdmfup, pdmfdp + . , pten, prfl, psfl, pdpmel, ktopm2 + . , pmflxr, pmflxs) + USE dimphy + IMPLICIT none +C---------------------------------------------------------------------- +C THIS ROUTINE DOES THE FINAL CALCULATION OF CONVECTIVE +C FLUXES IN THE CLOUD LAYER AND IN THE SUBCLOUD LAYER +C---------------------------------------------------------------------- +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "YOECUMF.h" +C + REAL cevapcu(klon,klev) +C ----------------------------------------------------------------- + REAL pqen(klon,klev), pqenh(klon,klev), pqsen(klon,klev) + REAL pten(klon,klev), ptenh(klon,klev) + REAL paph(klon,klev+1), pgeoh(klon,klev) +c + REAL pap(klon,klev) + REAL ztmsmlt, zdelta, zqsat +C + REAL pmfu(klon,klev), pmfus(klon,klev) + REAL pmfd(klon,klev), pmfds(klon,klev) + REAL pmfuq(klon,klev), pmful(klon,klev) + REAL pmfdq(klon,klev) + REAL plude(klon,klev) + REAL pdmfup(klon,klev), pdpmel(klon,klev) +cjq The variable maxpdmfdp(klon) has been introduced by Olivier Boucher +cjq 14/11/00 to fix the problem with the negative precipitation. + REAL pdmfdp(klon,klev), maxpdmfdp(klon,klev) + REAL prfl(klon), psfl(klon) + REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1) + INTEGER kcbot(klon), kctop(klon), ktype(klon) + LOGICAL ldland(klon), ldcum(klon) + INTEGER k, kp, i + REAL zcons1, zcons2, zcucov, ztmelp2 + REAL pdtime, zdp, zzp, zfac, zsnmlt, zrfl, zrnew + REAL zrmin, zrfln, zdrfl + REAL zpds, zpdr, zdenom + INTEGER ktopm2, itop, ikb +c + LOGICAL lddraf(klon) + INTEGER kdtop(klon) +c +#include "FCTTRE.h" +c + DO 101 k=1,klev + DO i=1,klon + CEVAPCU(i,k)=1.93E-6*261.*SQRT(1.E3/(38.3*0.293) + 1 *SQRT(0.5*(paph(i,k)+paph(i,k+1))/paph(i,klev+1)) ) * 0.5/RG + ENDDO + 101 CONTINUE +c +c SPECIFY CONSTANTS +c + zcons1 = RCPD/(RLMLT*RG*pdtime) + zcons2 = 1./(RG*pdtime) + zcucov = 0.05 + ztmelp2 = RTT + 2. +c +c DETERMINE FINAL CONVECTIVE FLUXES +c + itop=klev + DO 110 i = 1, klon + itop=MIN(itop,kctop(i)) + IF (.NOT.ldcum(i) .OR. kdtop(i).LT.kctop(i)) lddraf(i)=.FALSE. + IF(.NOT.ldcum(i)) ktype(i)=0 + 110 CONTINUE +c + ktopm2=itop-2 + DO 120 k=ktopm2,klev + DO 115 i = 1, klon + IF(ldcum(i).AND.k.GE.kctop(i)-1) THEN + pmfus(i,k)=pmfus(i,k)-pmfu(i,k)* + . (RCPD*ptenh(i,k)+pgeoh(i,k)) + pmfuq(i,k)=pmfuq(i,k)-pmfu(i,k)*pqenh(i,k) + zdp = 1.5E4 + IF ( ldland(i) ) zdp = 3.E4 +c +c l'eau liquide detrainee est precipitee quand certaines +c conditions sont reunies (sinon, elle est consideree +c evaporee dans l'environnement) +c + IF(paph(i,kcbot(i))-paph(i,kctop(i)).GE.zdp.AND. + . pqen(i,k-1).GT.0.8*pqsen(i,k-1)) + . pdmfup(i,k-1)=pdmfup(i,k-1)+plude(i,k-1) +c + IF(lddraf(i).AND.k.GE.kdtop(i)) THEN + pmfds(i,k)=pmfds(i,k)-pmfd(i,k)* + . (RCPD*ptenh(i,k)+pgeoh(i,k)) + pmfdq(i,k)=pmfdq(i,k)-pmfd(i,k)*pqenh(i,k) + ELSE + pmfd(i,k)=0. + pmfds(i,k)=0. + pmfdq(i,k)=0. + pdmfdp(i,k-1)=0. + END IF + ELSE + pmfu(i,k)=0. + pmfus(i,k)=0. + pmfuq(i,k)=0. + pmful(i,k)=0. + pdmfup(i,k-1)=0. + plude(i,k-1)=0. + pmfd(i,k)=0. + pmfds(i,k)=0. + pmfdq(i,k)=0. + pdmfdp(i,k-1)=0. + ENDIF + 115 CONTINUE + 120 CONTINUE +c + DO 130 k=ktopm2,klev + DO 125 i = 1, klon + IF(ldcum(i).AND.k.GT.kcbot(i)) THEN + ikb=kcbot(i) + zzp=((paph(i,klev+1)-paph(i,k))/ + . (paph(i,klev+1)-paph(i,ikb))) + IF (ktype(i).EQ.3) zzp = zzp**2 + pmfu(i,k)=pmfu(i,ikb)*zzp + pmfus(i,k)=pmfus(i,ikb)*zzp + pmfuq(i,k)=pmfuq(i,ikb)*zzp + pmful(i,k)=pmful(i,ikb)*zzp + ENDIF + 125 CONTINUE + 130 CONTINUE +c +c CALCULATE RAIN/SNOW FALL RATES +c CALCULATE MELTING OF SNOW +c CALCULATE EVAPORATION OF PRECIP +c + DO k = 1, klev+1 + DO i = 1, klon + pmflxr(i,k) = 0.0 + pmflxs(i,k) = 0.0 + ENDDO + ENDDO + DO k = ktopm2, klev + DO i = 1, klon + IF (ldcum(i)) THEN + IF (pmflxs(i,k).GT.0.0 .AND. pten(i,k).GT.ztmelp2) THEN + zfac=zcons1*(paph(i,k+1)-paph(i,k)) + zsnmlt=MIN(pmflxs(i,k),zfac*(pten(i,k)-ztmelp2)) + pdpmel(i,k)=zsnmlt + ztmsmlt=pten(i,k)-zsnmlt/zfac + zdelta=MAX(0.,SIGN(1.,RTT-ztmsmlt)) + zqsat=R2ES*FOEEW(ztmsmlt, zdelta) / pap(i,k) + zqsat=MIN(0.5,zqsat) + zqsat=zqsat/(1.-RETV *zqsat) + pqsen(i,k) = zqsat + ENDIF + IF (pten(i,k).GT.RTT) THEN + pmflxr(i,k+1)=pmflxr(i,k)+pdmfup(i,k)+pdmfdp(i,k)+pdpmel(i,k) + pmflxs(i,k+1)=pmflxs(i,k)-pdpmel(i,k) + ELSE + pmflxs(i,k+1)=pmflxs(i,k)+pdmfup(i,k)+pdmfdp(i,k) + pmflxr(i,k+1)=pmflxr(i,k) + ENDIF +c si la precipitation est negative, on ajuste le plux du +c panache descendant pour eliminer la negativite + IF ((pmflxr(i,k+1)+pmflxs(i,k+1)).LT.0.0) THEN + pdmfdp(i,k) = -pmflxr(i,k)-pmflxs(i,k)-pdmfup(i,k) + pmflxr(i,k+1) = 0.0 + pmflxs(i,k+1) = 0.0 + pdpmel(i,k) = 0.0 + ENDIF + ENDIF + ENDDO + ENDDO +c +cjq The new variable is initialized here. +cjq It contains the humidity which is fed to the downdraft +cjq by evaporation of precipitation in the column below the base +cjq of convection. +cjq +cjq In the former version, this term has been subtracted from precip +cjq as well as the evaporation. +cjq + DO k = 1, klev + DO i = 1, klon + maxpdmfdp(i,k)=0.0 + ENDDO + ENDDO + DO k = 1, klev + DO kp = k, klev + DO i = 1, klon + maxpdmfdp(i,k)=maxpdmfdp(i,k)+pdmfdp(i,kp) + ENDDO + ENDDO + ENDDO +cjq End of initialization +c + DO k = ktopm2, klev + DO i = 1, klon + IF (ldcum(i) .AND. k.GE.kcbot(i)) THEN + zrfl = pmflxr(i,k) + pmflxs(i,k) + IF (zrfl.GT.1.0E-20) THEN + zrnew=(MAX(0.,SQRT(zrfl/zcucov)- + . CEVAPCU(i,k)*(paph(i,k+1)-paph(i,k))* + . MAX(0.,pqsen(i,k)-pqen(i,k))))**2*zcucov + zrmin=zrfl-zcucov*MAX(0.,0.8*pqsen(i,k)-pqen(i,k)) + . *zcons2*(paph(i,k+1)-paph(i,k)) + zrnew=MAX(zrnew,zrmin) + zrfln=MAX(zrnew,0.) + zdrfl=MIN(0.,zrfln-zrfl) +cjq At least the amount of precipiation needed to feed the downdraft +cjq with humidity below the base of convection has to be left and can't +cjq be evaporated (surely the evaporation can't be positive): + zdrfl=MAX(zdrfl, + . MIN(-pmflxr(i,k)-pmflxs(i,k)-maxpdmfdp(i,k),0.0)) +cjq End of insertion +c + zdenom=1.0/MAX(1.0E-20,pmflxr(i,k)+pmflxs(i,k)) + IF (pten(i,k).GT.RTT) THEN + zpdr = pdmfdp(i,k) + zpds = 0.0 + ELSE + zpdr = 0.0 + zpds = pdmfdp(i,k) + ENDIF + pmflxr(i,k+1) = pmflxr(i,k) + zpdr + pdpmel(i,k) + . + zdrfl*pmflxr(i,k)*zdenom + pmflxs(i,k+1) = pmflxs(i,k) + zpds - pdpmel(i,k) + . + zdrfl*pmflxs(i,k)*zdenom + pdmfup(i,k) = pdmfup(i,k) + zdrfl + ELSE + pmflxr(i,k+1) = 0.0 + pmflxs(i,k+1) = 0.0 + pdmfdp(i,k) = 0.0 + pdpmel(i,k) = 0.0 + ENDIF + if (pmflxr(i,k) + pmflxs(i,k).lt.-1.e-26) + . write(*,*) 'precip. < 1e-16 ',pmflxr(i,k) + pmflxs(i,k) + ENDIF + ENDDO + ENDDO +c + DO 210 i = 1, klon + prfl(i) = pmflxr(i,klev+1) + psfl(i) = pmflxs(i,klev+1) + 210 CONTINUE +c + RETURN + END + SUBROUTINE flxdtdq(pdtime, ktopm2, paph, ldcum, pten + . , pmfus, pmfds, pmfuq, pmfdq, pmful, pdmfup, pdmfdp + . , pdpmel, dt_con, dq_con) + USE dimphy + IMPLICIT none +c---------------------------------------------------------------------- +c calculer les tendances T et Q +c---------------------------------------------------------------------- +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "YOECUMF.h" +C ----------------------------------------------------------------- + LOGICAL llo1 +C + REAL pten(klon,klev), paph(klon,klev+1) + REAL pmfus(klon,klev), pmfuq(klon,klev), pmful(klon,klev) + REAL pmfds(klon,klev), pmfdq(klon,klev) + REAL pdmfup(klon,klev) + REAL pdmfdp(klon,klev) + REAL pdpmel(klon,klev) + LOGICAL ldcum(klon) + REAL dt_con(klon,klev), dq_con(klon,klev) +c + INTEGER ktopm2 + REAL pdtime +c + INTEGER i, k + REAL zalv, zdtdt, zdqdt +c + DO 210 k=ktopm2,klev-1 + DO 220 i = 1, klon + IF (ldcum(i)) THEN + llo1 = (pten(i,k)-RTT).GT.0. + zalv = RLSTT + IF (llo1) zalv = RLVTT + zdtdt=RG/(paph(i,k+1)-paph(i,k))/RCPD + . *(pmfus(i,k+1)-pmfus(i,k) + . +pmfds(i,k+1)-pmfds(i,k) + . -RLMLT*pdpmel(i,k) + . -zalv*(pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k)) + . ) + dt_con(i,k)=zdtdt + zdqdt=RG/(paph(i,k+1)-paph(i,k)) + . *(pmfuq(i,k+1)-pmfuq(i,k) + . +pmfdq(i,k+1)-pmfdq(i,k) + . +pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k)) + dq_con(i,k)=zdqdt + ENDIF + 220 CONTINUE + 210 CONTINUE +C + k = klev + DO 230 i = 1, klon + IF (ldcum(i)) THEN + llo1 = (pten(i,k)-RTT).GT.0. + zalv = RLSTT + IF (llo1) zalv = RLVTT + zdtdt=-RG/(paph(i,k+1)-paph(i,k))/RCPD + . *(pmfus(i,k)+pmfds(i,k)+RLMLT*pdpmel(i,k) + . -zalv*(pmful(i,k)+pdmfup(i,k)+pdmfdp(i,k))) + dt_con(i,k)=zdtdt + zdqdt=-RG/(paph(i,k+1)-paph(i,k)) + . *(pmfuq(i,k)+pmfdq(i,k)+pmful(i,k) + . +pdmfup(i,k)+pdmfdp(i,k)) + dq_con(i,k)=zdqdt + ENDIF + 230 CONTINUE +C + RETURN + END + SUBROUTINE flxdlfs(ptenh, pqenh, pgeoh, paph, ptu, pqu, + . ldcum, kcbot, kctop, pmfub, prfl, ptd, pqd, + . pmfd, pmfds, pmfdq, pdmfdp, kdtop, lddraf) + USE dimphy + IMPLICIT none +C +C---------------------------------------------------------------------- +C THIS ROUTINE CALCULATES LEVEL OF FREE SINKING FOR +C CUMULUS DOWNDRAFTS AND SPECIFIES T,Q,U AND V VALUES +C +C TO PRODUCE LFS-VALUES FOR CUMULUS DOWNDRAFTS +C FOR MASSFLUX CUMULUS PARAMETERIZATION +C +C INPUT ARE ENVIRONMENTAL VALUES OF T,Q,U,V,P,PHI +C AND UPDRAFT VALUES T,Q,U AND V AND ALSO +C CLOUD BASE MASSFLUX AND CU-PRECIPITATION RATE. +C IT RETURNS T,Q,U AND V VALUES AND MASSFLUX AT LFS. +C +C CHECK FOR NEGATIVE BUOYANCY OF AIR OF EQUAL PARTS OF +C MOIST ENVIRONMENTAL AIR AND CLOUD AIR. +C---------------------------------------------------------------------- +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "YOECUMF.h" +C + REAL ptenh(klon,klev) + REAL pqenh(klon,klev) + REAL pgeoh(klon,klev), paph(klon,klev+1) + REAL ptu(klon,klev), pqu(klon,klev) + REAL pmfub(klon) + REAL prfl(klon) +C + REAL ptd(klon,klev), pqd(klon,klev) + REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev) + REAL pdmfdp(klon,klev) + INTEGER kcbot(klon), kctop(klon), kdtop(klon) + LOGICAL ldcum(klon), lddraf(klon) +C + REAL ztenwb(klon,klev), zqenwb(klon,klev), zcond(klon) + REAL zttest, zqtest, zbuo, zmftop + LOGICAL llo2(klon) + INTEGER i, k, is, icall +C---------------------------------------------------------------------- + DO i= 1, klon + lddraf(i)=.FALSE. + kdtop(i)=klev+1 + ENDDO +C +C---------------------------------------------------------------------- +C DETERMINE LEVEL OF FREE SINKING BY +C DOING A SCAN FROM TOP TO BASE OF CUMULUS CLOUDS +C +C FOR EVERY POINT AND PROCEED AS FOLLOWS: +C (1) DETEMINE WET BULB ENVIRONMENTAL T AND Q +C (2) DO MIXING WITH CUMULUS CLOUD AIR +C (3) CHECK FOR NEGATIVE BUOYANCY +C +C THE ASSUMPTION IS THAT AIR OF DOWNDRAFTS IS MIXTURE +C OF 50% CLOUD AIR + 50% ENVIRONMENTAL AIR AT WET BULB +C TEMPERATURE (I.E. WHICH BECAME SATURATED DUE TO +C EVAPORATION OF RAIN AND CLOUD WATER) +C---------------------------------------------------------------------- +C + DO 290 k = 3, klev-3 +C + is=0 + DO 212 i= 1, klon + ztenwb(i,k)=ptenh(i,k) + zqenwb(i,k)=pqenh(i,k) + llo2(i) = ldcum(i).AND.prfl(i).GT.0. + . .AND..NOT.lddraf(i) + . .AND.(k.LT.kcbot(i).AND.k.GT.kctop(i)) + IF ( llo2(i) ) is = is + 1 + 212 CONTINUE + IF(is.EQ.0) GO TO 290 +C + icall=2 + CALL flxadjtq(paph(1,k), ztenwb(1,k), zqenwb(1,k), llo2, icall) +C +C---------------------------------------------------------------------- +C DO MIXING OF CUMULUS AND ENVIRONMENTAL AIR +C AND CHECK FOR NEGATIVE BUOYANCY. +C THEN SET VALUES FOR DOWNDRAFT AT LFS. +C---------------------------------------------------------------------- + DO 222 i= 1, klon + IF (llo2(i)) THEN + zttest=0.5*(ptu(i,k)+ztenwb(i,k)) + zqtest=0.5*(pqu(i,k)+zqenwb(i,k)) + zbuo=zttest*(1.+RETV*zqtest)- + . ptenh(i,k)*(1.+RETV *pqenh(i,k)) + zcond(i)=pqenh(i,k)-zqenwb(i,k) + zmftop=-CMFDEPS*pmfub(i) + IF (zbuo.LT.0..AND.prfl(i).GT.10.*zmftop*zcond(i)) THEN + kdtop(i)=k + lddraf(i)=.TRUE. + ptd(i,k)=zttest + pqd(i,k)=zqtest + pmfd(i,k)=zmftop + pmfds(i,k)=pmfd(i,k)*(RCPD*ptd(i,k)+pgeoh(i,k)) + pmfdq(i,k)=pmfd(i,k)*pqd(i,k) + pdmfdp(i,k-1)=-0.5*pmfd(i,k)*zcond(i) + prfl(i)=prfl(i)+pdmfdp(i,k-1) + ENDIF + ENDIF + 222 CONTINUE +c + 290 CONTINUE +C + RETURN + END + SUBROUTINE flxddraf(ptenh, pqenh, pgeoh, paph, prfl, + . ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp, + . lddraf, pen_d, pde_d) + USE dimphy + IMPLICIT none +C +C---------------------------------------------------------------------- +C THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT +C +C TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS +C (I.E. T,Q,U AND V AND FLUXES) +C +C INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS. +C IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE +C AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS +C +C CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY +C A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND +C B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE. +C +C---------------------------------------------------------------------- +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "YOECUMF.h" +C + REAL ptenh(klon,klev), pqenh(klon,klev) + REAL pgeoh(klon,klev), paph(klon,klev+1) +C + REAL ptd(klon,klev), pqd(klon,klev) + REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev) + REAL pdmfdp(klon,klev) + REAL prfl(klon) + LOGICAL lddraf(klon) +C + REAL pen_d(klon,klev), pde_d(klon,klev), zcond(klon) + LOGICAL llo2(klon), llo1 + INTEGER i, k, is, icall, itopde + REAL zentr, zseen, zqeen, zsdde, zqdde, zmfdsk, zmfdqk, zdmfdp + REAL zbuo +C---------------------------------------------------------------------- +C CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY +C (A) CALCULATING ENTRAINMENT RATES, ASSUMING +C LINEAR DECREASE OF MASSFLUX IN PBL +C (B) DOING MOIST DESCENT - EVAPORATIVE COOLING +C AND MOISTENING IS CALCULATED IN *flxadjtq* +C (C) CHECKING FOR NEGATIVE BUOYANCY AND +C SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES +C + DO 180 k = 3, klev +c + is = 0 + DO i = 1, klon + llo2(i)=lddraf(i).AND.pmfd(i,k-1).LT.0. + IF (llo2(i)) is = is + 1 + ENDDO + IF (is.EQ.0) GOTO 180 +c + DO i = 1, klon + IF (llo2(i)) THEN + zentr = ENTRDD*pmfd(i,k-1)*RD*ptenh(i,k-1)/ + . (RG*paph(i,k-1))*(paph(i,k)-paph(i,k-1)) + pen_d(i,k) = zentr + pde_d(i,k) = zentr + ENDIF + ENDDO +c + itopde = klev-2 + IF (k.GT.itopde) THEN + DO i = 1, klon + IF (llo2(i)) THEN + pen_d(i,k)=0. + pde_d(i,k)=pmfd(i,itopde)* + . (paph(i,k)-paph(i,k-1))/(paph(i,klev+1)-paph(i,itopde)) + ENDIF + ENDDO + ENDIF +C + DO i = 1, klon + IF (llo2(i)) THEN + pmfd(i,k) = pmfd(i,k-1)+pen_d(i,k)-pde_d(i,k) + zseen = (RCPD*ptenh(i,k-1)+pgeoh(i,k-1))*pen_d(i,k) + zqeen = pqenh(i,k-1)*pen_d(i,k) + zsdde = (RCPD*ptd(i,k-1)+pgeoh(i,k-1))*pde_d(i,k) + zqdde = pqd(i,k-1)*pde_d(i,k) + zmfdsk = pmfds(i,k-1)+zseen-zsdde + zmfdqk = pmfdq(i,k-1)+zqeen-zqdde + pqd(i,k) = zmfdqk*(1./MIN(-CMFCMIN,pmfd(i,k))) + ptd(i,k) = (zmfdsk*(1./MIN(-CMFCMIN,pmfd(i,k)))- + . pgeoh(i,k))/RCPD + ptd(i,k) = MIN(400.,ptd(i,k)) + ptd(i,k) = MAX(100.,ptd(i,k)) + zcond(i) = pqd(i,k) + ENDIF + ENDDO +C + icall = 2 + CALL flxadjtq(paph(1,k), ptd(1,k), pqd(1,k), llo2, icall) +C + DO i = 1, klon + IF (llo2(i)) THEN + zcond(i) = zcond(i)-pqd(i,k) + zbuo = ptd(i,k)*(1.+RETV *pqd(i,k))- + . ptenh(i,k)*(1.+RETV *pqenh(i,k)) + llo1 = zbuo.LT.0..AND.(prfl(i)-pmfd(i,k)*zcond(i).GT.0.) + IF (.not.llo1) pmfd(i,k) = 0.0 + pmfds(i,k) = (RCPD*ptd(i,k)+pgeoh(i,k))*pmfd(i,k) + pmfdq(i,k) = pqd(i,k)*pmfd(i,k) + zdmfdp = -pmfd(i,k)*zcond(i) + pdmfdp(i,k-1) = zdmfdp + prfl(i) = prfl(i)+zdmfdp + ENDIF + ENDDO +c + 180 CONTINUE + RETURN + END + SUBROUTINE flxadjtq(pp, pt, pq, ldflag, kcall) + USE dimphy + IMPLICIT none +c====================================================================== +c Objet: ajustement entre T et Q +c====================================================================== +C NOTE: INPUT PARAMETER kcall DEFINES CALCULATION AS +C kcall=0 ENV. T AND QS IN*CUINI* +C kcall=1 CONDENSATION IN UPDRAFTS (E.G. CUBASE, CUASC) +C kcall=2 EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF) +C +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +C + REAL pt(klon), pq(klon), pp(klon) + LOGICAL ldflag(klon) + INTEGER kcall +c + REAL zcond(klon), zcond1 + REAL Z5alvcp, z5alscp, zalvdcp, zalsdcp + REAL zdelta, zcvm5, zldcp, zqsat, zcor + INTEGER is, i +#include "YOETHF.h" +#include "FCTTRE.h" +C + z5alvcp = r5les*RLVTT/RCPD + z5alscp = r5ies*RLSTT/RCPD + zalvdcp = rlvtt/RCPD + zalsdcp = rlstt/RCPD +C + + DO i = 1, klon + zcond(i) = 0.0 + ENDDO + + DO 210 i =1, klon + IF (ldflag(i)) THEN + zdelta = MAX(0.,SIGN(1.,RTT-pt(i))) + zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp + zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp + zqsat = R2ES*FOEEW(pt(i),zdelta) / pp(i) + zqsat = MIN(0.5,zqsat) + zcor = 1./(1.-RETV*zqsat) + zqsat = zqsat*zcor + zcond(i) = (pq(i)-zqsat) + . / (1. + FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor)) + IF (kcall.EQ.1) zcond(i) = MAX(zcond(i),0.) + IF (kcall.EQ.2) zcond(i) = MIN(zcond(i),0.) + pt(i) = pt(i) + zldcp*zcond(i) + pq(i) = pq(i) - zcond(i) + ENDIF + 210 CONTINUE +C + is = 0 + DO i =1, klon + IF (zcond(i).NE.0.) is = is + 1 + ENDDO + IF (is.EQ.0) GOTO 230 +C + DO 220 i = 1, klon + IF(ldflag(i).AND.zcond(i).NE.0.) THEN + zdelta = MAX(0.,SIGN(1.,RTT-pt(i))) + zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp + zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp + zqsat = R2ES* FOEEW(pt(i),zdelta) / pp(i) + zqsat = MIN(0.5,zqsat) + zcor = 1./(1.-RETV*zqsat) + zqsat = zqsat*zcor + zcond1 = (pq(i)-zqsat) + . / (1. + FOEDE(pt(i),zdelta,zcvm5,zqsat,zcor)) + pt(i) = pt(i) + zldcp*zcond1 + pq(i) = pq(i) - zcond1 + ENDIF + 220 CONTINUE +C + 230 CONTINUE + RETURN + END + SUBROUTINE flxsetup + IMPLICIT none +C +C THIS ROUTINE DEFINES DISPOSABLE PARAMETERS FOR MASSFLUX SCHEME +C +#include "YOECUMF.h" +C + ENTRPEN=1.0E-4 ! ENTRAINMENT RATE FOR PENETRATIVE CONVECTION + ENTRSCV=3.0E-4 ! ENTRAINMENT RATE FOR SHALLOW CONVECTION + ENTRMID=1.0E-4 ! ENTRAINMENT RATE FOR MIDLEVEL CONVECTION + ENTRDD =2.0E-4 ! ENTRAINMENT RATE FOR DOWNDRAFTS + CMFCTOP=0.33 ! RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUO LEVEL + CMFCMAX=1.0 ! MAXIMUM MASSFLUX VALUE ALLOWED FOR UPDRAFTS ETC + CMFCMIN=1.E-10 ! MINIMUM MASSFLUX VALUE (FOR SAFETY) + CMFDEPS=0.3 ! FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS + CPRCON =2.0E-4 ! CONVERSION FROM CLOUD WATER TO RAIN + RHCDD=1. ! RELATIVE SATURATION IN DOWNDRAFRS (NO LONGER USED) +c (FORMULATION IMPLIES SATURATION) + LMFPEN = .TRUE. + LMFSCV = .TRUE. + LMFMID = .TRUE. + LMFDD = .TRUE. + LMFDUDV = .TRUE. +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conlmd.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conlmd.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/conlmd.F (revision 1280) @@ -0,0 +1,2321 @@ +! +! $Header$ +! + SUBROUTINE conlmd (dtime, paprs, pplay, t, q, conv_q, + s d_t, d_q, rain, snow, ibas, itop) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: Schema de convection utilis'e dans le modele du LMD +c Ajustement humide (Manabe) + Ajustement convectif (Kuo) +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +c +c Arguments: +c + REAL dtime ! pas d'integration (s) + REAL paprs(klon,klev+1) ! pression inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (kg/kg) + REAL conv_q(klon,klev) ! taux de convergence humidite (g/g/s) +c + REAL d_t(klon,klev) ! incrementation temperature + REAL d_q(klon,klev) ! incrementation humidite + REAL rain(klon) ! pluies (mm/s) + REAL snow(klon) ! neige (mm/s) + INTEGER ibas(klon) ! niveau du bas + INTEGER itop(klon) ! niveau du haut +c + LOGICAL usekuo ! utiliser convection profonde (schema Kuo) + PARAMETER (usekuo=.TRUE.) +c + REAL d_t_bis(klon,klev) + REAL d_q_bis(klon,klev) + REAL rain_bis(klon) + REAL snow_bis(klon) + INTEGER ibas_bis(klon) + INTEGER itop_bis(klon) + REAL d_ql(klon,klev), d_ql_bis(klon,klev) + REAL rneb(klon,klev), rneb_bis(klon,klev) +c + INTEGER i, k + REAL zlvdcp, zlsdcp, zdelta, zz, za, zb +c +ccc CALL fiajh ! ancienne version de Convection Manabe + CALL conman ! nouvelle version de Convection Manabe + e (dtime, paprs, pplay, t, q, + s d_t, d_q, d_ql, rneb, + s rain, snow, ibas, itop) +c + IF (usekuo) THEN +ccc CALL fiajc ! ancienne version de Convection Kuo + CALL conkuo ! nouvelle version de Convection Kuo + e (dtime, paprs, pplay, t, q, conv_q, + s d_t_bis, d_q_bis, d_ql_bis, rneb_bis, + s rain_bis, snow_bis, ibas_bis, itop_bis) + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = d_t(i,k) + d_t_bis(i,k) + d_q(i,k) = d_q(i,k) + d_q_bis(i,k) + d_ql(i,k) = d_ql(i,k) + d_ql_bis(i,k) + ENDDO + ENDDO + DO i = 1, klon + rain(i) = rain(i) + rain_bis(i) + snow(i) = snow(i) + snow_bis(i) + ibas(i) = MIN(ibas(i),ibas_bis(i)) + itop(i) = MAX(itop(i),itop_bis(i)) + ENDDO + ENDIF +c +c L'eau liquide convective est dispersee dans l'air: +c + DO k = 1, klev + DO i = 1, klon + zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q(i,k)) + zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q(i,k)) + zdelta = MAX(0.,SIGN(1.,RTT-t(i,k))) + zz = d_ql(i,k) ! re-evap. de l'eau liquide + zb = MAX(0.0,zz) + za = - MAX(0.0,zz) * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta) + d_t(i,k) = d_t(i,k) + za + d_q(i,k) = d_q(i,k) + zb + ENDDO + ENDDO +c + RETURN + END + SUBROUTINE conman (dtime, paprs, pplay, t, q, + s d_t, d_q, d_ql, rneb, + s rain, snow, ibas, itop) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19970324 +c Objet: ajustement humide convectif avec la possibilite de faire +c l'ajustement sur une fraction de la maille. +c Methode: On impose une distribution uniforme pour la vapeur d'eau +c au sein d'une maille. On applique la procedure d'ajustement +c successivement a la totalite, 75%, 50%, 25% et 5% de la maille +c jusqu'a ce que l'ajustement a lieu. J'espere que ceci augmente +c les activites convectives et corrige le biais "trop froid et sec" +c du modele. +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c + REAL dtime ! pas d'integration (s) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (kg/kg) + REAL paprs(klon,klev+1) ! pression inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) +c + REAL d_t(klon,klev) ! incrementation temperature + REAL d_q(klon,klev) ! incrementation humidite + REAL d_ql(klon,klev) ! incrementation eau liquide + REAL rneb(klon,klev) ! nebulosite + REAL rain(klon) ! pluies (mm/s) + REAL snow(klon) ! neige (mm/s) + INTEGER ibas(klon) ! niveau du bas + INTEGER itop(klon) ! niveau du haut +c + LOGICAL afaire(klon) ! .TRUE. implique l'ajustement + LOGICAL accompli(klon) ! .TRUE. si l'ajustement est effectif +c + INTEGER nb ! nombre de sous-fractions a considere + PARAMETER (nb=1) +ccc PARAMETER (nb=3) +c + REAL ratqs ! largeur de la distribution pour vapeur d'eau + PARAMETER (ratqs=0.05) +c + REAL w_q(klon,klev) + REAL w_d_t(klon,klev), w_d_q(klon,klev), w_d_ql(klon,klev) + REAL w_rneb(klon,klev) + REAL w_rain(klon), w_snow(klon) + INTEGER w_ibas(klon), w_itop(klon) + REAL zq1, zq2 + INTEGER i, k, n +c + REAL t_coup + PARAMETER (t_coup=234.0) + REAL zdp1, zdp2 + REAL zqs1, zqs2, zdqs1, zdqs2 + REAL zgamdz + REAL zflo ! flotabilite + REAL zsat ! sur-saturation + REAL zdelta, zcor, zcvm5 + LOGICAL imprim +c + INTEGER ncpt + SAVE ncpt +c$OMP THREADPRIVATE(ncpt) + REAL frac(nb) ! valeur de la maille fractionnelle + SAVE frac +c$OMP THREADPRIVATE(frac) + INTEGER opt_cld(nb) ! option pour le modele nuageux + SAVE opt_cld +c$OMP THREADPRIVATE(opt_cld) + LOGICAL appel1er + SAVE appel1er +c$OMP THREADPRIVATE(appel1er) +c +c Fonctions thermodynamiques: +c +#include "YOETHF.h" +#include "FCTTRE.h" +c + DATA frac / 1.0 / + DATA opt_cld / 4 / +ccc DATA frac / 1.0, 0.50, 0.25/ +ccc DATA opt_cld / 4, 4, 4/ +c + DATA appel1er /.TRUE./ + DATA ncpt /0/ +c + IF (appel1er) THEN + PRINT*, 'conman, nb:', nb + PRINT*, 'conman, frac:', frac + PRINT*, 'conman, opt_cld:', opt_cld + appel1er = .FALSE. + ENDIF +c +c Initialiser les sorties a zero: +c + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + d_ql(i,k) = 0.0 + rneb(i,k) = 0.0 + ENDDO + ENDDO + DO i = 1, klon + ibas(i) = klev + itop(i) = 1 + rain(i) = 0.0 + snow(i) = 0.0 + ENDDO +c +c S'il n'y a pas d'instabilite conditionnelle, +c pas la penne de se fatiguer: +c + DO i = 1, klon + afaire(i) = .FALSE. + ENDDO + DO k = 1, klev-1 + DO i = 1, klon + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-t(i,k))) + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k)) + zqs1= R2ES*FOEEW(t(i,k),zdelta)/pplay(i,k) + zqs1=MIN(0.5,zqs1) + zcor=1./(1.-RETV*zqs1) + zqs1=zqs1*zcor + zdqs1 =FOEDE(t(i,k),zdelta,zcvm5,zqs1,zcor) +c + zdelta=MAX(0.,SIGN(1.,RTT-t(i,k+1))) + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k+1)) + zqs2= R2ES*FOEEW(t(i,k+1),zdelta)/pplay(i,k+1) + zqs2=MIN(0.5,zqs2) + zcor=1./(1.-RETV*zqs2) + zqs2=zqs2*zcor + zdqs2 =FOEDE(t(i,k+1),zdelta,zcvm5,zqs2,zcor) + ELSE + IF (t(i,k) .LT. t_coup) THEN + zqs1= qsats(t(i,k)) / pplay(i,k) + zdqs1= dqsats(t(i,k),zqs1) +c + zqs2= qsats(t(i,k+1)) / pplay(i,k+1) + zdqs2= dqsats(t(i,k+1),zqs2) + ELSE + zqs1= qsatl(t(i,k)) / pplay(i,k) + zdqs1= dqsatl(t(i,k),zqs1) +c + zqs2= qsatl(t(i,k+1)) / pplay(i,k+1) + zdqs2= dqsatl(t(i,k+1),zqs2) + ENDIF + ENDIF + zdp1 = paprs(i,k) - paprs(i,k+1) + zdp2 = paprs(i,k+1) - paprs(i,k+2) + zgamdz = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD + . *( RD*(t(i,k)*zdp1+t(i,k+1)*zdp2)/(zdp1+zdp2) + . +RLVTT*(zqs1*zdp1+zqs2*zdp2)/(zdp1+zdp2) + . ) / (1.0+(zdqs1*zdp1+zdqs2*zdp2)/(zdp1+zdp2) ) + zflo = t(i,k) + zgamdz - t(i,k+1) + zsat = (q(i,k)-zqs1)*zdp1 + (q(i,k+1)-zqs2)*zdp2 + IF (zflo.GT.0.0) afaire(i) = .TRUE. +c erreur IF (zflo.GT.0.0 .AND. zsat.GT.0.0) afaire(i) = .TRUE. + ENDDO + ENDDO +c + imprim = MOD(ncpt,48).EQ.0 + DO 99999 n = 1, nb +c + DO k = 1, klev + DO i = 1, klon + IF (afaire(i)) THEN + zq1 = q(i,k) * (1.0-ratqs) + zq2 = q(i,k) * (1.0+ratqs) + w_q(i,k) = zq2 - frac(n)/2.0 * (zq2-zq1) + ENDIF + ENDDO + ENDDO +c + CALL conmanv (dtime, paprs, pplay, t, w_q, + e afaire, opt_cld(n), + s w_d_t, w_d_q, w_d_ql, w_rneb, + s w_rain, w_snow, w_ibas, w_itop,accompli,imprim) + DO k = 1, klev + DO i = 1, klon + IF (afaire(i) .AND. accompli(i)) THEN + d_t(i,k) = w_d_t(i,k) * frac(n) + d_q(i,k) = w_d_q(i,k) * frac(n) + d_ql(i,k) = w_d_ql(i,k) * frac(n) + IF (NINT(w_rneb(i,k)).EQ.1) rneb(i,k) = frac(n) + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (afaire(i) .AND. accompli(i)) THEN + rain(i) = w_rain(i) * frac(n) + snow(i) = w_snow(i) * frac(n) + ibas(i) = MIN(ibas(i),w_ibas(i)) + itop(i) = MAX(itop(i),w_itop(i)) + ENDIF + ENDDO + DO i = 1, klon + IF(afaire(i) .AND. accompli(i)) afaire(i) = .FALSE. + ENDDO +c +99999 CONTINUE +c + ncpt = ncpt + 1 +c + RETURN + END + SUBROUTINE conmanv (dtime, paprs, pplay, t, q, + e afaire, opt_cld, + s d_t, d_q, d_ql, rneb, + s rain, snow, ibas, itop,accompli,imprim) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: ajustement humide (convection proposee par Manabe). +c Pour une colonne verticale, il peut avoir plusieurs blocs +c necessitant l'ajustement. ibas est le bas du plus bas bloc +c et itop est le haut du plus haut bloc +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c Arguments: +c + REAL dtime ! pas d'integration (s) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (kg/kg) + REAL paprs(klon,klev+1) ! pression inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) + INTEGER opt_cld ! comment traiter l'eau liquide + LOGICAL afaire(klon) ! .TRUE. si le point est a faire (Input) + LOGICAL imprim ! .T. pour imprimer quelques diagnostiques +c + REAL d_t(klon,klev) ! incrementation temperature + REAL d_q(klon,klev) ! incrementation humidite + REAL d_ql(klon,klev) ! incrementation eau liquide + REAL rneb(klon,klev) ! nebulosite + REAL rain(klon) ! pluies (mm/s) + REAL snow(klon) ! neige (mm/s) + INTEGER ibas(klon) ! niveau du bas + INTEGER itop(klon) ! niveau du haut + LOGICAL accompli(klon) ! .TRUE. si l'ajustement a eu lieu (Output) +c +c Quelques options: +c + LOGICAL new_top ! re-calculer sommet quand re-ajustement est fait + PARAMETER (new_top=.FALSE.) + LOGICAL evap_prec ! evaporation de pluie au-dessous de convection + PARAMETER (evap_prec=.TRUE.) + REAL coef_eva + PARAMETER (coef_eva=1.0E-05) + REAL t_coup + PARAMETER (t_coup=234.0) + REAL seuil_vap + PARAMETER (seuil_vap=1.0E-10) + LOGICAL old_tau ! implique precip nulle, si vrai. + PARAMETER (old_tau=.FALSE.) + REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante + REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande + PARAMETER (dpmin=0.15, tomax=0.97) + REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible + PARAMETER (dpmax=0.30, tomin=0.05) + REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to + PARAMETER (deep_sig=0.50, deep_to=0.05) + LOGICAL exigent ! implique un calcul supplementaire pour Qs + PARAMETER (exigent=.FALSE.) +c + INTEGER kbase + PARAMETER (kbase=0) +c +c Variables locales: +c + INTEGER nexpo + INTEGER i, k, k1min, k1max, k2min, k2max, is + REAL zgamdz(klon,klev-1) + REAL zt(klon,klev), zq(klon,klev) + REAL zqs(klon,klev), zdqs(klon,klev) + REAL zqmqsdp(klon,klev) + REAL ztnew(klon,klev), zqnew(klon,klev) + REAL zcond(klon), zvapo(klon), zrapp(klon) + REAL zrfl(klon), zrfln, zqev, zqevt + REAL zsat(klon) ! sur-saturation + REAL zflo(klon) ! flotabilite + REAL za(klon), zb(klon), zc(klon) + INTEGER k1(klon), k2(klon) + REAL zdelta, zcor, zcvm5 + REAL delp(klon,klev) + LOGICAL possible(klon), todo(klon), etendre(klon) + LOGICAL aller(klon), todobis(klon) + REAL zalfa + INTEGER nbtodo, nbdone +c +c Fonctions thermodynamiques: +c +#include "YOETHF.h" +#include "FCTTRE.h" +c + DO k = 1, klev + DO i = 1, klon + delp(i,k) = paprs(i,k) - paprs(i,k+1) + ENDDO + ENDDO +c +c Initialiser les sorties a zero +c + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + d_ql(i,k) = 0.0 + rneb(i,k) = 0.0 + ENDDO + ENDDO + DO i = 1, klon + ibas(i) = klev + itop(i) = 1 + rain(i) = 0.0 + snow(i) = 0.0 + accompli(i) = .FALSE. + ENDDO +c +c Preparations +c + DO k = 1, klev + DO i = 1, klon + IF (afaire(i)) THEN + zt(i,k) = t(i,k) + zq(i,k) = q(i,k) +c +c Calculer Qs et L/Cp*dQs/dT +c + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-zt(i,k))) + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i,k)) + zqs(i,k)= R2ES*FOEEW(zt(i,k),zdelta)/pplay(i,k) + zqs(i,k)=MIN(0.5,zqs(i,k)) + zcor=1./(1.-RETV*zqs(i,k)) + zqs(i,k)=zqs(i,k)*zcor + zdqs(i,k) =FOEDE(zt(i,k),zdelta,zcvm5,zqs(i,k),zcor) + ELSE + IF (zt(i,k) .LT. t_coup) THEN + zqs(i,k)= qsats(zt(i,k)) / pplay(i,k) + zdqs(i,k)= dqsats(zt(i,k),zqs(i,k)) + ELSE + zqs(i,k)= qsatl(zt(i,k)) / pplay(i,k) + zdqs(i,k)= dqsatl(zt(i,k),zqs(i,k)) + ENDIF + ENDIF +c +c Calculer (q-qs)*dp + zqmqsdp(i,k) = (zq(i,k)-zqs(i,k)) * delp(i,k) + ENDIF + ENDDO + ENDDO +c +c-----zgama is the moist convective lapse rate (-dT/dz). +c-----zgamdz(*,k) est la difference minimale autorisee des temperatures +c-----entre deux couches (k et k+1), c.a.d. si T(k+1)-T(k) est inferieur +c-----a zgamdz(*,k), alors ces 2 couches sont instables conditionnellement +c + DO k = 1, klev-1 + DO i = 1, klon + IF (afaire(i)) THEN + zgamdz(i,k) = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD + . *( RD*(zt(i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1)) + . /(delp(i,k)+delp(i,k+1)) + . +RLVTT*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1)) + . /(delp(i,k)+delp(i,k+1)) + . ) / (1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i,k+1)) + . /(delp(i,k)+delp(i,k+1)) ) + ENDIF + ENDDO + ENDDO +c +c On cherche la presence simultanee d'instabilite conditionnelle +c et de sur-saturation. Sinon, pas la penne de se fatiguer: +c + DO i = 1, klon + possible(i) = .FALSE. + ENDDO + DO k = 2, klev + DO i = 1, klon + IF (afaire(i)) THEN + zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k) + zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1) + IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) possible(i) = .TRUE. + ENDIF + ENDDO + ENDDO +c + DO i = 1, klon + IF (possible(i)) THEN + k1(i) = kbase + k2(i) = k1(i) + 1 + ENDIF + ENDDO +c + 810 CONTINUE ! chercher le bas de la colonne a ajuster +c + k2min = klev + DO i = 1, klon + todo(i) = .FALSE. + aller(i) = .TRUE. + IF (possible(i)) k2min = MIN(k2min,k2(i)) + ENDDO + IF (k2min.EQ.klev) GOTO 860 + DO k = k2min, klev-1 + DO i = 1, klon + IF (possible(i) .AND. k.GE.k2(i) .AND. aller(i)) THEN + zflo(i) = zt(i,k) + zgamdz(i,k) - zt(i,k+1) + zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k+1) + IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN + k1(i) = k + k2(i) = k+1 + todo(i) = .TRUE. + aller(i) = .FALSE. + ENDIF + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (possible(i).AND.aller(i)) THEN + todo(i) = .FALSE. + k1(i) = klev + k2(i) = klev + ENDIF + ENDDO +c +CCC DO i = 1, klon +CCC IF (possible(i)) THEN +CCC 811 k2(i) = k2(i) + 1 +CCC IF (k2(i) .GT. klev) THEN +CCC todo(i) = .FALSE. +CCC GOTO 812 +CCC ENDIF +CCC k = k2(i) +CCC zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k) +CCC zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1) +CCC IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 811 +CCC k1(i) = k2(i) - 1 +CCC todo(i) = .TRUE. +CCC ENDIF +CCC 812 CONTINUE +CCC ENDDO +c + 820 CONTINUE ! chercher le haut de la colonne +c + k2min = klev + DO i = 1, klon + aller(i) = .TRUE. + IF (todo(i)) k2min = MIN(k2min,k2(i)) + ENDDO + IF (k2min.LT.klev) THEN + DO k = k2min, klev + DO i = 1, klon + IF (todo(i) .AND. k.GT.k2(i) .AND. aller(i)) THEN + zsat(i) = zsat(i) + zqmqsdp(i,k) + zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k) + IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN + aller(i) = .FALSE. + ELSE + k2(i) = k + ENDIF + ENDIF + ENDDO + ENDDO +c error is = 0 +c error DO i = 1, klon +c error IF(todo(i).AND.aller(i)) THEN +c error is = is + 1 +c error todo(i) = .FALSE. +c error k2(i) = klev +c error ENDIF +c error ENDDO +c error IF (is.GT.0) THEN +c error PRINT*, "Bizard. je pourrais continuer mais j arrete" +c error CALL abort +c error ENDIF + ENDIF +c +CCC DO i = 1, klon +CCC IF (todo(i)) THEN +CCC 821 CONTINUE +CCC IF (k2(i) .EQ. klev) GOTO 822 +CCC k = k2(i) + 1 +CCC zsat(i) = zsat(i) + zqmqsdp(i,k) +CCC zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k) +CCC IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 822 +CCC k2(i) = k +CCC GOTO 821 +CCC ENDIF +CCC 822 CONTINUE +CCC ENDDO +c + 830 CONTINUE ! faire l'ajustement en sachant k1 et k2 +c + is = 0 + DO i = 1, klon + IF (todo(i)) THEN + IF (k2(i).LE.k1(i)) is = is + 1 + ENDIF + ENDDO + IF (is.GT.0) THEN + PRINT*, "Impossible: k1 trop grand ou k2 trop petit" + PRINT*, "is=", is + CALL abort + ENDIF +c + k1min = klev + k1max = 1 + k2max = 1 + DO i = 1, klon + IF (todo(i)) THEN + k1min = MIN(k1min,k1(i)) + k1max = MAX(k1max,k1(i)) + k2max = MAX(k2max,k2(i)) + ENDIF + ENDDO +c + DO i = 1, klon + IF (todo(i)) THEN + k = k1(i) + za(i) = 0. + zb(i) = ( RCPD*(1.+zdqs(i,k))*(zt(i,k)-za(i)) + . -RLVTT*(zqs(i,k)-zq(i,k)) )*delp(i,k) + zc(i) = delp(i,k) * RCPD*(1.+zdqs(i,k)) + ENDIF + ENDDO +c + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) THEN + za(i) = za(i) + zgamdz(i,k-1) + zb(i) = zb(i)+(RCPD*(1.+zdqs(i,k))*(zt(i,k)-za(i)) + . -RLVTT*(zqs(i,k)-zq(i,k)) ) * delp(i,k) + zc(i) = zc(i) + delp(i,k)*RCPD*(1.+zdqs(i,k)) + ENDIF + ENDDO + ENDDO +c + DO i = 1, klon + IF (todo(i)) THEN + k = k1(i) + ztnew(i,k) = zb(i)/zc(i) + zqnew(i,k) = zqs(i,k) + (ztnew(i,k)-zt(i,k)) + . *RCPD/RLVTT*zdqs(i,k) + ENDIF + ENDDO +c + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) THEN + ztnew(i,k) = ztnew(i,k-1) + zgamdz(i,k-1) + zqnew(i,k) = zqs(i,k) + (ztnew(i,k)-zt(i,k)) + . *RCPD/RLVTT*zdqs(i,k) + ENDIF + ENDDO + ENDDO +c +c Quantite de condensation produite pendant l'ajustement: +c + DO i = 1, klon + zcond(i) = 0.0 + ENDDO + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN + rneb(i,k) = 1.0 + zcond(i) = zcond(i) + (zq(i,k)-zqnew(i,k)) *delp(i,k)/RG + ENDIF + ENDDO + ENDDO +c +c Si condensation negative, effort completement perdu: +c + DO i = 1, klon + IF (todo(i).AND.zcond(i).LE.0.) todo(i) = .FALSE. + ENDDO +c +c L'ajustement a ete accompli, meme les calculs accessoires +c ne sont pas encore faits: +c + DO i = 1, klon + IF (todo(i)) accompli(i) = .TRUE. + ENDDO +c +c===== +c Une fois que la condensation a lieu, on doit construire un +c "modele nuageux" pour partager la condensation entre l'eau +c liquide nuageuse et la precipitation (leur rapport toliq +c est calcule selon l'epaisseur nuageuse). Je suppose que +c toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin, +c et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation +c lineaire entre dpmin et dpmax). +c===== + DO i = 1, klon + IF (todo(i)) THEN + toliq(i) = tomax-((paprs(i,k1(i))-paprs(i,k2(i)+1)) + . /paprs(i,1)-dpmin) + . *(tomax-tomin)/(dpmax-dpmin) + toliq(i) = MAX(tomin,MIN(tomax,toliq(i))) + IF (pplay(i,k2(i))/paprs(i,1) .LE. deep_sig) toliq(i) = deep_to + IF (old_tau) toliq(i) = 1.0 + ENDIF + ENDDO +c===== +c On doit aussi determiner la distribution verticale de +c l'eau nuageuse. Plusieurs options sont proposees: +c +c (0) La condensation precipite integralement (toliq ne sera +c pas utilise). +c (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle +c a la vapeur d'eau locale. +c (2) Elle est distribuee entre k1 et k2 avec une valeur constante. +c (3) Elle est seulement distribuee aux couches ou la vapeur d'eau +c est effectivement diminuee pendant le processus d'ajustement. +c (4) Elle est en fonction (lineaire ou exponentielle) de la +c distance (epaisseur en pression) avec le niveau k1 (la couche +c k1 n'aura donc pas d'eau liquide). +c===== +c + IF (opt_cld.EQ.0) THEN +c + DO i = 1, klon + IF (todo(i)) zrfl(i) = zcond(i) / dtime + ENDDO +c + ELSE IF (opt_cld.EQ.1) THEN +c + DO i = 1, klon + IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau + ENDDO + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) + . zvapo(i) = zvapo(i) + zqnew(i,k)*delp(i,k)/RG + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) THEN + zrapp(i) = toliq(i) * zcond(i) / zvapo(i) + zrapp(i) = MAX(0.,MIN(1.,zrapp(i))) + zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime + ENDIF + ENDDO + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN + d_ql(i,k) = d_ql(i,k) + zrapp(i) * zqnew(i,k) + ENDIF + ENDDO + ENDDO +c + ELSE IF (opt_cld.EQ.2) THEN +c + DO i = 1, klon + IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse + ENDDO + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) + . zvapo(i) = zvapo(i) + delp(i,k)/RG + ENDDO + ENDDO + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN + d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i) + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime + ENDDO +c + ELSE IF (opt_cld.EQ.3) THEN +c + DO i = 1, klon + IF (todo(i)) zvapo(i) = 0.0 ! quantite de l'eau strictement condensee + ENDDO + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) + . zvapo(i) = zvapo(i) + MAX(0.0,zq(i,k)-zqnew(i,k)) + . * delp(i,k)/RG + ENDDO + ENDDO + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i) .AND. + . zvapo(i).GT.0.0) + . d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i) + . * MAX(0.0,zq(i,k)-zqnew(i,k)) + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime + ENDDO +c + ELSE IF (opt_cld.EQ.4) THEN +c + nexpo = 3 +ccc nexpo = 1 ! distribution lineaire +c + DO i = 1, klon + IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse + ENDDO ! (avec ponderation) + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) + . zvapo(i) = zvapo(i) + delp(i,k) / RG + . * (pplay(i,k1(i))-pplay(i,k))**nexpo + ENDDO + ENDDO + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) + . d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i) + . * (pplay(i,k1(i))-pplay(i,k))**nexpo + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime + ENDDO +c + ELSE ! valeur non-prevue pour opt_cld +c + PRINT*, "opt_cld est faux:", opt_cld + CALL abort +c + ENDIF ! fin de opt_cld +c +c L'eau precipitante peut etre evaporee: +c + zalfa = 0.05 + IF (evap_prec .AND. (k1max.GE.2)) THEN + DO k = k1max-1, 1, -1 + DO i = 1, klon + IF (todo(i) .AND. k.LT.k1(i) .AND. zrfl(i).GT.0.0) THEN + zqev = MAX (0.0, (zqs(i,k)-zq(i,k))*zalfa ) + zqevt = coef_eva * (1.0-zq(i,k)/zqs(i,k))*SQRT(zrfl(i)) + . * delp(i,k)/pplay(i,k)*zt(i,k)*RD/RG + zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) * RG*dtime/delp(i,k) + zqev = MIN (zqev, zqevt) + zrfln = zrfl(i) - zqev*(delp(i,k))/RG/dtime + zq(i,k) = zq(i,k) - (zrfln-zrfl(i)) + . * (RG/(delp(i,k)))*dtime + zt(i,k) = zt(i,k) + (zrfln-zrfl(i)) + . * (RG/(delp(i,k)))*dtime + . * RLVTT/RCPD/(1.0+RVTMP2*zq(i,k)) + zrfl(i) = zrfln + ENDIF + ENDDO + ENDDO + ENDIF +c +c La temperature de la premiere couche determine la pluie ou la neige: +c + DO i = 1, klon + IF (todo(i)) THEN + IF (zt(i,1) .GT. RTT) THEN + rain(i) = rain(i) + zrfl(i) + ELSE + snow(i) = snow(i) + zrfl(i) + ENDIF + ENDIF + ENDDO +c +c Mise a jour de la temperature et de l'humidite +c + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN + zt(i,k) = ztnew(i,k) + zq(i,k) = zqnew(i,k) + ENDIF + ENDDO + ENDDO +c +c Re-calculer certaines variables pour etendre et re-ajuster la colonne +c + IF (exigent) THEN + DO k = 1, klev + DO i = 1, klon + IF (todo(i)) THEN + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-zt(i,k))) + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i,k)) + zqs(i,k)= R2ES*FOEEW(zt(i,k),zdelta)/pplay(i,k) + zqs(i,k)=MIN(0.5,zqs(i,k)) + zcor=1./(1.-RETV*zqs(i,k)) + zqs(i,k)=zqs(i,k)*zcor + zdqs(i,k) =FOEDE(zt(i,k),zdelta,zcvm5,zqs(i,k),zcor) + ELSE + IF (zt(i,k) .LT. t_coup) THEN + zqs(i,k)= qsats(zt(i,k)) / pplay(i,k) + zdqs(i,k)= dqsats(zt(i,k),zqs(i,k)) + ELSE + zqs(i,k)= qsatl(zt(i,k)) / pplay(i,k) + zdqs(i,k)= dqsatl(zt(i,k),zqs(i,k)) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF +c + IF (exigent) THEN + DO k = 1, klev-1 + DO i = 1, klon + IF (todo(i)) THEN + zgamdz(i,k) = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD + . *( RD*(zt(i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1)) + . /(delp(i,k)+delp(i,k+1)) + . +RLVTT*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1)) + . /(delp(i,k)+delp(i,k+1)) + . ) / (1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i,k+1)) + . /(delp(i,k)+delp(i,k+1)) ) + ENDIF + ENDDO + ENDDO + ENDIF +c +c Puisque l'humidite a ete modifiee, on re-fait (q-qs)*dp +c + DO k = 1, klev + DO i = 1, klon + IF (todo(i)) THEN + zqmqsdp(i,k) = (zq(i,k)-zqs(i,k))*delp(i,k) + ENDIF + ENDDO + ENDDO +c +c Verifier si l'on peut etendre le bas de la colonne +c + DO i = 1, klon + etendre(i) = .FALSE. + ENDDO +c + k1max = 1 + DO i = 1, klon + IF (todo(i) .AND. k1(i).GT.(kbase+1)) THEN + k = k1(i) + zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k) + zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1) +csc voici l'ancienne ligne: +csc IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN +csc sylvain: il faut RESPECTER les 2 criteres: + IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN + etendre(i) = .TRUE. + k1(i) = k1(i) - 1 + k1max = MAX(k1max,k1(i)) + aller(i) = .TRUE. + ENDIF + ENDIF + ENDDO +c + IF (k1max.GT.(kbase+1)) THEN + DO k = k1max, kbase+1, -1 + DO i = 1, klon + IF (etendre(i) .AND. k.LT.k1(i) .AND. aller(i)) THEN + zsat(i) = zsat(i) + zqmqsdp(i,k) + zflo(i) = zt(i,k) + zgamdz(i,k) - zt(i,k+1) + IF (zsat(i).LE.0.0 .OR. zflo(i).LE.0.0) THEN + aller(i) = .FALSE. + ELSE + k1(i) = k + ENDIF + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (etendre(i).AND.aller(i)) THEN + k1(i) = 1 + ENDIF + ENDDO + ENDIF +c +CCC DO i = 1, klon +CCC IF (etendre(i)) THEN +CCC 840 k = k1(i) +CCC IF (k.GT.1) THEN +CCC zsat(i) = zsat(i) + zqmqsdp(i,k-1) +CCC zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k) +CCC IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN +CCC k1(i) = k - 1 +CCC GOTO 840 +CCC ENDIF +CCC ENDIF +CCC ENDIF +CCC ENDDO +c + DO i = 1, klon + todobis(i) = todo(i) + todo(i) = .FALSE. + ENDDO + is = 0 + DO i = 1, klon + IF (etendre(i)) THEN + todo(i) = .TRUE. + is = is + 1 + ENDIF + ENDDO + IF (is.GT.0) THEN + IF (new_top) THEN + GOTO 820 ! chercher de nouveau le sommet k2 + ELSE + GOTO 830 ! supposer que le sommet est celui deja trouve + ENDIF + ENDIF +c + DO i = 1, klon + possible(i) = .FALSE. + ENDDO + is = 0 + DO i = 1, klon + IF (todobis(i) .AND. k2(i).LT.klev) THEN + is = is + 1 + possible(i) = .TRUE. + ENDIF + ENDDO + IF (is.GT.0) GOTO 810 !on cherche en haut d'autres blocks +c a ajuster a partir du sommet de la colonne precedente +c + 860 CONTINUE ! Calculer les tendances et diagnostiques +ccc print*, "Apres 860" +c + DO k = 1, klev + DO i = 1, klon + IF (accompli(i)) THEN + d_t(i,k) = zt(i,k) - t(i,k) + zq(i,k) = MAX(zq(i,k),seuil_vap) + d_q(i,k) = zq(i,k) - q(i,k) + ENDIF + ENDDO + ENDDO +c + DO 888 i = 1, klon + IF (accompli(i)) THEN + DO k = 1, klev + IF (rneb(i,k).GT.0.0) THEN + ibas(i) = k + GOTO 807 + ENDIF + ENDDO + 807 CONTINUE + DO k = klev, 1, -1 + IF (rneb(i,k).GT.0.0) THEN + itop(i) = k + GOTO 808 + ENDIF + ENDDO + 808 CONTINUE + ENDIF + 888 CONTINUE +c + IF (imprim) THEN + nbtodo = 0 + nbdone = 0 + DO i = 1, klon + IF (afaire(i)) nbtodo = nbtodo + 1 + IF (accompli(i)) nbdone = nbdone + 1 + ENDDO + PRINT*, "nbTodo, nbDone=", nbtodo, nbdone + ENDIF +c + RETURN + END + SUBROUTINE conkuo(dtime, paprs, pplay, t, q, conv_q, + s d_t, d_q, d_ql, rneb, + s rain, snow, ibas, itop) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: Schema de convection de type Kuo (1965). +c Cette version du code peut calculer le niveau de depart +c N.B. version vectorielle (le 6 oct. 1997) +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c Arguments: +c + REAL dtime ! intervalle du temps (s) + REAL paprs(klon,klev+1) ! pression a inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique + REAL conv_q(klon,klev) ! taux de convergence humidite (g/g/s) +c + REAL d_t(klon,klev) ! incrementation temperature + REAL d_q(klon,klev) ! incrementation humidite + REAL d_ql(klon,klev) ! incrementation eau liquide + REAL rneb(klon,klev) ! nebulosite + REAL rain(klon) ! pluies (mm/s) + REAL snow(klon) ! neige (mm/s) + INTEGER itop(klon) ! niveau du sommet + INTEGER ibas(klon) ! niveau du bas +c + LOGICAL ldcum(klon) ! convection existe + LOGICAL todo(klon) +c +c Quelsques options: +c + LOGICAL calcfcl ! calculer le niveau de convection libre + PARAMETER (calcfcl=.TRUE.) + INTEGER ldepar ! niveau fixe de convection libre + PARAMETER (ldepar=4) + INTEGER opt_cld ! comment traiter l'eau liquide + PARAMETER (opt_cld=4) ! valeur possible: 0, 1, 2, 3 ou 4 + LOGICAL evap_prec ! evaporation de pluie au-dessous de convection + PARAMETER (evap_prec=.TRUE.) + REAL coef_eva + PARAMETER (coef_eva=1.0E-05) + LOGICAL new_deh ! nouvelle facon de calculer dH + PARAMETER (new_deh=.FALSE.) + REAL t_coup + PARAMETER (t_coup=234.0) + LOGICAL old_tau ! implique precipitation nulle + PARAMETER (old_tau=.FALSE.) + REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante + REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande + PARAMETER (dpmin=0.15, tomax=0.97) + REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible + PARAMETER (dpmax=0.30, tomin=0.05) + REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to + PARAMETER (deep_sig=0.50, deep_to=0.05) +c +c Variables locales: +c + INTEGER nexpo + LOGICAL nuage(klon) + INTEGER i, k, kbmin, kbmax, khmax + REAL ztotal(klon,klev), zdeh(klon,klev) + REAL zgz(klon,klev) + REAL zqs(klon,klev) + REAL zdqs(klon,klev) + REAL ztemp(klon,klev) + REAL zpres(klon,klev) + REAL zconv(klon) ! convergence d'humidite + REAL zvirt(klon) ! convergence virtuelle d'humidite + REAL zfrac(klon) ! fraction convective + INTEGER kb(klon), kh(klon) +c + REAL zcond(klon), zvapo(klon), zrapp(klon) + REAL zrfl(klon), zrfln, zqev, zqevt + REAL zdelta, zcvm5, zcor + REAL zvar +c + LOGICAL appel1er + SAVE appel1er +c$OMP THREADPRIVATE(appel1er) +c +c Fonctions thermodynamiques +c +#include "YOETHF.h" +#include "FCTTRE.h" +c + DATA appel1er /.TRUE./ +c + IF (appel1er) THEN + PRINT*, 'conkuo, calcfcl:', calcfcl + IF (.NOT.calcfcl) PRINT*, 'conkuo, ldepar:', ldepar + PRINT*, 'conkuo, opt_cld:', opt_cld + PRINT*, 'conkuo, evap_prec:', evap_prec + PRINT*, 'conkuo, new_deh:', new_deh + appel1er = .FALSE. + ENDIF +c +c Initialiser les sorties a zero +c + DO k = 1, klev + DO i = 1, klon + d_q(i,k) = 0.0 + d_t(i,k) = 0.0 + d_ql(i,k) = 0.0 + rneb(i,k) = 0.0 + ENDDO + ENDDO + DO i = 1, klon + rain(i) = 0.0 + snow(i) = 0.0 + ibas(i) = 0 + itop(i) = 0 + ENDDO +c +c Calculer la vapeur d'eau saturante Qs et sa derive L/Cp * dQs/dT +c + DO k = 1, klev + DO i = 1, klon + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-t(i,k))) + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k)) + zqs(i,k)=R2ES*FOEEW(t(i,k),zdelta)/pplay(i,k) + zqs(i,k)=MIN(0.5,zqs(i,k)) + zcor=1./(1.-RETV*zqs(i,k)) + zqs(i,k)=zqs(i,k)*zcor + zdqs(i,k) =FOEDE(t(i,k),zdelta,zcvm5,zqs(i,k),zcor) + ELSE + IF (t(i,k).LT.t_coup) THEN + zqs(i,k) = qsats(t(i,k))/pplay(i,k) + zdqs(i,k) = dqsats(t(i,k),zqs(i,k)) + ELSE + zqs(i,k) = qsatl(t(i,k))/pplay(i,k) + zdqs(i,k) = dqsatl(t(i,k),zqs(i,k)) + ENDIF + ENDIF + ENDDO + ENDDO +c +c Calculer gz (energie potentielle) +c + DO i = 1, klon + zgz(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) + . * (paprs(i,1)-pplay(i,1)) + ENDDO + DO k = 2, klev + DO i = 1, klon + zgz(i,k) = zgz(i,k-1) + . + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) + . * (pplay(i,k-1)-pplay(i,k)) + ENDDO + ENDDO +c +c Calculer l'energie statique humide saturee (Cp*T + gz + L*Qs) +c + DO k = 1, klev + DO i = 1, klon + ztotal(i,k) = RCPD*t(i,k) + RLVTT*zqs(i,k) + zgz(i,k) + ENDDO + ENDDO +c +c Determiner le niveau de depart et calculer la difference de +c l'energie statique humide saturee (ztotal) entre la couche +c de depart et chaque couche au-dessus. +c + IF (calcfcl) THEN + DO k = 1, klev + DO i = 1, klon + zpres(i,k) = pplay(i,k) + ztemp(i,k) = t(i,k) + ENDDO + ENDDO + CALL kuofcl(ztemp, q, zgz, zpres, ldcum, kb) + DO i = 1, klon + IF (ldcum(i)) THEN + k = kb(i) + IF (new_deh) THEN + zdeh(i,k) = ztotal(i,k-1) - ztotal(i,k) + ELSE + zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k)) + . - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k) + . *(pplay(i,k-1)-pplay(i,k)) + . + RLVTT*(zqs(i,k-1)-zqs(i,k)) + ENDIF + zdeh(i,k) = zdeh(i,k) * 0.5 + ENDIF + ENDDO + DO k = 1, klev + DO i = 1, klon + IF (ldcum(i) .AND. k.GE.(kb(i)+1)) THEN + IF (new_deh) THEN + zdeh(i,k) = zdeh(i,k-1) + (ztotal(i,k-1)-ztotal(i,k)) + ELSE + zdeh(i,k) = zdeh(i,k-1) + . + RCPD * (t(i,k-1)-t(i,k)) + . - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k) + . *(pplay(i,k-1)-pplay(i,k)) + . + RLVTT*(zqs(i,k-1)-zqs(i,k)) + ENDIF + ENDIF + ENDDO + ENDDO + ELSE + DO i = 1, klon + k = ldepar + kb(i) = ldepar + ldcum(i) = .TRUE. + IF (new_deh) THEN + zdeh(i,k) = ztotal(i,k-1) - ztotal(i,k) + ELSE + zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k)) + . - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k) + . *(pplay(i,k-1)-pplay(i,k)) + . + RLVTT*(zqs(i,k-1)-zqs(i,k)) + ENDIF + zdeh(i,k) = zdeh(i,k) * 0.5 + ENDDO + DO k = ldepar+1, klev + DO i = 1, klon + IF (new_deh) THEN + zdeh(i,k) = zdeh(i,k-1) + (ztotal(i,k-1)-ztotal(i,k)) + ELSE + zdeh(i,k) = zdeh(i,k-1) + . + RCPD * (t(i,k-1)-t(i,k)) + . - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k) + . *(pplay(i,k-1)-pplay(i,k)) + . + RLVTT*(zqs(i,k-1)-zqs(i,k)) + ENDIF + ENDDO + ENDDO + ENDIF +c +c-----Chercher le sommet du nuage +c-----Calculer la convergence de l'humidite (en kg/m**2 a un facteur +c-----psolpa/RG pres) du bas jusqu'au sommet du nuage. +c-----Calculer la convergence virtuelle pour que toute la maille +c-----deviennt nuageuse (du bas jusqu'au sommet du nuage) +c + DO i = 1, klon + nuage(i) = .TRUE. + zconv(i) = 0.0 + zvirt(i) = 0.0 + kh(i) = -999 + ENDDO + DO k = 1, klev + DO i = 1, klon + IF (k.GE.kb(i) .AND. ldcum(i)) THEN + nuage(i) = nuage(i) .AND. zdeh(i,k).GT.0.0 + IF (nuage(i)) THEN + kh(i) = k + zconv(i)=zconv(i)+conv_q(i,k)*dtime + . *(paprs(i,k)-paprs(i,k+1)) + zvirt(i)=zvirt(i)+(zdeh(i,k)/RLVTT+zqs(i,k)-q(i,k)) + . *(paprs(i,k)-paprs(i,k+1)) + ENDIF + ENDIF + ENDDO + ENDDO +c + DO i = 1, klon + todo(i) = ldcum(i) .AND. kh(i).GT.kb(i) .AND. zconv(i).GT.0.0 + ENDDO +c + kbmin = klev + kbmax = 0 + khmax = 0 + DO i = 1, klon + IF (todo(i)) THEN + kbmin = MIN(kbmin,kb(i)) + kbmax = MAX(kbmax,kb(i)) + khmax = MAX(khmax,kh(i)) + ENDIF + ENDDO +c +c-----Calculer la surface couverte par le nuage +c + DO i = 1, klon + IF (todo(i)) THEN + zfrac(i) = MAX(0.0,MIN(zconv(i)/zvirt(i), 1.0)) + ENDIF + ENDDO +c +c-----Calculs essentiels: +c + DO i = 1, klon + IF (todo(i)) THEN + zcond(i) = 0.0 + ENDIF + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN + zvar = zdeh(i,k)/(1.+zdqs(i,k)) + d_t(i,k) = zvar * zfrac(i) / RCPD + d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i) + . - conv_q(i,k)*dtime + zcond(i) = zcond(i) - d_q(i,k) *(paprs(i,k)-paprs(i,k+1))/RG + rneb(i,k) = zfrac(i) + ENDIF + ENDDO + ENDDO +c + DO i = 1, klon + IF (todo(i) .AND. zcond(i).LT.0.0) THEN + PRINT*, 'WARNING: cond. negative (Kuo) ', + . i,kb(i),kh(i), zcond(i) + zcond(i) = 0.0 + DO k = kb(i), kh(i) + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + ENDDO + todo(i) = .FALSE. ! effort totalement perdu + ENDIF + ENDDO +c +c===== +c Une fois que la condensation a lieu, on doit construire un +c "modele nuageux" pour partager la condensation entre l'eau +c liquide nuageuse et la precipitation (leur rapport toliq +c est calcule selon l'epaisseur nuageuse). Je suppose que +c toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin, +c et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation +c lineaire entre dpmin et dpmax). +c===== + DO i = 1, klon + IF (todo(i)) THEN + toliq(i) = tomax-((paprs(i,kb(i))-paprs(i,kh(i)+1)) + . /paprs(i,1)-dpmin) + . *(tomax-tomin)/(dpmax-dpmin) + toliq(i) = MAX(tomin,MIN(tomax,toliq(i))) + IF (pplay(i,kh(i))/paprs(i,1) .LE. deep_sig) toliq(i) = deep_to + IF (old_tau) toliq(i) = 1.0 + ENDIF + ENDDO +c===== +c On doit aussi determiner la distribution verticale de +c l'eau nuageuse. Plusieurs options sont proposees: +c +c (0) La condensation precipite integralement (toliq ne sera +c pas utilise). +c (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle +c a la vapeur d'eau locale. +c (2) Elle est distribuee entre k1 et k2 avec une valeur constante. +c (3) Elle est seulement distribuee aux couches ou la vapeur d'eau +c est effectivement diminuee pendant le processus d'ajustement. +c (4) Elle est en fonction (lineaire ou exponentielle) de la +c distance (epaisseur en pression) avec le niveau k1 (la couche +c k1 n'aura donc pas d'eau liquide). +c===== +c + IF (opt_cld.EQ.0) THEN +c + DO i = 1, klon + IF (todo(i)) zrfl(i) = zcond(i) / dtime + ENDDO +c + ELSE IF (opt_cld.EQ.1) THEN +c + DO i = 1, klon + IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN + zvapo(i) = zvapo(i) + (q(i,k)+d_q(i,k)) + . *(paprs(i,k)-paprs(i,k+1))/RG + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) THEN + zrapp(i) = toliq(i) * zcond(i) / zvapo(i) + zrapp(i) = MAX(0.,MIN(1.,zrapp(i))) + ENDIF + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN + d_ql(i,k) = zrapp(i) * (q(i,k)+d_q(i,k)) + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) THEN + zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime + ENDIF + ENDDO +c + ELSE IF (opt_cld.EQ.2) THEN +c + DO i = 1, klon + IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN + zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1))/RG + ENDIF + ENDDO + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN + d_ql(i,k) = toliq(i) * zcond(i) / zvapo(i) + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) THEN + zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime + ENDIF + ENDDO +c + ELSE IF (opt_cld.EQ.3) THEN +c + DO i = 1, klon + IF (todo(i)) THEN + zvapo(i) = 0.0 ! quantite de l'eau strictement condensee + ENDIF + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN + zvapo(i) = zvapo(i) + MAX(0.0,-d_q(i,k)) + . * (paprs(i,k)-paprs(i,k+1))/RG + ENDIF + ENDDO + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i) .AND. + . zvapo(i).GT.0.0) THEN + d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i) + . * MAX(0.0,-d_q(i,k)) + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) THEN + zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime + ENDIF + ENDDO +c + ELSE IF (opt_cld.EQ.4) THEN +c + nexpo = 3 +ccc nexpo = 1 ! distribution lineaire +c + DO i = 1, klon + IF (todo(i)) THEN + zvapo(i) = 0.0 ! quantite integrale de masse (avec ponderation) + ENDIF + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.(kb(i)+1) .AND. k.LE.kh(i)) THEN + zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1)) / RG + . * (pplay(i,kb(i))-pplay(i,k))**nexpo + ENDIF + ENDDO + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.(kb(i)+1) .AND. k.LE.kh(i)) THEN + d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i) + . * (pplay(i,kb(i))-pplay(i,k))**nexpo + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) THEN + zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime + ENDIF + ENDDO +c + ELSE ! valeur non-prevue pour opt_cld +c + PRINT*, "opt_cld est faux:", opt_cld + CALL abort +c + ENDIF ! fin de opt_cld +c +c L'eau precipitante peut etre re-evaporee: +c + IF (evap_prec .AND. kbmax.GE.2) THEN + DO k = kbmax, 1, -1 + DO i = 1, klon + IF (todo(i) .AND. k.LE.(kb(i)-1) .AND. zrfl(i).GT.0.0) THEN + zqev = MAX (0.0, (zqs(i,k)-q(i,k))*zfrac(i) ) + zqevt = coef_eva * (1.0-q(i,k)/zqs(i,k))*SQRT(zrfl(i)) + . * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*t(i,k)*RD/RG + zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) + . * RG*dtime/(paprs(i,k)-paprs(i,k+1)) + zqev = MIN (zqev, zqevt) + zrfln = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1)) + . /RG/dtime + d_q(i,k) = - (zrfln-zrfl(i)) + . * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime + d_t(i,k) = (zrfln-zrfl(i)) + . * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime + . * RLVTT/RCPD + zrfl(i) = zrfln + ENDIF + ENDDO + ENDDO + ENDIF +c +c La temperature de la premiere couche determine la pluie ou la neige: +c + DO i = 1, klon + IF (todo(i)) THEN + IF (t(i,1) .GT. RTT) THEN + rain(i) = rain(i) + zrfl(i) + ELSE + snow(i) = snow(i) + zrfl(i) + ENDIF + ENDIF + ENDDO +c + RETURN + END + SUBROUTINE kuofcl(pt, pq, pg, pp, LDCUM, kcbot) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927 +c adaptation du code de Tiedtke du ECMWF +c Objet: calculer le niveau de convection libre +c (FCL: Free Convection Level) +c====================================================================== +c Arguments: +c pt---input-R- temperature (K) +c pq---input-R- vapeur d'eau (kg/kg) +c pg---input-R- geopotentiel (g*z ou z est en metre) +c pp---input-R- pression (Pa) +c +c LDCUM---output-L- Y-t-il la convection +c kcbot---output-I- Niveau du bas de la convection +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +C + REAL pt(klon,klev), pq(klon,klev), pg(klon,klev), pp(klon,klev) + INTEGER kcbot(klon) + LOGICAL LDCUM(klon) +C + REAL ztu(klon,klev), zqu(klon,klev), zlu(klon,klev) + REAL zqold(klon), zbuo + INTEGER is, i, k +c +c klab=1: on est sous le nuage convectif +c klab=2: le bas du nuage convectif +c klab=0: autres couches + INTEGER klab(klon,klev) +c +c quand lflag=.true., on est sous le nuage, il faut donc appliquer +c le processus d'elevation. + LOGICAL lflag(klon) +C + DO k = 1, klev + DO i = 1, klon + ztu(i,k) = pt(i,k) + zqu(i,k) = pq(i,k) + zlu(i,k) = 0.0 + klab(i,k) = 0 + ENDDO + ENDDO +C---------------------------------------------------------------------- + DO i = 1, klon + klab(i,1)=1 + kcbot(i)=2 + LDCUM(i)=.FALSE. + ENDDO +C + DO 290 k = 2, klev-1 +c + is=0 + DO i = 1, klon + if (klab(i,k-1).EQ.1) is = is + 1 + lflag(i) = .FALSE. + if (klab(i,k-1).EQ.1) lflag(i) = .TRUE. + ENDDO + IF (is.EQ.0) GOTO 290 +c +c on eleve le parcel d'air selon l'adiabatique sec +c + DO i = 1, klon + IF (lflag(i)) THEN + zqu(i,k) = zqu(i,k-1) + ztu(i,k) = ztu(i,k-1) + (pg(i,k-1)-pg(i,k))/RCPD + zbuo = ztu(i,k)*(1.+RETV*zqu(i,k))- + . pt(i,k)*(1.+RETV*pq(i,k))+0.5 + IF (zbuo.GT.0.) klab(i,k)=1 + zqold(i) = zqu(i,k) + ENDIF + ENDDO +c +c on calcule la condensation eventuelle +c + CALL adjtq(pp(1,k), ztu(1,k), zqu(1,k), lflag, 1) +c +c s'il y a la condensation et la "buoyancy" force est positive +c c'est bien le bas de la tour de convection +c + DO i=1, klon + IF(lflag(i).AND.zqu(i,k).NE.zqold(i)) THEN + klab(i,k) = 2 + zlu(i,k) = zlu(i,k)+zqold(i)-zqu(i,k) + zbuo = ztu(i,k)*(1.+RETV*zqu(i,k))- + . pt(i,k)*(1.+RETV*pq(i,k))+0.5 + IF (zbuo.GT.0.) THEN + kcbot(i) = k + LDCUM(i) = .TRUE. + ENDIF + ENDIF + ENDDO +C + 290 CONTINUE +C + RETURN + END + SUBROUTINE adjtq(pp, pt, pq, LDFLAG, KCALL) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927 +c adaptation du code de Tiedtke du ECMWF +c Objet: ajustement entre T et Q +c====================================================================== +c Arguments: +c pp---input-R- pression (Pa) +c pt---input/output-R- temperature (K) +c pq---input/output-R- vapeur d'eau (kg/kg) +c====================================================================== +C TO PRODUCE T,Q AND L VALUES FOR CLOUD ASCENT +C +C NOTE: INPUT PARAMETER KCALL DEFINES CALCULATION AS +C KCALL=0 ENV. T AND QS IN*CUINI* +C KCALL=1 CONDENSATION IN UPDRAFTS (E.G. CUBASE, CUASC) +C KCALL=2 EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF) +C +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +C + REAL pt(klon), pq(klon), pp(klon) + LOGICAL ldflag(klon) + INTEGER KCALL +c + REAL t_coup + PARAMETER (t_coup=234.0) +c + REAL zcond(klon), zcond1 + REAL zdelta, zcvm5, zldcp, zqsat, zcor, zdqsat + INTEGER is, i +#include "YOETHF.h" +#include "FCTTRE.h" +c + DO i = 1, klon + zcond(i) = 0.0 + ENDDO +C + DO 210 i=1, klon + IF (LDFLAG(i)) THEN + zdelta=MAX(0.,SIGN(1.,RTT-pt(i))) + zldcp = RLVTT*(1.-zdelta) + zdelta*RLSTT + zldcp = zldcp / RCPD/(1.0+RVTMP2*pq(i)) + IF (thermcep) THEN + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 / RCPD/(1.0+RVTMP2*pq(i)) + zqsat=R2ES*FOEEW (pt(i), zdelta) / pp(i) + zqsat=MIN(0.5,zqsat) + zcor=1./(1.-RETV *zqsat) + zqsat=zqsat*zcor + zdqsat = FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor) + ELSE + IF (pt(i).LT.t_coup) THEN + zqsat = qsats(pt(i))/pp(i) + zdqsat = dqsats(pt(i),zqsat) + ELSE + zqsat = qsatl(pt(i))/pp(i) + zdqsat = dqsatl(pt(i),zqsat) + ENDIF + ENDIF + zcond(i)=(pq(i)-zqsat) / (1. + zdqsat) + IF(KCALL.EQ.1) zcond(i)=MAX(zcond(i),0.) + IF(KCALL.EQ.2) zcond(i)=MIN(zcond(i),0.) + pt(i)=pt(i)+zldcp*zcond(i) + pq(i)=pq(i)-zcond(i) + ENDIF + 210 CONTINUE +C + is = 0 + DO i=1, klon + if (zcond(i).NE.0.) is = is + 1 + ENDDO + IF(is.EQ.0) GOTO 230 +C + DO 220 i = 1, klon + IF(LDFLAG(i).AND.zcond(i).NE.0.) THEN + zdelta=MAX(0.,SIGN(1.,RTT-pt(i))) + zldcp = RLVTT*(1.-zdelta) + zdelta*RLSTT + zldcp = zldcp / RCPD/(1.0+RVTMP2*pq(i)) + IF (thermcep) THEN + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 / RCPD/(1.0+RVTMP2*pq(i)) + zqsat=R2ES*FOEEW (pt(i), zdelta) / pp(i) + zqsat=MIN(0.5,zqsat) + zcor=1./(1.-RETV *zqsat) + zqsat=zqsat*zcor + zdqsat = FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor) + ELSE + IF (pt(i).LT.t_coup) THEN + zqsat = qsats(pt(i))/pp(i) + zdqsat = dqsats(pt(i),zqsat) + ELSE + zqsat = qsatl(pt(i))/pp(i) + zdqsat = dqsatl(pt(i),zqsat) + ENDIF + ENDIF + zcond1=(pq(i)-zqsat) / (1.+zdqsat) + pt(i)=pt(i)+zldcp*zcond1 + pq(i)=pq(i)-zcond1 + END IF + 220 CONTINUE +C + 230 CONTINUE + RETURN + END + SUBROUTINE fiajh(dtime, paprs, pplay, t, q, + . d_t, d_q, d_ql, rneb, + . rain, snow, ibas, itop) + USE dimphy + IMPLICIT NONE +c +c Ajustement humide (Schema de convection de Manabe) +C. +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c Arguments: +c + REAL dtime ! intervalle du temps (s) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (kg/kg) + REAL paprs(klon,klev+1) ! pression a inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) +c + REAL d_t(klon,klev) ! incrementation pour la temperature + REAL d_q(klon,klev) ! incrementation pour vapeur d'eau + REAL d_ql(klon,klev) ! incrementation pour l'eau liquide + REAL rneb(klon,klev) ! fraction nuageuse +c + REAL rain(klon) ! variable non utilisee + REAL snow(klon) ! variable non utilisee + INTEGER ibas(klon) ! variable non utilisee + INTEGER itop(klon) ! variable non utilisee + + REAL t_coup + PARAMETER (t_coup=234.0) + REAL seuil_vap + PARAMETER (seuil_vap=1.0E-10) +c +c Variables locales: +c + INTEGER i, k + INTEGER k1, k1p, k2, k2p + LOGICAL itest(klon) + REAL delta_q(klon, klev) + REAL cp_new_t(klev) + REAL cp_delta_t(klev) + REAL new_qb(klev) + REAL v_cptj(klev), v_cptjk1, v_ssig + REAL v_cptt(klon,klev), v_p, v_t + REAL v_qs(klon,klev), v_qsd(klon,klev) + REAL zq1(klon), zq2(klon) + REAL gamcpdz(klon,2:klev) + REAL zdp, zdpm +c + REAL zsat ! sur-saturation + REAL zflo ! flotabilite +c + REAL local_q(klon,klev),local_t(klon,klev) +c + REAL zdelta, zcor, zcvm5 +C +#include "YOETHF.h" +#include "FCTTRE.h" +C + DO k = 1, klev + DO i = 1, klon + local_q(i,k) = q(i,k) + local_t(i,k) = t(i,k) + rneb(i,k) = 0.0 + d_ql(i,k) = 0.0 + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + ENDDO + ENDDO + DO i = 1, klon + rain(i) = 0.0 + snow(i) = 0.0 + ibas(i) = 0 + itop(i) = 0 + ENDDO +c +c Calculer v_qs et v_qsd: +c + DO k = 1, klev + DO i = 1, klon + v_cptt(i,k) = RCPD * local_t(i,k) + v_t = local_t(i,k) + v_p = pplay(i,k) +c + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-v_t)) + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*local_q(i,k)) + v_qs(i,k)= R2ES * FOEEW(v_t,zdelta)/v_p + v_qs(i,k)=MIN(0.5,v_qs(i,k)) + zcor=1./(1.-RETV*v_qs(i,k)) + v_qs(i,k)=v_qs(i,k)*zcor + v_qsd(i,k) =FOEDE(v_t,zdelta,zcvm5,v_qs(i,k),zcor) + ELSE + IF (v_t.LT.t_coup) THEN + v_qs(i,k) = qsats(v_t) / v_p + v_qsd(i,k) = dqsats(v_t,v_qs(i,k)) + ELSE + v_qs(i,k) = qsatl(v_t) / v_p + v_qsd(i,k) = dqsatl(v_t,v_qs(i,k)) + ENDIF + ENDIF + ENDDO + ENDDO +c +c Calculer Gamma * Cp * dz: (gamm est le gradient critique) +c + DO k = 2, klev + DO i = 1, klon + zdp = paprs(i,k)-paprs(i,k+1) + zdpm = paprs(i,k-1)-paprs(i,k) + gamcpdz(i,k) = ( ( RD/RCPD /(zdpm+zdp) * + . (v_cptt(i,k-1)*zdpm + v_cptt(i,k)*zdp) + . +RLVTT /(zdpm+zdp) * + . (v_qs(i,k-1)*zdpm + v_qs(i,k)*zdp) + . )* (pplay(i,k-1)-pplay(i,k)) / paprs(i,k) ) + . / (1.0+(v_qsd(i,k-1)*zdpm+ + . v_qsd(i,k)*zdp)/(zdpm+zdp) ) + ENDDO + ENDDO +C +C------------------------------------ modification des profils instables + DO 9999 i = 1, klon + itest(i) = .FALSE. +C + k1 = 0 + k2 = 1 +C + 810 CONTINUE ! chercher k1, le bas de la colonne + k2 = k2 + 1 + IF (k2 .GT. klev) GOTO 9999 + zflo = v_cptt(i,k2-1) - v_cptt(i,k2) - gamcpdz(i,k2) + zsat=(local_q(i,k2-1)-v_qs(i,k2-1))*(paprs(i,k2-1)-paprs(i,k2)) + . +(local_q(i,k2)-v_qs(i,k2))*(paprs(i,k2)-paprs(i,k2+1)) + IF ( zflo.LE.0.0 .OR. zsat.LE.0.0 ) GOTO 810 + k1 = k2 - 1 + itest(i) = .TRUE. +C + 820 CONTINUE ! chercher k2, le haut de la colonne + IF (k2 .EQ. klev) GOTO 821 + k2p = k2 + 1 + zsat=zsat +(paprs(i,k2p)-paprs(i,k2p+1)) + . *(local_q(i,k2p)-v_qs(i,k2p)) + zflo = v_cptt(i,k2p-1) - v_cptt(i,k2p) - gamcpdz(i,k2p) + IF (zflo.LE.0.0 .OR. zsat.LE.0.0) GOTO 821 + k2 = k2p + GOTO 820 + 821 CONTINUE +C +C------------------------------------------------------ ajustement local + 830 CONTINUE ! ajustement proprement dit + v_cptj(k1) = 0.0 + zdp = paprs(i,k1)-paprs(i,k1+1) + v_cptjk1 = ( (1.0+v_qsd(i,k1))*(v_cptt(i,k1)+v_cptj(k1)) + . + RLVTT*(local_q(i,k1)-v_qs(i,k1)) ) * zdp + v_ssig = zdp * (1.0+v_qsd(i,k1)) +C + k1p = k1 + 1 + DO k = k1p, k2 + zdp = paprs(i,k)-paprs(i,k+1) + v_cptj(k) = v_cptj(k-1) + gamcpdz(i,k) + v_cptjk1 = v_cptjk1 + zdp + . * ( (1.0+v_qsd(i, k))*(v_cptt(i,k)+v_cptj(k)) + . + RLVTT*(local_q(i,k)-v_qs(i,k)) ) + v_ssig = v_ssig + zdp *(1.0+v_qsd(i,k)) + ENDDO +C + DO k = k1, k2 + cp_new_t(k) = v_cptjk1/v_ssig - v_cptj(k) + cp_delta_t(k) = cp_new_t(k) - v_cptt(i,k) + new_qb(k) = v_qs(i,k) + v_qsd(i,k)*cp_delta_t(k)/RLVTT + local_q(i,k) = new_qb(k) + local_t(i,k) = cp_new_t(k) / RCPD + ENDDO +C +C--------------------------------------------------- sondage vers le bas +C -- on redefinit les variables prognostiques dans +C -- la colonne qui vient d'etre ajustee +C + DO k = k1, k2 + v_cptt(i,k) = RCPD * local_t(i,k) + v_t = local_t(i,k) + v_p = pplay(i,k) +C + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-v_t)) + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*local_q(i,k)) + v_qs(i,k)= R2ES * FOEEW(v_t,zdelta)/v_p + v_qs(i,k)=MIN(0.5,v_qs(i,k)) + zcor=1./(1.-RETV*v_qs(i,k)) + v_qs(i,k)=v_qs(i,k)*zcor + v_qsd(i,k) =FOEDE(v_t,zdelta,zcvm5,v_qs(i,k),zcor) + ELSE + IF (v_t.LT.t_coup) THEN + v_qs(i,k) = qsats(v_t) / v_p + v_qsd(i,k) = dqsats(v_t,v_qs(i,k)) + ELSE + v_qs(i,k) = qsatl(v_t) / v_p + v_qsd(i,k) = dqsatl(v_t,v_qs(i,k)) + ENDIF + ENDIF + ENDDO + DO k = 2, klev + zdpm = paprs(i,k-1) - paprs(i,k) + zdp = paprs(i,k) - paprs(i,k+1) + gamcpdz(i,k) = ( ( RD/RCPD /(zdpm+zdp) * + . (v_cptt(i,k-1)*zdpm+v_cptt(i,k)*zdp) + . +RLVTT /(zdpm+zdp) * + . (v_qs(i,k-1)*zdpm+v_qs(i,k)*zdp) + . )* (pplay(i,k-1)-pplay(i,k)) / paprs(i,k) ) + . / (1.0+(v_qsd(i,k-1)*zdpm+v_qsd(i,k)*zdp) + . /(zdpm+zdp) ) + ENDDO +C +C Verifier si l'on peut etendre la colonne vers le bas +C + IF (k1 .EQ. 1) GOTO 841 ! extension echouee + zflo = v_cptt(i,k1-1) - v_cptt(i,k1) - gamcpdz(i,k1) + zsat=(local_q(i,k1-1)-v_qs(i,k1-1))*(paprs(i,k1-1)-paprs(i,k1)) + . + (local_q(i,k1)-v_qs(i,k1))*(paprs(i,k1)-paprs(i,k1+1)) + IF (zflo.LE.0.0 .OR. zsat.LE.0.0) GOTO 841 ! extension echouee +C + 840 CONTINUE + k1 = k1 - 1 + IF (k1 .EQ. 1) GOTO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995) + zsat = zsat + (local_q(i,k1-1)-v_qs(i,k1-1)) + . *(paprs(i,k1-1)-paprs(i,k1)) + zflo = v_cptt(i,k1-1) - v_cptt(i,k1) - gamcpdz(i,k1) + IF (zflo.GT.0.0 .AND. zsat.GT.0.0) THEN + GOTO 840 + ELSE + GOTO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995) + ENDIF + 841 CONTINUE +C + GOTO 810 ! chercher d'autres blocks en haut +C + 9999 CONTINUE ! boucle sur tous les points +C----------------------------------------------------------------------- +c +c Determiner la fraction nuageuse (hypothese: la nebulosite a lieu +c a l'endroit ou la vapeur d'eau est diminuee par l'ajustement): +c + DO k = 1, klev + DO i = 1, klon + IF (itest(i)) THEN + delta_q(i,k) = local_q(i,k) - q(i,k) + IF (delta_q(i,k).LT.0.) rneb(i,k) = 1.0 + ENDIF + ENDDO + ENDDO +c +c Distribuer l'eau condensee en eau liquide nuageuse (hypothese: +c l'eau liquide est distribuee aux endroits ou la vapeur d'eau +c diminue et d'une maniere proportionnelle a cet diminution): +c + DO i = 1, klon + IF (itest(i)) THEN + zq1(i) = 0.0 + zq2(i) = 0.0 + ENDIF + ENDDO + DO k = 1, klev + DO i = 1, klon + IF (itest(i)) THEN + zdp = paprs(i,k)-paprs(i,k+1) + zq1(i) = zq1(i) - delta_q(i,k) * zdp + zq2(i) = zq2(i) - MIN(0.0, delta_q(i,k)) * zdp + ENDIF + ENDDO + ENDDO + DO k = 1, klev + DO i = 1, klon + IF (itest(i)) THEN + IF (zq2(i).NE.0.0) + . d_ql(i,k) = - MIN(0.0,delta_q(i,k))*zq1(i)/zq2(i) + ENDIF + ENDDO + ENDDO +C + DO k = 1, klev + DO i = 1, klon + local_q(i, k) = MAX(local_q(i, k), seuil_vap) + ENDDO + ENDDO +C + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = local_t(i,k) - t(i,k) + d_q(i,k) = local_q(i,k) - q(i,k) + ENDDO + ENDDO +c + RETURN + END + SUBROUTINE fiajc(dtime,paprs,pplay, + . t, q,conv_q, + . d_t, d_q, d_ql,rneb, + . rain, snow, ibas, itop) + USE dimphy + IMPLICIT NONE +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c Options: +c + INTEGER plb ! niveau de depart pour la convection + PARAMETER (plb=4) +c +c Mystere: cette option n'est pas innocente pour les resultats ! +c Qui peut resoudre ce mystere ? (Z.X.Li mars 1995) + LOGICAL vector ! calcul vectorise + PARAMETER (vector=.FALSE.) +c + REAL t_coup + PARAMETER (t_coup=234.0) +c +c Arguments: +c + REAL q(klon,klev) ! humidite specifique (kg/kg) + REAL t(klon,klev) ! temperature (K) + REAL paprs(klon,klev+1) ! pression a inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) + REAL dtime ! intervalle du temps (s) + REAL conv_q(klon,klev) ! taux de convergence de l'humidite + REAL rneb(klon,klev) ! fraction nuageuse + REAL d_q(klon,klev) ! incrementaion pour la vapeur d'eau + REAL d_ql(klon,klev) ! incrementation pour l'eau liquide + REAL d_t(klon,klev) ! incrementation pour la temperature + REAL rain(klon) ! variable non-utilisee + REAL snow(klon) ! variable non-utilisee + INTEGER itop(klon) ! variable non-utilisee + INTEGER ibas(klon) ! variable non-utilisee +c + INTEGER kh(klon), i, k + LOGICAL nuage(klon), test(klon,klev) + REAL zconv(klon), zdeh(klon,klev), zvirt(klon) + REAL zdqs(klon,klev), zqs(klon,klev) + REAL ztt, zvar, zfrac(klon) + REAL zq1(klon), zq2(klon) + REAL zdelta, zcor, zcvm5 +C +#include "YOETHF.h" +#include "FCTTRE.h" +c +c Initialiser les sorties: +c + DO k = 1, klev + DO i = 1, klon + rneb(i,k) = 0.0 + d_ql(i,k) = 0.0 + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + ENDDO + ENDDO + DO i = 1, klon + itop(i) = 0 + ibas(i) = 0 + rain(i) = 0.0 + snow(i) = 0.0 + ENDDO +c +c Calculer Qs et L/Cp * dQs/dT: +c + DO k = 1, klev + DO i = 1, klon + ztt = t(i,k) + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-ztt)) + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k)) + zqs(i,k)= R2ES*FOEEW(ztt,zdelta)/pplay(i,k) + zqs(i,k)=MIN(0.5,zqs(i,k)) + zcor=1./(1.-RETV*zqs(i,k)) + zqs(i,k)=zqs(i,k)*zcor + zdqs(i,k) =FOEDE(ztt,zdelta,zcvm5,zqs(i,k),zcor) + ELSE + IF (ztt .LT. t_coup) THEN + zqs(i,k) = qsats(ztt) / pplay(i,k) + zdqs(i,k) = dqsats(ztt,zqs(i,k)) + ELSE + zqs(i,k) = qsatl(ztt) / pplay(i,k) + zdqs(i,k) = dqsatl(ztt,zqs(i,k)) + ENDIF + ENDIF + ENDDO + ENDDO +c +c Determiner la difference de l'energie totale saturee: +c + DO i = 1, klon + k = plb + zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k)) + . - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k) + . *(pplay(i,k-1)-pplay(i,k)) + . + RLVTT*(zqs(i,k-1)-zqs(i,k)) + zdeh(i,k) = zdeh(i,k) * 0.5 ! on prend la moitie + ENDDO + DO k = plb+1, klev + DO i = 1, klon + zdeh(i,k) = zdeh(i,k-1) + . + RCPD * (t(i,k-1)-t(i,k)) + . - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k) + . *(pplay(i,k-1)-pplay(i,k)) + . + RLVTT*(zqs(i,k-1)-zqs(i,k)) + ENDDO + ENDDO +c +c Determiner le sommet du nuage selon l'instabilite +c Calculer les convergences d'humidite (reelle et virtuelle) +c + DO i = 1, klon + nuage(i) = .TRUE. + zconv(i) = 0.0 + zvirt(i) = 0.0 + kh(i) = -999 + ENDDO + DO k = plb, klev + DO i = 1, klon + nuage(i) = nuage(i) .AND. zdeh(i,k).GT.0.0 + IF (nuage(i)) THEN + kh(i) = k + zconv(i) = zconv(i)+conv_q(i,k)*dtime + . *(paprs(i,k)-paprs(i,k+1)) + zvirt(i)=zvirt(i)+(zdeh(i,k)/RLVTT+zqs(i,k)-q(i,k)) + . *(paprs(i,k)-paprs(i,k+1)) + ENDIF + ENDDO + ENDDO +c + IF (vector) THEN +c +c + DO k = plb, klev + DO i = 1, klon + IF (k.LE.kh(i) .AND. kh(i).GT.plb .AND. zconv(i).GT.0.0) THEN + test(i,k) = .TRUE. + zfrac(i) = MAX(0.0,MIN(zconv(i)/zvirt(i),1.0)) + ELSE + test(i,k) = .FALSE. + ENDIF + ENDDO + ENDDO +c + DO k = plb, klev + DO i = 1, klon + IF (test(i,k)) THEN + zvar = zdeh(i,k)/(1.0+zdqs(i,k)) + d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i) + . - conv_q(i,k)*dtime + d_t(i,k) = zvar * zfrac(i) / RCPD + ENDIF + ENDDO + ENDDO +c + DO i = 1, klon + zq1(i) = 0.0 + zq2(i) = 0.0 + ENDDO + DO k = plb, klev + DO i = 1, klon + IF (test(i,k)) THEN + IF (d_q(i,k).LT.0.0) rneb(i,k) = zfrac(i) + zq1(i) = zq1(i) - d_q(i,k) * (paprs(i,k)-paprs(i,k+1)) + zq2(i) = zq2(i) - MIN(0.0, d_q(i,k)) + . * (paprs(i,k)-paprs(i,k+1)) + ENDIF + ENDDO + ENDDO +c + DO k = plb, klev + DO i = 1, klon + IF (test(i,k)) THEN + IF(zq2(i).NE.0.)d_ql(i,k)=-MIN(0.0,d_q(i,k))*zq1(i)/zq2(i) + ENDIF + ENDDO + ENDDO +c + ELSE ! (.NOT. vector) +c + DO 999 i = 1, klon + IF (kh(i).GT.plb .AND. zconv(i).GT.0.0) THEN +ccc IF (kh(i).LE.plb) GOTO 999 ! il n'y a pas d'instabilite +ccc IF (zconv(i).LE.0.0) GOTO 999 ! convergence insuffisante + zfrac(i) = MAX(0.0,MIN(zconv(i)/zvirt(i),1.0)) + DO k = plb, kh(i) + zvar = zdeh(i,k)/(1.0+zdqs(i,k)) + d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i) + . - conv_q(i,k)*dtime + d_t(i,k) = zvar * zfrac(i) / RCPD + ENDDO +c + zq1(i) = 0.0 + zq2(i) = 0.0 + DO k = plb, kh(i) + IF (d_q(i,k).LT.0.0) rneb(i,k) = zfrac(i) + zq1(i) = zq1(i) - d_q(i,k) * (paprs(i,k)-paprs(i,k+1)) + zq2(i) = zq2(i) - MIN(0.0, d_q(i,k)) + . * (paprs(i,k)-paprs(i,k+1)) + ENDDO + DO k = plb, kh(i) + IF(zq2(i).NE.0.)d_ql(i,k)=-MIN(0.0,d_q(i,k))*zq1(i)/zq2(i) + ENDDO + ENDIF + 999 CONTINUE +c + ENDIF ! fin de teste sur vector +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/convect1.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/convect1.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/convect1.F (revision 1280) @@ -0,0 +1,649 @@ +! +! $Header$ +! + subroutine convect1(len,nd,ndp1,noff,minorig, + & t,q,qs,u,v, + & p,ph,iflag,ft, + & fq,fu,fv,precip,cbmf,delt,Ma) +C.............................START PROLOGUE............................ +C +C SCCS IDENTIFICATION: @(#)convect1.f 1.1 04/21/00 +C 19:40:52 /h/cm/library/nogaps4/src/sub/fcst/convect1.f_v +C +C CONFIGURATION IDENTIFICATION: None +C +C MODULE NAME: convect1 +C +C DESCRIPTION: +C +C convect1 The Emanuel Cumulus Convection Scheme +C +C CONTRACT NUMBER AND TITLE: None +C +C REFERENCES: Programmers K. Emanuel (MIT), Timothy F. Hogan, M. Peng (NRL) +C +C CLASSIFICATION: Unclassified +C +C RESTRICTIONS: None +C +C COMPILER DEPENDENCIES: FORTRAN 77, FORTRAN 90 +C +C COMPILE OPTIONS: Fortran 77: -Zu -Wf"-ei -o aggress" +C Fortran 90: -O vector3,scalar3,task1,aggress,overindex -ei -r 2 +C +C LIBRARIES OF RESIDENCE: /a/ops/lib/libfcst159.a +C +C USAGE: call convect1(len,nd,noff,minorig, +C & t,q,qs,u,v, +C & p,ph,iflag,ft, +C & fq,fu,fv,precip,cbmf,delt) +C +C PARAMETERS: +C Name Type Usage Description +C ---------- ---------- ------- ---------------------------- +C +C len Integer Input first (i) dimension +C nd Integer Input vertical (k) dimension +C ndp1 Integer Input nd + 1 +C noff Integer Input integer limit for convection (nd-noff) +C minorig Integer Input First level of convection +C t Real Input temperature +C q Real Input specific hum +C qs Real Input sat specific hum +C u Real Input u-wind +C v Real Input v-wind +C p Real Input full level pressure +C ph Real Input half level pressure +C iflag Integer Output iflag on latitude strip +C ft Real Output temp tend +C fq Real Output spec hum tend +C fu Real Output u-wind tend +C fv Real Output v-wind tend +C cbmf Real In/Out cumulus mass flux +C delt Real Input time step +C iflag Integer Output integer flag for Emanuel conditions +C +C COMMON BLOCKS: +C Block Name Type Usage Notes +C -------- -------- ---- ------ ------------------------ +C +C FILES: None +C +C DATA BASES: None +C +C NON-FILE INPUT/OUTPUT: None +C +C ERROR CONDITIONS: None +C +C ADDITIONAL COMMENTS: None +C +C.................MAINTENANCE SECTION................................ +C +C MODULES CALLED: +C Name Description +C convect2 Emanuel cumulus convection tendency calculations +C ------- ---------------------- +C LOCAL VARIABLES AND +C STRUCTURES: +C Name Type Description +C ------- ------ ----------- +C See Comments Below +C +C i Integer loop index +C k Integer loop index +c +C METHOD: +C +C See Emanuel, K. and M. Zivkovic-Rothman, 2000: Development and evaluation of a +C convective scheme for use in climate models. +C +C FILES: None +C +C INCLUDE FILES: None +C +C MAKEFILE: /a/ops/met/nogaps/src/sub/fcst/fcst159lib.mak +C +C..............................END PROLOGUE............................. +c +c + USE dimphy + implicit none +c +cym#include "dimensions.h" +cym#include "dimphy.h" +c + integer len + integer nd + integer ndp1 + integer noff + real t(len,nd) + real q(len,nd) + real qs(len,nd) + real u(len,nd) + real v(len,nd) + real p(len,nd) + real ph(len,ndp1) + integer iflag(len) + real ft(len,nd) + real fq(len,nd) + real fu(len,nd) + real fv(len,nd) + real precip(len) + real cbmf(len) + real Ma(len,nd) + integer minorig + real delt,cpd,cpv,cl,rv,rd,lv0,g + real sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp + real alpha,entp,coeffs,coeffr,omtrain,cu +c +!------------------------------------------------------------------- +! --- ARGUMENTS +!------------------------------------------------------------------- +! --- On input: +! +! t: Array of absolute temperature (K) of dimension ND, with first +! index corresponding to lowest model level. Note that this array +! will be altered by the subroutine if dry convective adjustment +! occurs and if IPBL is not equal to 0. +! +! q: Array of specific humidity (gm/gm) of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! qs: Array of saturation specific humidity of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! u: Array of zonal wind velocity (m/s) of dimension ND, witth first +! index corresponding with the lowest model level. Defined at +! same levels as T. Note that this array will be altered if +! dry convective adjustment occurs and if IPBL is not equal to 0. +! +! v: Same as u but for meridional velocity. +! +! tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA), +! where NTRA is the number of different tracers. If no +! convective tracer transport is needed, define a dummy +! input array of dimension (ND,1). Tracers are defined at +! same vertical levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! p: Array of pressure (mb) of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. +! +! ph: Array of pressure (mb) of dimension ND+1, with first index +! corresponding to lowest level. These pressures are defined at +! levels intermediate between those of P, T, Q and QS. The first +! value of PH should be greater than (i.e. at a lower level than) +! the first value of the array P. +! +! nl: The maximum number of levels to which convection can penetrate, plus 1. +! NL MUST be less than or equal to ND-1. +! +! delt: The model time step (sec) between calls to CONVECT +! +!---------------------------------------------------------------------------- +! --- On Output: +! +! iflag: An output integer whose value denotes the following: +! VALUE INTERPRETATION +! ----- -------------- +! 0 Moist convection occurs. +! 1 Moist convection occurs, but a CFL condition +! on the subsidence warming is violated. This +! does not cause the scheme to terminate. +! 2 Moist convection, but no precip because ep(inb) lt 0.0001 +! 3 No moist convection because new cbmf is 0 and old cbmf is 0. +! 4 No moist convection; atmosphere is not +! unstable +! 6 No moist convection because ihmin le minorig. +! 7 No moist convection because unreasonable +! parcel level temperature or specific humidity. +! 8 No moist convection: lifted condensation +! level is above the 200 mb level. +! 9 No moist convection: cloud base is higher +! then the level NL-1. +! +! ft: Array of temperature tendency (K/s) of dimension ND, defined at same +! grid levels as T, Q, QS and P. +! +! fq: Array of specific humidity tendencies ((gm/gm)/s) of dimension ND, +! defined at same grid levels as T, Q, QS and P. +! +! fu: Array of forcing of zonal velocity (m/s^2) of dimension ND, +! defined at same grid levels as T. +! +! fv: Same as FU, but for forcing of meridional velocity. +! +! ftra: Array of forcing of tracer content, in tracer mixing ratio per +! second, defined at same levels as T. Dimensioned (ND,NTRA). +! +! precip: Scalar convective precipitation rate (mm/day). +! +! wd: A convective downdraft velocity scale. For use in surface +! flux parameterizations. See convect.ps file for details. +! +! tprime: A convective downdraft temperature perturbation scale (K). +! For use in surface flux parameterizations. See convect.ps +! file for details. +! +! qprime: A convective downdraft specific humidity +! perturbation scale (gm/gm). +! For use in surface flux parameterizations. See convect.ps +! file for details. +! +! cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST +! BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT +! ITS NEXT CALL. That is, the value of CBMF must be "remembered" +! by the calling program between calls to CONVECT. +! +! det: Array of detrainment mass flux of dimension ND. +! +!------------------------------------------------------------------- +c +c Local arrays +c + integer nl + integer nlp + integer nlm + integer i,k,n + real delti + real rowl + real clmcpv + real clmcpd + real cpdmcp + real cpvmcpd + real eps + real epsi + real epsim1 + real ginv + real hrd + real prccon1 + integer icbmax + real lv(klon,klev) + real cpn(klon,klev) + real cpx(klon,klev) + real tv(klon,klev) + real gz(klon,klev) + real hm(klon,klev) + real h(klon,klev) + real work(klon) + integer ihmin(klon) + integer nk(klon) + real rh(klon) + real chi(klon) + real plcl(klon) + integer icb(klon) + real tnk(klon) + real qnk(klon) + real gznk(klon) + real pnk(klon) + real qsnk(klon) + real ticb(klon) + real gzicb(klon) + real tp(klon,klev) + real tvp(klon,klev) + real clw(klon,klev) +c + real ah0(klon),cpp(klon) + real tg,qg,s,alv,tc,ahg,denom,es,rg +c + integer ncum + integer idcum(klon) +c + cpd=1005.7 + cpv=1870.0 + cl=4190.0 + rv=461.5 + rd=287.04 + lv0=2.501E6 + g=9.8 +C +C *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) *** +C *** TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO- *** +C *** CONVERSION THRESHOLD IS ASSUMED TO BE ZERO *** +C *** (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY *** +C *** BETWEEN 0 C AND TLCRIT) *** +C *** ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT *** +C *** FORMULATION *** +C *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** +C *** SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** +C *** OF CLOUD *** +C *** OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN *** +C *** OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW *** +C *** COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** +C *** OF RAIN *** +C *** COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** +C *** OF SNOW *** +C *** CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM *** +C *** TRANSPORT *** +C *** DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION *** +C *** A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC *** +C *** ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** (THEIR STANDARD VALUES ARE 0.20 AND 0.1, RESPECTIVELY) *** +C *** (DAMP MUST BE LESS THAN 1) *** +c + sigs=0.12 + sigd=0.05 + elcrit=0.0011 + tlcrit=-55.0 + omtsnow=5.5 + dtmax=0.9 + damp=0.1 + alpha=0.2 + entp=1.5 + coeffs=0.8 + coeffr=1.0 + omtrain=50.0 +c + cu=0.70 + damp=0.1 +c +c +c Define nl, nlp, nlm, and delti +c + nl=nd-noff + nlp=nl+1 + nlm=nl-1 + delti=1.0/delt +! +!------------------------------------------------------------------- +! --- SET CONSTANTS +!------------------------------------------------------------------- +! + rowl=1000.0 + clmcpv=cl-cpv + clmcpd=cl-cpd + cpdmcp=cpd-cpv + cpvmcpd=cpv-cpd + eps=rd/rv + epsi=1.0/eps + epsim1=epsi-1.0 + ginv=1.0/g + hrd=0.5*rd + prccon1=86400.0*1000.0/(rowl*g) +! +! dtmax is the maximum negative temperature perturbation. +! +!===================================================================== +! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS +!===================================================================== +! + do 20 k=1,nd + do 10 i=1,len + ft(i,k)=0.0 + fq(i,k)=0.0 + fu(i,k)=0.0 + fv(i,k)=0.0 + tvp(i,k)=0.0 + tp(i,k)=0.0 + clw(i,k)=0.0 + gz(i,k) = 0. + 10 continue + 20 continue + do 60 i=1,len + precip(i)=0.0 + iflag(i)=0 + 60 continue +c +!===================================================================== +! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY +!===================================================================== + do 110 k=1,nl+1 + do 100 i=1,len + lv(i,k)= lv0-clmcpv*(t(i,k)-273.15) + cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k) + cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k) + tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1) + 100 continue + 110 continue +c +c gz = phi at the full levels (same as p). +c + do 120 i=1,len + gz(i,1)=0.0 + 120 continue + do 140 k=2,nlp + do 130 i=1,len + gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k)) + & *(p(i,k-1)-p(i,k))/ph(i,k) + 130 continue + 140 continue +c +c h = phi + cpT (dry static energy). +c hm = phi + cp(T-Tbase)+Lq +c + do 170 k=1,nlp + do 160 i=1,len + h(i,k)=gz(i,k)+cpn(i,k)*t(i,k) + hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k) + 160 continue + 170 continue +c +!------------------------------------------------------------------- +! --- Find level of minimum moist static energy +! --- If level of minimum moist static energy coincides with +! --- or is lower than minimum allowable parcel origin level, +! --- set iflag to 6. +!------------------------------------------------------------------- + do 180 i=1,len + work(i)=1.0e12 + ihmin(i)=nl + 180 continue + do 200 k=2,nlp + do 190 i=1,len + if((hm(i,k).lt.work(i)).and. + & (hm(i,k).lt.hm(i,k-1)))then + work(i)=hm(i,k) + ihmin(i)=k + endif + 190 continue + 200 continue + do 210 i=1,len + ihmin(i)=min(ihmin(i),nlm) + if(ihmin(i).le.minorig)then + iflag(i)=6 + endif + 210 continue +c +!------------------------------------------------------------------- +! --- Find that model level below the level of minimum moist static +! --- energy that has the maximum value of moist static energy +!------------------------------------------------------------------- + + do 220 i=1,len + work(i)=hm(i,minorig) + nk(i)=minorig + 220 continue + do 240 k=minorig+1,nl + do 230 i=1,len + if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then + work(i)=hm(i,k) + nk(i)=k + endif + 230 continue + 240 continue +!------------------------------------------------------------------- +! --- Check whether parcel level temperature and specific humidity +! --- are reasonable +!------------------------------------------------------------------- + do 250 i=1,len + if(((t(i,nk(i)).lt.250.0).or. + & (q(i,nk(i)).le.0.0).or. + & (p(i,ihmin(i)).lt.400.0)).and. + & (iflag(i).eq.0))iflag(i)=7 + 250 continue +!------------------------------------------------------------------- +! --- Calculate lifted condensation level of air at parcel origin level +! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980) +!------------------------------------------------------------------- + do 260 i=1,len + tnk(i)=t(i,nk(i)) + qnk(i)=q(i,nk(i)) + gznk(i)=gz(i,nk(i)) + pnk(i)=p(i,nk(i)) + qsnk(i)=qs(i,nk(i)) +c + rh(i)=qnk(i)/qsnk(i) + rh(i)=min(1.0,rh(i)) + chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i)) + plcl(i)=pnk(i)*(rh(i)**chi(i)) + if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0)) + & .and.(iflag(i).eq.0))iflag(i)=8 + 260 continue +!------------------------------------------------------------------- +! --- Calculate first level above lcl (=icb) +!------------------------------------------------------------------- + do 270 i=1,len + icb(i)=nlm + 270 continue +c + do 290 k=minorig,nl + do 280 i=1,len + if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i))) + & icb(i)=min(icb(i),k) + 280 continue + 290 continue +c + do 300 i=1,len + if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9 + 300 continue +c +c Compute icbmax. +c + icbmax=2 + do 310 i=1,len + icbmax=max(icbmax,icb(i)) + 310 continue +! +!------------------------------------------------------------------- +! --- Calculates the lifted parcel virtual temperature at nk, +! --- the actual temperature, and the adiabatic +! --- liquid water content. The procedure is to solve the equation. +! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. +!------------------------------------------------------------------- +! + do 320 i=1,len + tnk(i)=t(i,nk(i)) + qnk(i)=q(i,nk(i)) + gznk(i)=gz(i,nk(i)) + ticb(i)=t(i,icb(i)) + gzicb(i)=gz(i,icb(i)) + 320 continue +c +c *** Calculate certain parcel quantities, including static energy *** +c + do 330 i=1,len + ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + & +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i) + cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv + 330 continue +c +c *** Calculate lifted parcel quantities below cloud base *** +c + do 350 k=minorig,icbmax-1 + do 340 i=1,len + tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))/cpp(i) + tvp(i,k)=tp(i,k)*(1.+qnk(i)*epsi) + 340 continue + 350 continue +c +c *** Find lifted parcel quantities above cloud base *** +c + do 360 i=1,len + tg=ticb(i) + qg=qs(i,icb(i)) + alv=lv0-clmcpv*(ticb(i)-273.15) +c +c First iteration. +c + s=cpd+alv*alv*qg/(rv*ticb(i)*ticb(i)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-273.15 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + endif + qg=eps*es/(p(i,icb(i))-es*(1.-eps)) +c +c Second iteration. +c + s=cpd+alv*alv*qg/(rv*ticb(i)*ticb(i)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-273.15 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + end if + qg=eps*es/(p(i,icb(i))-es*(1.-eps)) +c + alv=lv0-clmcpv*(ticb(i)-273.15) + tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i) + & -gz(i,icb(i))-alv*qg)/cpd + clw(i,icb(i))=qnk(i)-qg + clw(i,icb(i))=max(0.0,clw(i,icb(i))) + rg=qg/(1.-qnk(i)) + tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi) + 360 continue +c + do 380 k=minorig,icbmax + do 370 i=1,len + tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i) + 370 continue + 380 continue +c +!------------------------------------------------------------------- +! --- Test for instability. +! --- If there was no convection at last time step and parcel +! --- is stable at icb, then set iflag to 4. +!------------------------------------------------------------------- + + do 390 i=1,len + if((cbmf(i).eq.0.0) .and.(iflag(i).eq.0).and. + & (tvp(i,icb(i)).le.(tv(i,icb(i))-dtmax)))iflag(i)=4 + 390 continue + +!===================================================================== +! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY +!===================================================================== +c + ncum=0 + do 400 i=1,len + if(iflag(i).eq.0)then + ncum=ncum+1 + idcum(ncum)=i + endif + 400 continue +c +c Call convect2, which compresses the points and computes the heating, +c moistening, velocity mixing, and precipiation. +c +c print*,'cpd avant convect2 ',cpd + if(ncum.gt.0)then + call convect2(ncum,idcum,len,nd,ndp1,nl,minorig, + & nk,icb, + & t,q,qs,u,v,gz,tv,tp,tvp,clw,h, + & lv,cpn,p,ph,ft,fq,fu,fv, + & tnk,qnk,gznk,plcl, + & precip,cbmf,iflag, + & delt,cpd,cpv,cl,rv,rd,lv0,g, + & sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp, + & alpha,entp,coeffs,coeffr,omtrain,cu,Ma) + endif +c + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/convect2.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/convect2.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/convect2.F (revision 1280) @@ -0,0 +1,1395 @@ +! +! $Header$ +! + subroutine convect2(ncum,idcum,len,nd,ndp1,nl,minorig, + & nk1,icb1, + & t1,q1,qs1,u1,v1,gz1,tv1,tp1,tvp1,clw1,h1, + & lv1,cpn1,p1,ph1,ft1,fq1,fu1,fv1, + & tnk1,qnk1,gznk1,plcl1, + & precip1,cbmf1,iflag1, + & delt,cpd,cpv,cl,rv,rd,lv0,g, + & sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp, + & alpha,entp,coeffs,coeffr,omtrain,cu,Ma) +C.............................START PROLOGUE............................ +C +C SCCS IDENTIFICATION: @(#)convect2.f 1.2 05/18/00 +C 22:06:22 /h/cm/library/nogaps4/src/sub/fcst/convect2.f_v +C +C CONFIGURATION IDENTIFICATION: None +C +C MODULE NAME: convect2 +C +C DESCRIPTION: +C +C convect1 The Emanuel Cumulus Convection Scheme - compute tendencies +C +C CONTRACT NUMBER AND TITLE: None +C +C REFERENCES: Programmers K. Emanuel (MIT), Timothy F. Hogan, M. Peng (NRL) +C +C CLASSIFICATION: Unclassified +C +C RESTRICTIONS: None +C +C COMPILER DEPENDENCIES: FORTRAN 77, FORTRAN 90 +C +C COMPILE OPTIONS: Fortran 77: -Zu -Wf"-ei -o aggress" +C Fortran 90: -O vector3,scalar3,task1,aggress,overindex -ei -r 2 +C +C LIBRARIES OF RESIDENCE: /a/ops/lib/libfcst159.a +C +C USAGE: call convect2(ncum,idcum,len,nd,nl,minorig, +C & nk1,icb1, +C & t1,q1,qs1,u1,v1,gz1,tv1,tp1,tvp1,clw1,h1, +C & lv1,cpn1,p1,ph1,ft1,fq1,fu1,fv1, +C & tnk1,qnk1,gznk1,plcl1, +C & precip1,cbmf1,iflag1, +C & delt,cpd,cpv,cl,rv,rd,lv0,g, +C & sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp, +C & alpha,entp,coeffs,coeffr,omtrain,cu) +C +C PARAMETERS: +C Name Type Usage Description +C ---------- ---------- ------- ---------------------------- +C +C ncum Integer Input number of cumulus points +C idcum Integer Input index of cumulus point +C len Integer Input first dimension +C nd Integer Input total vertical dimension +C ndp1 Integer Input nd + 1 +C nl Integer Input vertical dimension for convection +C minorig Integer Input First level where convection is allow to begin +C nk1 Integer Input First level of convection +C ncb1 Integer Input Level of free convection +C t1 Real Input temperature +C q1 Real Input specific hum +C qs1 Real Input sat specific hum +C u1 Real Input u-wind +C v1 Real Input v-wind +C gz1 Real Inout geop +C tv1 Real Input virtual temp +C tp1 Real Input +C clw1 Real Inout cloud liquid water +C h1 Real Inout +C lv1 Real Inout +C cpn1 Real Inout +C p1 Real Input full level pressure +C ph1 Real Input half level pressure +C ft1 Real Output temp tend +C fq1 Real Output spec hum tend +C fu1 Real Output u-wind tend +C fv1 Real Output v-wind tend +C precip1 Real Output prec +C cbmf1 Real In/Out cumulus mass flux +C iflag1 Integer Output iflag on latitude strip +C delt Real Input time step +C cpd Integer Input See description below +C cpv Integer Input See description below +C cl Integer Input See description below +C rv Integer Input See description below +C rd Integer Input See description below +C lv0 Integer Input See description below +C g Integer Input See description below +C sigs Integer Input See description below +C sigd Integer Input See description below +C elcrit Integer Input See description below +C tlcrit Integer Input See description below +C omtsnow Integer Input See description below +C dtmax Integer Input See description below +C damp Integer Input See description below +C alpha Integer Input See description below +C ent Integer Input See description below +C coeffs Integer Input See description below +C coeffr Integer Input See description below +C omtrain Integer Input See description below +C cu Integer Input See description below +C +C COMMON BLOCKS: +C Block Name Type Usage Notes +C -------- -------- ---- ------ ------------------------ +C +C FILES: None +C +C DATA BASES: None +C +C NON-FILE INPUT/OUTPUT: None +C +C ERROR CONDITIONS: None +C +C ADDITIONAL COMMENTS: None +C +C.................MAINTENANCE SECTION................................ +C +C MODULES CALLED: +C Name Description +C zilch Zero out an array +C ------- ---------------------- +C LOCAL VARIABLES AND +C STRUCTURES: +C Name Type Description +C ------- ------ ----------- +C See Comments Below +C +C i Integer loop index +C k Integer loop index +c +C METHOD: +C +C See Emanuel, K. and M. Zivkovic-Rothman, 2000: Development and evaluation of a +C convective scheme for use in climate models. +C +C FILES: None +C +C INCLUDE FILES: None +C +C MAKEFILE: /a/ops/met/nogaps/src/sub/fcst/fcst159lib.mak +C +C..............................END PROLOGUE............................. +c +c + USE dimphy + implicit none +c +cym#include "dimensions.h" +cym#include "dimphy.h" +c + integer kmax2,imax2,kmin2,imin2 + real ftmax2,ftmin2 + integer kmax,imax,kmin,imin + real ftmax,ftmin +c + integer ncum + integer idcum(len) + integer len + integer nd + integer ndp1 + integer nl + integer minorig + integer nk1(len) + integer icb1(len) + real t1(len,nd) + real q1(len,nd) + real qs1(len,nd) + real u1(len,nd) + real v1(len,nd) + real gz1(len,nd) + real tv1(len,nd) + real tp1(len,nd) + real tvp1(len,nd) + real clw1(len,nd) + real h1(len,nd) + real lv1(len,nd) + real cpn1(len,nd) + real p1(len,nd) + real ph1(len,ndp1) + real ft1(len,nd) + real fq1(len,nd) + real fu1(len,nd) + real fv1(len,nd) + real tnk1(len) + real qnk1(len) + real gznk1(len) + real precip1(len) + real cbmf1(len) + real plcl1(len) + integer iflag1(len) + real delt + real cpd + real cpv + real cl + real rv + real rd + real lv0 + real g + real sigs ! SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE + real sigd ! SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT + real elcrit ! ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) + real tlcrit ! TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO- +c CONVERSION THRESHOLD IS ASSUMED TO BE ZERO + real omtsnow ! OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW + real dtmax ! DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION +c A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC. + real damp + real alpha + real entp ! ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT FORMULATION + real coeffs ! COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION OF SNOW + real coeffr ! COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION OF RAIN + real omtrain ! OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN + real cu ! CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM TRANSPORT +c + real Ma(len,nd) +c +C +C *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) *** +C *** TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO- *** +C *** CONVERSION THRESHOLD IS ASSUMED TO BE ZERO *** +C *** (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY *** +C *** BETWEEN 0 C AND TLCRIT) *** +C *** ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT *** +C *** FORMULATION *** +C *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** +C *** SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** +C *** OF CLOUD *** +C *** OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN *** +C *** OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW *** +C *** COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** +C *** OF RAIN *** +C *** COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** +C *** OF SNOW *** +C *** CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM *** +C *** TRANSPORT *** +C *** DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION *** +C *** A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC *** +C *** ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** (THEIR STANDARD VALUES ARE 0.20 AND 0.1, RESPECTIVELY) *** +C *** (DAMP MUST BE LESS THAN 1) *** +c +c Local arrays. +c + real work(ncum) + real t(ncum,klev) + real q(ncum,klev) + real qs(ncum,klev) + real u(ncum,klev) + real v(ncum,klev) + real gz(ncum,klev) + real h(ncum,klev) + real lv(ncum,klev) + real cpn(ncum,klev) + real p(ncum,klev) + real ph(ncum,klev) + real ft(ncum,klev) + real fq(ncum,klev) + real fu(ncum,klev) + real fv(ncum,klev) + real precip(ncum) + real cbmf(ncum) + real plcl(ncum) + real tnk(ncum) + real qnk(ncum) + real gznk(ncum) + real tv(ncum,klev) + real tp(ncum,klev) + real tvp(ncum,klev) + real clw(ncum,klev) +c real det(ncum,klev) + real dph(ncum,klev) +c real wd(ncum) +c real tprime(ncum) +c real qprime(ncum) + real ah0(ncum) + real ep(ncum,klev) + real sigp(ncum,klev) + integer nent(ncum,klev) + real water(ncum,klev) + real evap(ncum,klev) + real mp(ncum,klev) + real m(ncum,klev) + real qti + real wt(ncum,klev) + real hp(ncum,klev) + real lvcp(ncum,klev) + real elij(ncum,klev,klev) + real ment(ncum,klev,klev) + real sij(ncum,klev,klev) + real qent(ncum,klev,klev) + real uent(ncum,klev,klev) + real vent(ncum,klev,klev) + real qp(ncum,klev) + real up(ncum,klev) + real vp(ncum,klev) + real cape(ncum) + real capem(ncum) + real frac(ncum) + real dtpbl(ncum) + real tvpplcl(ncum) + real tvaplcl(ncum) + real dtmin(ncum) + real w3d(ncum,klev) + real am(ncum) + real ents(ncum) + real uav(ncum) + real vav(ncum) +c + integer iflag(ncum) + integer nk(ncum) + integer icb(ncum) + integer inb(ncum) + integer inb1(ncum) + integer jtt(ncum) +c + integer nn,i,k,n,icbmax,nlp,j + integer ij + integer nn2,nn3 + real clmcpv + real clmcpd + real cpdmcp + real cpvmcpd + real eps + real epsi + real epsim1 + real tg,qg,s,alv,tc,ahg,denom,es,rg,ginv,rowl + real delti + real tca,elacrit + real by,defrac +c real byp + real byp(ncum) + logical lcape(ncum) + real dbo + real bf2,anum,dei,altem,cwat,stemp + real alt,qp1,smid,sjmax,sjmin + real delp,delm + real awat,coeff,afac,revap,dhdp,fac,qstm,rat + real qsm,sigt,b6,c6 + real dpinv,cpinv + real fqold,ftold,fuold,fvold + real wdtrain(ncum),xxx + real bsum(ncum,klev) + real asij(ncum) + real smin(ncum) + real scrit(ncum) +c real amp1,ad + real amp1(ncum),ad(ncum) + logical lwork(ncum) + integer num1,num2 +c +c print*,'cpd en entree de convect2 ',cpd + nlp=nl+1 +c + rowl=1000.0 + ginv=1.0/g + delti=1.0/delt +c +c Define some thermodynamic variables. +c + clmcpv=cl-cpv + clmcpd=cl-cpd + cpdmcp=cpd-cpv + cpvmcpd=cpv-cpd + eps=rd/rv + epsi=1.0/eps + epsim1=epsi-1.0 +c +c Compress the fields. +c + do 110 k=1,nl+1 + nn=0 + do 100 i=1,len + if(iflag1(i).eq.0)then + nn=nn+1 + t(nn,k)=t1(i,k) + q(nn,k)=q1(i,k) + qs(nn,k)=qs1(i,k) + u(nn,k)=u1(i,k) + v(nn,k)=v1(i,k) + gz(nn,k)=gz1(i,k) + h(nn,k)=h1(i,k) + lv(nn,k)=lv1(i,k) + cpn(nn,k)=cpn1(i,k) + p(nn,k)=p1(i,k) + ph(nn,k)=ph1(i,k) + tv(nn,k)=tv1(i,k) + tp(nn,k)=tp1(i,k) + tvp(nn,k)=tvp1(i,k) + clw(nn,k)=clw1(i,k) + endif + 100 continue +c print*,'100 ncum,nn',ncum,nn + 110 continue + nn=0 + do 150 i=1,len + if(iflag1(i).eq.0)then + nn=nn+1 + cbmf(nn)=cbmf1(i) + plcl(nn)=plcl1(i) + tnk(nn)=tnk1(i) + qnk(nn)=qnk1(i) + gznk(nn)=gznk1(i) + nk(nn)=nk1(i) + icb(nn)=icb1(i) + iflag(nn)=iflag1(i) + endif + 150 continue +c print*,'150 ncum,nn',ncum,nn +c +c Initialize the tendencies, det, wd, tprime, qprime. +c + do 170 k=1,nl + do 160 i=1,ncum +c det(i,k)=0.0 + ft(i,k)=0.0 + fu(i,k)=0.0 + fv(i,k)=0.0 + fq(i,k)=0.0 + dph(i,k)=ph(i,k)-ph(i,k+1) + ep(i,k)=0.0 + sigp(i,k)=sigs + 160 continue + 170 continue + do 180 i=1,ncum +c wd(i)=0.0 +c tprime(i)=0.0 +c qprime(i)=0.0 + precip(i)=0.0 + ft(i,nl+1)=0.0 + fu(i,nl+1)=0.0 + fv(i,nl+1)=0.0 + fq(i,nl+1)=0.0 + 180 continue +c +c Compute icbmax. +c + icbmax=2 + do 230 i=1,ncum + icbmax=max(icbmax,icb(i)) + 230 continue +c +c +!===================================================================== +! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +!===================================================================== +c +c --- The procedure is to solve the equation. +c cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. +c +c *** Calculate certain parcel quantities, including static energy *** +c +c + do 240 i=1,ncum + ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + & +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i) + 240 continue +c +c +c *** Find lifted parcel quantities above cloud base *** +c +c + do 300 k=minorig+1,nl + do 290 i=1,ncum + if(k.ge.(icb(i)+1))then + tg=t(i,k) + qg=qs(i,k) + alv=lv0-clmcpv*(t(i,k)-273.15) +c +c First iteration. +c + s=cpd+alv*alv*qg/(rv*t(i,k)*t(i,k)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-273.15 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c +c Second iteration. +c + s=cpd+alv*alv*qg/(rv*t(i,k)*t(i,k)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-273.15 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c + alv=lv0-clmcpv*(t(i,k)-273.15) +c print*,'cpd dans convect2 ',cpd +c print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd' +c print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd + tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg) + & /cpd +c if (.not.cpd.gt.1000.) then +c print*,'CPD=',cpd +c stop +c endif + clw(i,k)=qnk(i)-qg + clw(i,k)=max(0.0,clw(i,k)) + rg=qg/(1.-qnk(i)) + tvp(i,k)=tp(i,k)*(1.+rg*epsi) + endif + 290 continue + 300 continue +c +!===================================================================== +! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF +! --- PRECIPITATION FALLING OUTSIDE OF CLOUD +! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I) +!===================================================================== +c + do 320 k=minorig+1,nl + do 310 i=1,ncum + if(k.ge.(nk(i)+1))then + tca=tp(i,k)-273.15 + if(tca.ge.0.0)then + elacrit=elcrit + else + elacrit=elcrit*(1.0-tca/tlcrit) + endif + elacrit=max(elacrit,0.0) + ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8) + ep(i,k)=max(ep(i,k),0.0 ) + ep(i,k)=min(ep(i,k),1.0 ) + sigp(i,k)=sigs + endif + 310 continue + 320 continue +c +!===================================================================== +! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL +! --- VIRTUAL TEMPERATURE +!===================================================================== +c + do 340 k=minorig+1,nl + do 330 i=1,ncum + if(k.ge.(icb(i)+1))then + tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k)) +c print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)' +c print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k) + endif + 330 continue + 340 continue + do 350 i=1,ncum + tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd + 350 continue +c +c +c===================================================================== +c --- NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS +c===================================================================== +c + do 360 i=1,ncum*nlp + nent(i,1)=0 + water(i,1)=0.0 + evap(i,1)=0.0 + mp(i,1)=0.0 + m(i,1)=0.0 + wt(i,1)=omtsnow + hp(i,1)=h(i,1) +c if(.not.cpn(i,1).gt.900.) then +c print*,'i,lv(i,1),cpn(i,1)' +c print*, i,lv(i,1),cpn(i,1) +c k=(i-1)/ncum+1 +c print*,'i,k',mod(i,ncum),k,' cpn',cpn(mod(i,ncum),k) +c stop +c endif + lvcp(i,1)=lv(i,1)/cpn(i,1) + 360 continue +c + do 380 i=1,ncum*nlp*nlp + elij(i,1,1)=0.0 + ment(i,1,1)=0.0 + sij(i,1,1)=0.0 + 380 continue +c + do 400 k=1,nlp + do 390 j=1,nlp + do 385 i=1,ncum + qent(i,k,j)=q(i,j) + uent(i,k,j)=u(i,j) + vent(i,k,j)=v(i,j) + 385 continue + 390 continue + 400 continue +c + do 420 i=1,ncum + qp(i,1)=q(i,1) + up(i,1)=u(i,1) + vp(i,1)=v(i,1) + 420 continue + do 440 k=2,nlp + do 430 i=1,ncum + qp(i,k)=q(i,k-1) + up(i,k)=u(i,k-1) + vp(i,k)=v(i,k-1) + 430 continue + 440 continue +c +c===================================================================== +c --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S +c --- HIGHEST LEVEL OF NEUTRAL BUOYANCY +c --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB) +c===================================================================== +c + do 510 i=1,ncum + cape(i)=0.0 + capem(i)=0.0 + inb(i)=icb(i)+1 + inb1(i)=inb(i) + 510 continue +c +c Originial Code +c +c do 530 k=minorig+1,nl-1 +c do 520 i=1,ncum +c if(k.ge.(icb(i)+1))then +c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c cape(i)=cape(i)+by +c if(by.ge.0.0)inb1(i)=k+1 +c if(cape(i).gt.0.0)then +c inb(i)=k+1 +c capem(i)=cape(i) +c endif +c endif +c520 continue +c530 continue +c do 540 i=1,ncum +c byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl) +c cape(i)=capem(i)+byp +c defrac=capem(i)-cape(i) +c defrac=max(defrac,0.001) +c frac(i)=-cape(i)/defrac +c frac(i)=min(frac(i),1.0) +c frac(i)=max(frac(i),0.0) +c540 continue +c +c K Emanuel fix +c +c call zilch(byp,ncum) +c do 530 k=minorig+1,nl-1 +c do 520 i=1,ncum +c if(k.ge.(icb(i)+1))then +c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c cape(i)=cape(i)+by +c if(by.ge.0.0)inb1(i)=k+1 +c if(cape(i).gt.0.0)then +c inb(i)=k+1 +c capem(i)=cape(i) +c byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c endif +c endif +c520 continue +c530 continue +c do 540 i=1,ncum +c inb(i)=max(inb(i),inb1(i)) +c cape(i)=capem(i)+byp(i) +c defrac=capem(i)-cape(i) +c defrac=max(defrac,0.001) +c frac(i)=-cape(i)/defrac +c frac(i)=min(frac(i),1.0) +c frac(i)=max(frac(i),0.0) +c540 continue +c +c J Teixeira fix +c + call zilch(byp,ncum) + do 515 i=1,ncum + lcape(i)=.true. + 515 continue + do 530 k=minorig+1,nl-1 + do 520 i=1,ncum + if(cape(i).lt.0.0)lcape(i)=.false. + if((k.ge.(icb(i)+1)).and.lcape(i))then + by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) + byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) + cape(i)=cape(i)+by + if(by.ge.0.0)inb1(i)=k+1 + if(cape(i).gt.0.0)then + inb(i)=k+1 + capem(i)=cape(i) + endif + endif + 520 continue + 530 continue + do 540 i=1,ncum + cape(i)=capem(i)+byp(i) + defrac=capem(i)-cape(i) + defrac=max(defrac,0.001) + frac(i)=-cape(i)/defrac + frac(i)=min(frac(i),1.0) + frac(i)=max(frac(i),0.0) + 540 continue +c +c===================================================================== +c --- CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL +c===================================================================== +c + do 600 k=minorig+1,nl + do 590 i=1,ncum + if((k.ge.icb(i)).and.(k.le.inb(i)))then + hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k) + endif + 590 continue + 600 continue +c +c===================================================================== +c --- CALCULATE CLOUD BASE MASS FLUX AND RATES OF MIXING, M(I), +c --- AT EACH MODEL LEVEL +c===================================================================== +c +c tvpplcl = parcel temperature lifted adiabatically from level +c icb-1 to the LCL. +c tvaplcl = virtual temperature at the LCL. +c + do 610 i=1,ncum + dtpbl(i)=0.0 + tvpplcl(i)=tvp(i,icb(i)-1) + & -rd*tvp(i,icb(i)-1)*(p(i,icb(i)-1)-plcl(i)) + & /(cpn(i,icb(i)-1)*p(i,icb(i)-1)) + tvaplcl(i)=tv(i,icb(i)) + & +(tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i,icb(i))) + & /(p(i,icb(i))-p(i,icb(i)+1)) + 610 continue +c +c------------------------------------------------------------------- +c --- Interpolate difference between lifted parcel and +c --- environmental temperatures to lifted condensation level +c------------------------------------------------------------------- +c +c dtpbl = average of tvp-tv in the PBL (k=nk to icb-1). +c + do 630 k=minorig,icbmax + do 620 i=1,ncum + if((k.ge.nk(i)).and.(k.le.(icb(i)-1)))then + dtpbl(i)=dtpbl(i)+(tvp(i,k)-tv(i,k))*dph(i,k) + endif + 620 continue + 630 continue + do 640 i=1,ncum + dtpbl(i)=dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i))) + dtmin(i)=tvpplcl(i)-tvaplcl(i)+dtmax+dtpbl(i) + 640 continue +c +c------------------------------------------------------------------- +c --- Adjust cloud base mass flux +c------------------------------------------------------------------- +c + do 650 i=1,ncum + work(i)=cbmf(i) + cbmf(i)=max(0.0,(1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i)) + if((work(i).eq.0.0).and.(cbmf(i).eq.0.0))then + iflag(i)=3 + endif + 650 continue +c +c------------------------------------------------------------------- +c --- Calculate rates of mixing, m(i) +c------------------------------------------------------------------- +c + call zilch(work,ncum) +c + do 670 j=minorig+1,nl + do 660 i=1,ncum + if((j.ge.(icb(i)+1)).and.(j.le.inb(i)))then + k=min(j,inb1(i)) + dbo=abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1)) + & +entp*0.04*(ph(i,k)-ph(i,k+1)) + work(i)=work(i)+dbo + m(i,j)=cbmf(i)*dbo + endif + 660 continue + 670 continue + do 690 k=minorig+1,nl + do 680 i=1,ncum + if((k.ge.(icb(i)+1)).and.(k.le.inb(i)))then + m(i,k)=m(i,k)/work(i) + endif + 680 continue + 690 continue +c +c +c===================================================================== +c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING +c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING +c --- FRACTION (sij) +c===================================================================== +c +c + do 750 i=minorig+1,nl + do 710 j=minorig+1,nl + do 700 ij=1,ncum + if((i.ge.(icb(ij)+1)).and.(j.ge.icb(ij)) + & .and.(i.le.inb(ij)).and.(j.le.inb(ij)))then + qti=qnk(ij)-ep(ij,i)*clw(ij,i) + bf2=1.+lv(ij,j)*lv(ij,j)*qs(ij,j) + & /(rv*t(ij,j)*t(ij,j)*cpd) + anum=h(ij,j)-hp(ij,i)+(cpv-cpd)*t(ij,j)*(qti-q(ij,j)) + denom=h(ij,i)-hp(ij,i)+(cpd-cpv)*(q(ij,i)-qti)*t(ij,j) + dei=denom + if(abs(dei).lt.0.01)dei=0.01 + sij(ij,i,j)=anum/dei + sij(ij,i,i)=1.0 + altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j) + altem=altem/bf2 + cwat=clw(ij,j)*(1.-ep(ij,j)) + stemp=sij(ij,i,j) + if((stemp.lt.0.0.or.stemp.gt.1.0.or. + 1 altem.gt.cwat).and.j.gt.i)then + anum=anum-lv(ij,j)*(qti-qs(ij,j)-cwat*bf2) + denom=denom+lv(ij,j)*(q(ij,i)-qti) + if(abs(denom).lt.0.01)denom=0.01 + sij(ij,i,j)=anum/denom + altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j) + altem=altem-(bf2-1.)*cwat + endif + if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then + qent(ij,i,j)=sij(ij,i,j)*q(ij,i) + & +(1.-sij(ij,i,j))*qti + uent(ij,i,j)=sij(ij,i,j)*u(ij,i) + & +(1.-sij(ij,i,j))*u(ij,nk(ij)) + vent(ij,i,j)=sij(ij,i,j)*v(ij,i) + & +(1.-sij(ij,i,j))*v(ij,nk(ij)) + elij(ij,i,j)=altem + elij(ij,i,j)=max(0.0,elij(ij,i,j)) + ment(ij,i,j)=m(ij,i)/(1.-sij(ij,i,j)) + nent(ij,i)=nent(ij,i)+1 + endif + sij(ij,i,j)=max(0.0,sij(ij,i,j)) + sij(ij,i,j)=min(1.0,sij(ij,i,j)) + endif + 700 continue + 710 continue +c +c *** If no air can entrain at level i assume that updraft detrains *** +c *** at that level and calculate detrained air flux and properties *** +c + do 740 ij=1,ncum + if((i.ge.(icb(ij)+1)).and.(i.le.inb(ij)) + & .and.(nent(ij,i).eq.0))then + ment(ij,i,i)=m(ij,i) + qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i) + uent(ij,i,i)=u(ij,nk(ij)) + vent(ij,i,i)=v(ij,nk(ij)) + elij(ij,i,i)=clw(ij,i) + sij(ij,i,i)=1.0 + endif + 740 continue + 750 continue +c + do 770 i=1,ncum + sij(i,inb(i),inb(i))=1.0 + 770 continue +c +c===================================================================== +c --- NORMALIZE ENTRAINED AIR MASS FLUXES +c --- TO REPRESENT EQUAL PROBABILITIES OF MIXING +c===================================================================== +c +c + call zilch(bsum,ncum*nlp) + do 780 ij=1,ncum + lwork(ij)=.false. + 780 continue + do 789 i=minorig+1,nl +c + num1=0 + do 779 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))num1=num1+1 + 779 continue + if(num1.le.0)go to 789 +c + do 781 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))then + lwork(ij)=(nent(ij,i).ne.0) + qp1=q(ij,nk(ij))-ep(ij,i)*clw(ij,i) + anum=h(ij,i)-hp(ij,i)-lv(ij,i)*(qp1-qs(ij,i)) + denom=h(ij,i)-hp(ij,i)+lv(ij,i)*(q(ij,i)-qp1) + if(abs(denom).lt.0.01)denom=0.01 + scrit(ij)=anum/denom + alt=qp1-qs(ij,i)+scrit(ij)*(q(ij,i)-qp1) + if(scrit(ij).lt.0.0.or.alt.lt.0.0)scrit(ij)=1.0 + asij(ij)=0.0 + smin(ij)=1.0 + endif + 781 continue + do 783 j=minorig,nl +c + num2=0 + do 778 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(j.ge.icb(ij)).and.(j.le.inb(ij)) + & .and.lwork(ij))num2=num2+1 + 778 continue + if(num2.le.0)go to 783 +c + do 782 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(j.ge.icb(ij)).and.(j.le.inb(ij)).and.lwork(ij))then + if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then + if(j.gt.i)then + smid=min(sij(ij,i,j),scrit(ij)) + sjmax=smid + sjmin=smid + if(smid.lt.smin(ij) + & .and.sij(ij,i,j+1).lt.smid)then + smin(ij)=smid + sjmax=min(sij(ij,i,j+1),sij(ij,i,j),scrit(ij)) + sjmin=max(sij(ij,i,j-1),sij(ij,i,j)) + sjmin=min(sjmin,scrit(ij)) + endif + else + sjmax=max(sij(ij,i,j+1),scrit(ij)) + smid=max(sij(ij,i,j),scrit(ij)) + sjmin=0.0 + if(j.gt.1)sjmin=sij(ij,i,j-1) + sjmin=max(sjmin,scrit(ij)) + endif + delp=abs(sjmax-smid) + delm=abs(sjmin-smid) + asij(ij)=asij(ij)+(delp+delm) + & *(ph(ij,j)-ph(ij,j+1)) + ment(ij,i,j)=ment(ij,i,j)*(delp+delm) + & *(ph(ij,j)-ph(ij,j+1)) + endif + endif + 782 continue + 783 continue + do 784 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)).and.lwork(ij))then + asij(ij)=max(1.0e-21,asij(ij)) + asij(ij)=1.0/asij(ij) + bsum(ij,i)=0.0 + endif + 784 continue + do 786 j=minorig,nl+1 + do 785 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(j.ge.icb(ij)).and.(j.le.inb(ij)) + & .and.lwork(ij))then + ment(ij,i,j)=ment(ij,i,j)*asij(ij) + bsum(ij,i)=bsum(ij,i)+ment(ij,i,j) + endif + 785 continue + 786 continue + do 787 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(bsum(ij,i).lt.1.0e-18).and.lwork(ij))then + nent(ij,i)=0 + ment(ij,i,i)=m(ij,i) + qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i) + uent(ij,i,i)=u(ij,nk(ij)) + vent(ij,i,i)=v(ij,nk(ij)) + elij(ij,i,i)=clw(ij,i) + sij(ij,i,i)=1.0 + endif + 787 continue + 789 continue +c +c===================================================================== +c --- PRECIPITATING DOWNDRAFT CALCULATION +c===================================================================== +c +c *** Check whether ep(inb)=0, if so, skip precipitating *** +c *** downdraft calculation *** +c +c +c *** Integrate liquid water equation to find condensed water *** +c *** and condensed water flux *** +c +c + do 890 i=1,ncum + jtt(i)=2 + if(ep(i,inb(i)).le.0.0001)iflag(i)=2 + if(iflag(i).eq.0)then + lwork(i)=.true. + else + lwork(i)=.false. + endif + 890 continue +c +c *** Begin downdraft loop *** +c +c + call zilch(wdtrain,ncum) + do 899 i=nl+1,1,-1 +c + num1=0 + do 879 ij=1,ncum + if((i.le.inb(ij)).and.lwork(ij))num1=num1+1 + 879 continue + if(num1.le.0)go to 899 +c +c +c *** Calculate detrained precipitation *** +c + do 891 ij=1,ncum + if((i.le.inb(ij)).and.(lwork(ij)))then + wdtrain(ij)=g*ep(ij,i)*m(ij,i)*clw(ij,i) + endif + 891 continue +c + if(i.gt.1)then + do 893 j=1,i-1 + do 892 ij=1,ncum + if((i.le.inb(ij)).and.(lwork(ij)))then + awat=elij(ij,j,i)-(1.-ep(ij,i))*clw(ij,i) + awat=max(0.0,awat) + wdtrain(ij)=wdtrain(ij)+g*awat*ment(ij,j,i) + endif + 892 continue + 893 continue + endif +c +c *** Find rain water and evaporation using provisional *** +c *** estimates of qp(i)and qp(i-1) *** +c +c +c *** Value of terminal velocity and coeffecient of evaporation for snow *** +c + do 894 ij=1,ncum + if((i.le.inb(ij)).and.(lwork(ij)))then + coeff=coeffs + wt(ij,i)=omtsnow +c +c *** Value of terminal velocity and coeffecient of evaporation for rain *** +c + if(t(ij,i).gt.273.0)then + coeff=coeffr + wt(ij,i)=omtrain + endif + qsm=0.5*(q(ij,i)+qp(ij,i+1)) + afac=coeff*ph(ij,i)*(qs(ij,i)-qsm) + & /(1.0e4+2.0e3*ph(ij,i)*qs(ij,i)) + afac=max(afac,0.0) + sigt=sigp(ij,i) + sigt=max(0.0,sigt) + sigt=min(1.0,sigt) + b6=100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij,i) + c6=(water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij,i) + revap=0.5*(-b6+sqrt(b6*b6+4.*c6)) + evap(ij,i)=sigt*afac*revap + water(ij,i)=revap*revap +c +c *** Calculate precipitating downdraft mass flux under *** +c *** hydrostatic approximation *** +c + if(i.gt.1)then + dhdp=(h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i)) + dhdp=max(dhdp,10.0) + mp(ij,i)=100.*ginv*lv(ij,i)*sigd*evap(ij,i)/dhdp + mp(ij,i)=max(mp(ij,i),0.0) +c +c *** Add small amount of inertia to downdraft *** +c + fac=20.0/(ph(ij,i-1)-ph(ij,i)) + mp(ij,i)=(fac*mp(ij,i+1)+mp(ij,i))/(1.+fac) +c +c *** Force mp to decrease linearly to zero *** +c *** between about 950 mb and the surface *** +c + if(p(ij,i).gt.(0.949*p(ij,1)))then + jtt(ij)=max(jtt(ij),i) + mp(ij,i)=mp(ij,jtt(ij))*(p(ij,1)-p(ij,i)) + & /(p(ij,1)-p(ij,jtt(ij))) + endif + endif +c +c *** Find mixing ratio of precipitating downdraft *** +c + if(i.ne.inb(ij))then + if(i.eq.1)then + qstm=qs(ij,1) + else + qstm=qs(ij,i-1) + endif + if(mp(ij,i).gt.mp(ij,i+1))then + rat=mp(ij,i+1)/mp(ij,i) + qp(ij,i)=qp(ij,i+1)*rat+q(ij,i)*(1.0-rat)+100.*ginv* + & sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i)) + up(ij,i)=up(ij,i+1)*rat+u(ij,i)*(1.-rat) + vp(ij,i)=vp(ij,i+1)*rat+v(ij,i)*(1.-rat) + else + if(mp(ij,i+1).gt.0.0)then + qp(ij,i)=(gz(ij,i+1)-gz(ij,i) + & +qp(ij,i+1)*(lv(ij,i+1)+t(ij,i+1) + & *(cl-cpd))+cpd*(t(ij,i+1)-t(ij,i))) + & /(lv(ij,i)+t(ij,i)*(cl-cpd)) + up(ij,i)=up(ij,i+1) + vp(ij,i)=vp(ij,i+1) + endif + endif + qp(ij,i)=min(qp(ij,i),qstm) + qp(ij,i)=max(qp(ij,i),0.0) + endif + endif + 894 continue + 899 continue +c +c *** Calculate surface precipitation in mm/day *** +c + do 1190 i=1,ncum + if(iflag(i).le.1)then +cc precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000. +cc & /(rowl*g) +cc precip(i)=precip(i)*delt/86400. + precip(i) = wt(i,1)*sigd*water(i,1)*86400/g + endif + 1190 continue +c +c +c *** Calculate downdraft velocity scale and surface temperature and *** +c *** water vapor fluctuations *** +c +c wd=beta*abs(mp(icb))*0.01*rd*t(icb)/(sigd*p(icb)) +c qprime=0.5*(qp(1)-q(1)) +c tprime=lv0*qprime/cpd +c +c *** Calculate tendencies of lowest level potential temperature *** +c *** and mixing ratio *** +c + do 1200 i=1,ncum + work(i)=0.01/(ph(i,1)-ph(i,2)) + am(i)=0.0 + 1200 continue + do 1220 k=2,nl + do 1210 i=1,ncum + if((nk(i).eq.1).and.(k.le.inb(i)).and.(nk(i).eq.1))then + am(i)=am(i)+m(i,k) + endif + 1210 continue + 1220 continue + do 1240 i=1,ncum + if((g*work(i)*am(i)).ge.delti)iflag(i)=1 + ft(i,1)=ft(i,1)+g*work(i)*am(i)*(t(i,2)-t(i,1) + & +(gz(i,2)-gz(i,1))/cpn(i,1)) + ft(i,1)=ft(i,1)-lvcp(i,1)*sigd*evap(i,1) + ft(i,1)=ft(i,1)+sigd*wt(i,2)*(cl-cpd)*water(i,2)*(t(i,2) + & -t(i,1))*work(i)/cpn(i,1) + fq(i,1)=fq(i,1)+g*mp(i,2)*(qp(i,2)-q(i,1))* + & work(i)+sigd*evap(i,1) + fq(i,1)=fq(i,1)+g*am(i)*(q(i,2)-q(i,1))*work(i) + fu(i,1)=fu(i,1)+g*work(i)*(mp(i,2)*(up(i,2)-u(i,1)) + & +am(i)*(u(i,2)-u(i,1))) + fv(i,1)=fv(i,1)+g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1)) + & +am(i)*(v(i,2)-v(i,1))) + 1240 continue + do 1260 j=2,nl + do 1250 i=1,ncum + if(j.le.inb(i))then + fq(i,1)=fq(i,1) + & +g*work(i)*ment(i,j,1)*(qent(i,j,1)-q(i,1)) + fu(i,1)=fu(i,1) + & +g*work(i)*ment(i,j,1)*(uent(i,j,1)-u(i,1)) + fv(i,1)=fv(i,1) + & +g*work(i)*ment(i,j,1)*(vent(i,j,1)-v(i,1)) + endif + 1250 continue + 1260 continue +c +c *** Calculate tendencies of potential temperature and mixing ratio *** +c *** at levels above the lowest level *** +c +c *** First find the net saturated updraft and downdraft mass fluxes *** +c *** through each level *** +c + do 1500 i=2,nl+1 +c + num1=0 + do 1265 ij=1,ncum + if(i.le.inb(ij))num1=num1+1 + 1265 continue + if(num1.le.0)go to 1500 +c + call zilch(amp1,ncum) + call zilch(ad,ncum) +c + do 1280 k=i+1,nl+1 + do 1270 ij=1,ncum + if((i.ge.nk(ij)).and.(i.le.inb(ij)) + & .and.(k.le.(inb(ij)+1)))then + amp1(ij)=amp1(ij)+m(ij,k) + endif + 1270 continue + 1280 continue +c + do 1310 k=1,i + do 1300 j=i+1,nl+1 + do 1290 ij=1,ncum + if((j.le.(inb(ij)+1)).and.(i.le.inb(ij)))then + amp1(ij)=amp1(ij)+ment(ij,k,j) + endif + 1290 continue + 1300 continue + 1310 continue + do 1340 k=1,i-1 + do 1330 j=i,nl+1 + do 1320 ij=1,ncum + if((i.le.inb(ij)).and.(j.le.inb(ij)))then + ad(ij)=ad(ij)+ment(ij,j,k) + endif + 1320 continue + 1330 continue + 1340 continue +c + do 1350 ij=1,ncum + if(i.le.inb(ij))then + dpinv=0.01/(ph(ij,i)-ph(ij,i+1)) + cpinv=1.0/cpn(ij,i) +c + ft(ij,i)=ft(ij,i) + & +g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij,i) + & +(gz(ij,i+1)-gz(ij,i))*cpinv) + & -ad(ij)*(t(ij,i)-t(ij,i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv)) + & -sigd*lvcp(ij,i)*evap(ij,i) + ft(ij,i)=ft(ij,i)+g*dpinv*ment(ij,i,i)*(hp(ij,i)-h(ij,i)+ + & t(ij,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv + ft(ij,i)=ft(ij,i)+sigd*wt(ij,i+1)*(cl-cpd)*water(ij,i+1)* + & (t(ij,i+1)-t(ij,i))*dpinv*cpinv + fq(ij,i)=fq(ij,i)+g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij,i))- + & ad(ij)*(q(ij,i)-q(ij,i-1))) + fu(ij,i)=fu(ij,i)+g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij,i))- + & ad(ij)*(u(ij,i)-u(ij,i-1))) + fv(ij,i)=fv(ij,i)+g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij,i))- + & ad(ij)*(v(ij,i)-v(ij,i-1))) + endif + 1350 continue + do 1370 k=1,i-1 + do 1360 ij=1,ncum + if(i.le.inb(ij))then + awat=elij(ij,k,i)-(1.-ep(ij,i))*clw(ij,i) + awat=max(awat,0.0) + fq(ij,i)=fq(ij,i) + & +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-awat-q(ij,i)) + fu(ij,i)=fu(ij,i) + & +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i)) + fv(ij,i)=fv(ij,i) + & +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i)) + endif + 1360 continue + 1370 continue + do 1390 k=i,nl+1 + do 1380 ij=1,ncum + if((i.le.inb(ij)).and.(k.le.inb(ij)))then + fq(ij,i)=fq(ij,i) + & +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-q(ij,i)) + fu(ij,i)=fu(ij,i) + & +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i)) + fv(ij,i)=fv(ij,i) + & +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i)) + endif + 1380 continue + 1390 continue + do 1400 ij=1,ncum + if(i.le.inb(ij))then + fq(ij,i)=fq(ij,i) + & +sigd*evap(ij,i)+g*(mp(ij,i+1)* + & (qp(ij,i+1)-q(ij,i)) + & -mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv + fu(ij,i)=fu(ij,i) + & +g*(mp(ij,i+1)*(up(ij,i+1)-u(ij,i))-mp(ij,i)* + & (up(ij,i)-u(ij,i-1)))*dpinv + fv(ij,i)=fv(ij,i) + & +g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij,i))-mp(ij,i)* + & (vp(ij,i)-v(ij,i-1)))*dpinv + endif + 1400 continue + 1500 continue +c +c *** Adjust tendencies at top of convection layer to reflect *** +c *** actual position of the level zero cape *** +c + do 503 ij=1,ncum + fqold=fq(ij,inb(ij)) + fq(ij,inb(ij))=fq(ij,inb(ij))*(1.-frac(ij)) + fq(ij,inb(ij)-1)=fq(ij,inb(ij)-1) + & +frac(ij)*fqold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*lv(ij,inb(ij)) + & /lv(ij,inb(ij)-1) + ftold=ft(ij,inb(ij)) + ft(ij,inb(ij))=ft(ij,inb(ij))*(1.-frac(ij)) + ft(ij,inb(ij)-1)=ft(ij,inb(ij)-1) + & +frac(ij)*ftold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*cpn(ij,inb(ij)) + & /cpn(ij,inb(ij)-1) + fuold=fu(ij,inb(ij)) + fu(ij,inb(ij))=fu(ij,inb(ij))*(1.-frac(ij)) + fu(ij,inb(ij)-1)=fu(ij,inb(ij)-1) + & +frac(ij)*fuold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij)))) + fvold=fv(ij,inb(ij)) + fv(ij,inb(ij))=fv(ij,inb(ij))*(1.-frac(ij)) + fv(ij,inb(ij)-1)=fv(ij,inb(ij)-1) + & +frac(ij)*fvold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij)))) + 503 continue +c +c *** Very slightly adjust tendencies to force exact *** +c *** enthalpy, momentum and tracer conservation *** +c + do 682 ij=1,ncum + ents(ij)=0.0 + uav(ij)=0.0 + vav(ij)=0.0 + do 681 i=1,inb(ij) + ents(ij)=ents(ij) + & +(cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)-ph(ij,i+1)) + uav(ij)=uav(ij)+fu(ij,i)*(ph(ij,i)-ph(ij,i+1)) + vav(ij)=vav(ij)+fv(ij,i)*(ph(ij,i)-ph(ij,i+1)) + 681 continue + 682 continue + do 683 ij=1,ncum + ents(ij)=ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1)) + uav(ij)=uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1)) + vav(ij)=vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1)) + 683 continue + do 642 ij=1,ncum + do 641 i=1,inb(ij) + ft(ij,i)=ft(ij,i)-ents(ij)/cpn(ij,i) + fu(ij,i)=(1.-cu)*(fu(ij,i)-uav(ij)) + fv(ij,i)=(1.-cu)*(fv(ij,i)-vav(ij)) + 641 continue + 642 continue +c + do 1810 k=1,nl+1 + do 1800 i=1,ncum + if((q(i,k)+delt*fq(i,k)).lt.0.0)iflag(i)=10 + 1800 continue + 1810 continue +c +c + do 1900 i=1,ncum + if(iflag(i).gt.2)then + precip(i)=0.0 + cbmf(i)=0.0 + endif + 1900 continue + do 1920 k=1,nl + do 1910 i=1,ncum + if(iflag(i).gt.2)then + ft(i,k)=0.0 + fq(i,k)=0.0 + fu(i,k)=0.0 + fv(i,k)=0.0 + endif + 1910 continue + 1920 continue + do 2000 i=1,ncum + precip1(idcum(i))=precip(i) + cbmf1(idcum(i))=cbmf(i) + iflag1(idcum(i))=iflag(i) + 2000 continue + do 2020 k=1,nl + do 2010 i=1,ncum + ft1(idcum(i),k)=ft(i,k) + fq1(idcum(i),k)=fq(i,k) + fu1(idcum(i),k)=fu(i,k) + fv1(idcum(i),k)=fv(i,k) + 2010 continue + 2020 continue +c + DO k=1,nd + DO i=1,len + Ma(i,k) = 0. + ENDDO + ENDDO + DO k=nl,1,-1 + DO i=1,ncum + Ma(i,k) = Ma(i,k+1)+m(i,k) + ENDDO + ENDDO +c + return + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/convect3.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/convect3.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/convect3.F (revision 1280) @@ -0,0 +1,1410 @@ +! +! $Header$ +! + SUBROUTINE CONVECT3 + * (DTIME,EPMAX,ok_adj, + * T1, R1, RS, U, V, TRA, P, PH, + * ND, NDP1, NL, NTRA, DELT, IFLAG, + * FT, FR, FU, FV, FTRA, PRECIP, + * icb,inb, upwd,dnwd,dnwd0,SIG, W0,Mike,Mke, + * Ma,MENTS,QENTS,TPS,TLS,SIGIJ,CAPE,TVP,PBASE,BUOYBASE, +cccc * DTVPDT1,DTVPDQ1,DPLCLDT,DPLCLDR) + * DTVPDT1,DTVPDQ1,DPLCLDT,DPLCLDR, ! sbl + * FT2,FR2,FU2,FV2,WD,QCOND,QCONDC) ! sbl +C +C *** THE PARAMETER NA SHOULD IN GENERAL EQUAL ND *** +C +c################################################################# +cFleur Introduction des traceurs dans convect3 le 6 juin 200 +c################################################################# + USE dimphy + USE infotrac, ONLY : NBTR + +#include "dimensions.h" + INTEGER NA + PARAMETER (NA=60) + + REAL DELTAC ! cld + PARAMETER (DELTAC=0.01) ! cld + + INTEGER NENT(NA) + INTEGER ND, NDP1, NL, NTRA, IFLAG, icb, inb + REAL DTIME, EPMAX, DELT, PRECIP, CAPE + REAL DPLCLDT, DPLCLDR + REAL T1(ND),R1(ND),RS(ND),U(ND),V(ND),TRA(ND,NTRA) + REAL P(ND),PH(NDP1) + REAL FT(ND),FR(ND),FU(ND),FV(ND),FTRA(ND,NTRA) + REAL SIG(ND),W0(ND) + REAL UENT(NA,NA),VENT(NA,NA),TRAENT(NA,NA,NBTR),TRATM(NA) + REAL UP(NA),VP(NA),TRAP(NA,NBTR) + REAL M(NA),MP(NA),MENT(NA,NA),QENT(NA,NA),ELIJ(NA,NA) + REAL SIJ(NA,NA),TVP(NA),TV(NA),WATER(NA) + REAL RP(NA),EP(NA),TH(NA),WT(NA),EVAP(NA),CLW(NA) + REAL SIGP(NA),B(NA),TP(NA),CPN(NA) + REAL LV(NA),LVCP(NA),H(NA),HP(NA),GZ(NA) + REAL T(NA),RR(NA) +C + REAL FT2(ND),FR2(ND),FU2(ND),FV2(ND) ! added sbl + REAL U1(ND),V1(ND) ! added sbl +C + REAL BUOY(NA) ! Lifted parcel buoyancy + REAL DTVPDT1(ND),DTVPDQ1(ND) ! Derivatives of parcel virtual +C temperature wrt T1 and Q1 + REAL CLW_NEW(NA),QI(NA) +C + REAL WD, BETAD ! for gust factor (sb) + REAL QCONDC(ND) ! interface cld param (sb) + REAL QCOND(ND),NQCOND(NA),WA(NA),MAA(NA),SIGA(NA),AXC(NA) ! cld +C + LOGICAL ICE_CONV,ok_adj + PARAMETER (ICE_CONV=.TRUE.) + +cccccccccccccccccccccccccccccccccccccccccccccc +c declaration des variables a sortir +ccccccccccccccccccccccccccccccccccccccccccccc + real Mke(nd) + real Mike(nd) + real Ma(nd) + real TPS(ND) !temperature dans les ascendances non diluees + real TLS(ND) !temperature potentielle + real MENTS(nd,nd) + real QENTS(nd,nd) + REAL SIGIJ(KLEV,KLEV) + REAL PBASE ! pressure at the cloud base level + REAL BUOYBASE ! buoyancy at the cloud base level +cccccccccccccccccccccccccccccccccccccccccccccc + + + +c + real dnwd0(nd) ! precipitation driven unsaturated downdraft flux + real dnwd(nd), dn1 ! in-cloud saturated downdraft mass flux + real upwd(nd), up1 ! in-cloud saturated updraft mass flux +C +C *** ASSIGN VALUES OF THERMODYNAMIC CONSTANTS *** +C *** THESE SHOULD BE CONSISTENT WITH *** +C *** THOSE USED IN CALLING PROGRAM *** +C *** NOTE: THESE ARE ALSO SPECIFIED IN SUBROUTINE TLIFT *** +C +c sb CPD=1005.7 +c sb CPV=1870.0 +c sb CL=4190.0 +c sb CPVMCL=CL-CPV +c sb RV=461.5 +c sb RD=287.04 +c sb EPS=RD/RV +c sb ALV0=2.501E6 +ccccccccccccccccccccccc +c constantes coherentes avec le modele du Centre Europeen +c sb RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644 +c sb RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153 +c sb CPD = 3.5 * RD +c sb CPV = 4.0 * RV +c sb CL = 4218.0 +c sb CPVMCL=CL-CPV +c sb EPS=RD/RV +c sb ALV0=2.5008E+06 +cccccccccccccccccccccc +c on utilise les constantes thermo du Centre Europeen: (SB) +c +#include "YOMCST.h" +c + CPD = RCPD + CPV = RCPV + CL = RCW + CPVMCL = CL-CPV + EPS = RD/RV + ALV0 = RLVTT +c + NK = 1 ! origin level of the lifted parcel +c +cccccccccccccccccccccc +C +C *** INITIALIZE OUTPUT ARRAYS AND PARAMETERS *** +C + DO 5 I=1,ND + FT(I)=0.0 + FR(I)=0.0 + FU(I)=0.0 + FV(I)=0.0 + + FT2(I)=0.0 + FR2(I)=0.0 + FU2(I)=0.0 + FV2(I)=0.0 + + DO 4 J=1,NTRA + FTRA(I,J)=0.0 + 4 CONTINUE + + QCONDC(I)=0.0 ! cld + QCOND(I)=0.0 ! cld + NQCOND(I)=0.0 ! cld + + T(I)=T1(I) + RR(I)=R1(I) + U1(I)=U(I) ! added sbl + V1(I)=V(I) ! added sbl + 5 CONTINUE + DO 7 I=1,NL + RDCP=(RD*(1.-RR(I))+RR(I)*RV)/ (CPD*(1.-RR(I))+RR(I)*CPV) + TH(I)=T(I)*(1000.0/P(I))**RDCP + 7 CONTINUE +C +************************************************************* +** CALCUL DES TEMPERATURES POTENTIELLES A SORTIR +************************************************************* + do i=1,ND + RDCP=(RD*(1.-RR(I))+RR(I)*RV)/ (CPD*(1.-RR(I))+RR(I)*CPV) + + TLS(i)=T(I)*(1000.0/P(I))**RDCP + enddo + + + + +************************************************************ + + + PRECIP=0.0 + WD=0.0 ! sb + IFLAG=1 +C +C *** SPECIFY PARAMETERS *** +C *** PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE *** +C *** PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO *** +C *** PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. *** +C *** EFFICIENCY IS ASSUMED TO BE UNITY *** +C *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** +C *** SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** +C *** OF CLOUD *** +C *** ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) *** +C *** (BETA MUST BE LESS THAN OR EQUAL TO 1) *** +C *** DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** IT MUST BE LESS THAN 0 *** +C + PBCRIT=150.0 + PTCRIT=500.0 + SIGD=0.01 + SPFAC=0.15 +c sb: +c EPMAX=0.993 ! precip efficiency less than unity +c EPMAX=1. ! precip efficiency less than unity +C +Cjyg +CCC BETA=0.96 +C Beta is now expressed as a function of the characteristic time +C of the convective process. +CCC Old value : TAU = 15000. !(for dtime = 600.s) +CCC Other value (inducing little change) :TAU = 8000. + TAU = 8000. + BETA = 1.-DTIME/TAU +Cjyg +CCC ALPHA=1.0 + ALPHA=1.5E-3*DTIME/TAU +C Increase alpha in order to compensate W decrease + ALPHA = ALPHA*1.5 +C +Cjyg (voir CONVECT 3) +CCC DTCRIT=-0.2 + DTCRIT=-2. +Cgf&jyg +CCC DT pour l'overshoot. + DTOVSH = -0.2 + +C +C *** INCREMENT THE COUNTER *** +C + SIG(ND)=SIG(ND)+1.0 + SIG(ND)=AMIN1(SIG(ND),12.1) +C +C *** IF NOPT IS AN INTEGER OTHER THAN 0, CONVECT *** +C *** RETURNS ARRAYS T AND R THAT MAY HAVE BEEN *** +C *** ALTERED BY DRY ADIABATIC ADJUSTMENT; OTHERWISE *** +C *** THE RETURNED ARRAYS ARE UNALTERED. *** +C + NOPT=0 +c! NOPT=1 ! sbl +C +C *** PERFORM DRY ADIABATIC ADJUSTMENT *** +C +C *** DO NOT BYPASS THIS EVEN IF THE CALLING PROGRAM HAS A *** +C *** BOUNDARY LAYER SCHEME !!! *** +C + IF (ok_adj) THEN ! added sbl + + DO 30 I=NL-1,1,-1 + JN=0 + DO 10 J=I+1,NL + 10 IF(TH(J).LT.TH(I))JN=J + IF(JN.EQ.0)GOTO 30 + AHM=0.0 + RM=0.0 + UM=0.0 + VM=0.0 + DO K=1,NTRA + TRATM(K)=0.0 + END DO + DO 15 J=I,JN + AHM=AHM+(CPD*(1.-RR(J))+RR(J)*CPV)*T(J)*(PH(J)-PH(J+1)) + RM=RM+RR(J)*(PH(J)-PH(J+1)) + UM=UM+U(J)*(PH(J)-PH(J+1)) + VM=VM+V(J)*(PH(J)-PH(J+1)) + DO K=1,NTRA + TRATM(K)=TRATM(K)+TRA(J,K)*(PH(J)-PH(J+1)) + END DO + 15 CONTINUE + DPHINV=1./(PH(I)-PH(JN+1)) + RM=RM*DPHINV + UM=UM*DPHINV + VM=VM*DPHINV + DO K=1,NTRA + TRATM(K)=TRATM(K)*DPHINV + END DO + A2=0.0 + DO 20 J=I,JN + RR(J)=RM + U(J)=UM + V(J)=VM + DO K=1,NTRA + TRA(J,K)=TRATM(K) + END DO + RDCP=(RD*(1.-RR(J))+RR(J)*RV)/ (CPD*(1.-RR(J))+RR(J)*CPV) + X=(0.001*P(J))**RDCP + T(J)=X + A2=A2+(CPD*(1.-RR(J))+RR(J)*CPV)*X*(PH(J)-PH(J+1)) + 20 CONTINUE + DO 25 J=I,JN + TH(J)=AHM/A2 + T(J)=T(J)*TH(J) + 25 CONTINUE + 30 CONTINUE + + ENDIF ! added sbl +C +C *** RESET INPUT ARRAYS IF ok_adj 0 *** +C + IF (ok_adj)THEN + DO 35 I=1,ND + + FT2(I)=(T(I)-T1(I))/DELT ! sbl + FR2(I)=(RR(I)-R1(I))/DELT ! sbl + FU2(I)=(U(I)-U1(I))/DELT ! sbl + FV2(I)=(V(I)-V1(I))/DELT ! sbl + +c! T1(I)=T(I) ! commente sbl +c! R1(I)=RR(I) ! commente sbl + 35 CONTINUE + END IF +C +C *** CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY AND STATIC ENERGY +C + GZ(1)=0.0 + CPN(1)=CPD*(1.-RR(1))+RR(1)*CPV + H(1)=T(1)*CPN(1) + DO 40 I=2,NL + TVX=T(I)*(1.+RR(I)/EPS-RR(I)) + TVY=T(I-1)*(1.+RR(I-1)/EPS-RR(I-1)) + GZ(I)=GZ(I-1)+0.5*RD*(TVX+TVY)*(P(I-1)-P(I))/PH(I) + CPN(I)=CPD*(1.-RR(I))+CPV*RR(I) + H(I)=T(I)*CPN(I)+GZ(I) + 40 CONTINUE +C +C *** CALCULATE LIFTED CONDENSATION LEVEL OF AIR AT LOWEST MODEL LEVEL *** +C *** (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980) *** +C + IF (T(1).LT.250.0.OR.RR(1).LE.0.0)THEN + IFLAG=0 +c sb3d print*,'je suis passe par 366' + RETURN + END IF + +cjyg1 Utilisation de la subroutine CLIFT +CC RH=RR(1)/RS(1) +CC CHI=T(1)/(1669.0-122.0*RH-T(1)) +CC PLCL=P(1)*(RH**CHI) + CALL CLIFT(P(1),T(1),RR(1),RS(1),PLCL,DPLCLDT,DPLCLDR) +cjyg2 +c sb3d PRINT *,' em_plcl,p1,t1,r1,rs1,rh ' +c sb3d $ ,PLCL,P(1),T(1),RR(1),RS(1),RH +c + IF (PLCL.LT.200.0.OR.PLCL.GE.2000.0)THEN + IFLAG=2 + RETURN + END IF +Cjyg1 +C Essais de modification de ICB +C +C *** CALCULATE FIRST LEVEL ABOVE LCL (=ICB) *** +C +CC ICB=NL-1 +CC DO 50 I=2,NL-1 +CC IF(P(I).LT.PLCL)THEN +CC ICB=MIN(ICB,I) ! ICB sup ou egal a 2 +CC END IF +CC 50 CONTINUE +CC IF(ICB.EQ.(NL-1))THEN +CC IFLAG=3 +CC RETURN +CC END IF +C +C *** CALCULATE LAYER CONTAINING LCL (=ICB) *** +C + ICB=NL-1 +c sb DO 50 I=2,NL-1 + DO 50 I=3,NL-1 ! modif sb pour que ICB soit sup/egal a 2 +C la modification consiste a comparer PLCL a PH et non a P: +C ICB est defini par : PH(ICB) adiabatic CAPE) +C +ccc TVP(I)=TVP(I)-TP(I)*(RR(1)-EP(I)*CLW(I)) +c!!! sb TVP(I)=TVP(I)-TP(I)*RR(1) ! calcule dans tlift +Ccd2 +C +C *** Calculate first estimate of buoyancy +C + BUOY(I) = TVP(I) - TV(I) + 55 CONTINUE +C +C *** Set Cloud Base Buoyancy at (Plcl+DPbase) level buoyancy +C + DPBASE = -40. !That is 400m above LCL + PBASE = PLCL + DPBASE + TVPBASE = TVP(ICB )*(PBASE -P(ICB+1))/(P(ICB)-P(ICB+1)) + $ +TVP(ICB+1)*(P(ICB)-PBASE )/(P(ICB)-P(ICB+1)) + TVBASE = TV(ICB )*(PBASE -P(ICB+1))/(P(ICB)-P(ICB+1)) + $ +TV(ICB+1)*(P(ICB)-PBASE )/(P(ICB)-P(ICB+1)) +C +c test sb: +c@ write(*,*) '++++++++++++++++++++++++++++++++++++++++' +c@ write(*,*) 'plcl,dpbas,tvpbas,tvbas,tvp(icb),tvp(icb1) +c@ : ,tv(icb),tv(icb1)' +c@ write(*,*) plcl,dpbase,tvpbase,tvbase,tvp(icb) +c@ L ,tvp(icb+1),tv(icb),tv(icb+1) +c@ write(*,*) '++++++++++++++++++++++++++++++++++++++++' +c fin test sb + BUOYBASE = TVPBASE - TVBASE +C +CC Set buoyancy = BUOYBASE for all levels below BASE. +CC For safety, set : BUOY(ICB) = BUOYBASE + DO I = ICB,NL + IF (P(I) .GE. PBASE) THEN + BUOY(I) = BUOYBASE + ENDIF + ENDDO + BUOY(ICB) = BUOYBASE +C +c sb3d print *,'buoybase,tvp_tv,tvpbase,tvbase,pbase,plcl' +c sb3d $, buoybase,tvp(icb)-tv(icb),tvpbase,tvbase,pbase,plcl +c sb3d print *,'TVP ',(tvp(i),i=1,nl) +c sb3d print *,'TV ',(tv(i),i=1,nl) +c sb3d print *, 'P ',(p(i),i=1,nl) +c sb3d print *,'ICB ',icb +c test sb: +c@ write(*,*) '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@' +c@ write(*,*) 'icb,icbs,inb,buoybase:' +c@ write(*,*) icb,icb+1,inb,buoybase +c@ write(*,*) 'k,tvp,tv,tp,buoy,ep: ' +c@ do k=1,nl +c@ write(*,*) k,tvp(k),tv(k),tp(k),buoy(k),ep(k) +c@ enddo +c@ write(*,*) '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@' +c fin test sb + + +C +C *** MAKE SURE THAT COLUMN IS DRY ADIABATIC BETWEEN THE SURFACE *** +C *** AND CLOUD BASE, AND THAT LIFTED AIR IS POSITIVELY BUOYANT *** +C *** AT CLOUD BASE *** +C *** IF NOT, RETURN TO CALLING PROGRAM AFTER RESETTING *** +C *** SIG(I) AND W0(I) *** +C +Cjyg +CCC TDIF=TVP(ICB)-TV(ICB) + TDIF = BUOY(ICB) + ATH1=TH(1) +Cjyg +CCC ATH=TH(ICB-1)-1.0 + ATH=TH(ICB-1)-5.0 +c ATH=0. ! ajout sb +c IF (ICB.GT.1) ATH=TH(ICB-1)-5.0 ! modif sb + IF(TDIF.LT.DTCRIT.OR.ATH.GT.ATH1)THEN + DO 60 I=1,NL + SIG(I)=BETA*SIG(I)-2.*ALPHA*TDIF*TDIF + SIG(I)=AMAX1(SIG(I),0.0) + W0(I)=BETA*W0(I) + 60 CONTINUE + IFLAG=0 + RETURN + END IF +C + + +C *** IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY *** +C *** NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS *** +C + DO 70 I=1,NL + HP(I)=H(I) + WT(I)=0.001 + RP(I)=RR(I) + UP(I)=U(I) + VP(I)=V(I) + DO 71 J=1,NTRA + TRAP(I,J)=TRA(I,J) + 71 CONTINUE + NENT(I)=0 + WATER(I)=0.0 + EVAP(I)=0.0 + B(I)=0.0 + MP(I)=0.0 + M(I)=0.0 + LV(I)=ALV0-CPVMCL*(T(I)-273.15) + LVCP(I)=LV(I)/CPN(I) + DO 70 J=1,NL + QENT(I,J)=RR(J) + ELIJ(I,J)=0.0 + MENT(I,J)=0.0 + SIJ(I,J)=0.0 + UENT(I,J)=U(J) + VENT(I,J)=V(J) + DO 70 K=1,NTRA + TRAENT(I,J,K)=TRA(J,K) + 70 CONTINUE + + DELTI=1.0/DELT +C +C *** FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S *** +C *** LEVEL OF NEUTRAL BUOYANCY *** +C + INB=NL-1 + DO 80 I=ICB,NL-1 +Cjyg +CCC IF((TVP(I)-TV(I)).LT.DTCRIT)THEN + IF(BUOY(I).LT.DTOVSH)THEN + INB=MIN(INB,I) + END IF + 80 CONTINUE + + + + +C +C *** RESET SIG(I) AND W0(I) FOR I>INB AND IPH(I), PR1=1 & PR2=0 +C Pour PH(I+1) 0.) THEN + pctsrf(i,is_sic) = (pctsrf_old(i,is_oce) + pctsrf_old(i,is_sic)) & + * read_sic1D(i) + pctsrf(i,is_oce) = (pctsrf_old(i,is_oce) + pctsrf_old(i,is_sic)) & + - pctsrf(i,is_sic) + ENDIF + ENDDO + + END IF ! if time to receive + + END SUBROUTINE cpl_receive_frac + +! +!************************************************************************************* +! + + SUBROUTINE cpl_receive_ocean_fields(knon, knindex, tsurf_new, u0_new, v0_new) +! +! This routine returns the field for the ocean that has been read from the coupler +! (done earlier with cpl_receive_frac). The field is the temperature. +! The temperature is transformed into 1D array with valid points from index 1 to knon. +! + USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, fco2_ocn_day + INCLUDE "indicesol.h" + +! Input arguments +!************************************************************************************* + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + +! Output arguments +!************************************************************************************* + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: u0_new + REAL, DIMENSION(klon), INTENT(OUT) :: v0_new + +! Local variables +!************************************************************************************* + INTEGER :: i + INTEGER, DIMENSION(klon) :: index + REAL, DIMENSION(klon) :: sic_new + +!************************************************************************************* +! Transform read_sst into compressed 1D variable tsurf_new +! +!************************************************************************************* + CALL cpl2gath(read_sst, tsurf_new, knon, knindex) + CALL cpl2gath(read_sic, sic_new, knon, knindex) + CALL cpl2gath(read_u0, u0_new, knon, knindex) + CALL cpl2gath(read_v0, v0_new, knon, knindex) + +!************************************************************************************* +! Transform read_co2 into uncompressed 1D variable fco2_ocn_day added directly in +! the module carbon_cycle_mod +! +!************************************************************************************* + IF (carbon_cycle_cpl) THEN + DO i=1,klon + index(i)=i + END DO + CALL cpl2gath(read_co2, fco2_ocn_day, klon, index) + END IF + +!************************************************************************************* +! The fields received from the coupler have to be weighted with the fraction of ocean +! in relation to the total sea-ice+ocean +! +!************************************************************************************* + DO i=1, knon + tsurf_new(i) = tsurf_new(i)/(1. - sic_new(i)) + END DO + + END SUBROUTINE cpl_receive_ocean_fields + +! +!************************************************************************************* +! + + SUBROUTINE cpl_receive_seaice_fields(knon, knindex, & + tsurf_new, alb_new, u0_new, v0_new) +! +! This routine returns the fields for the seaice that have been read from the coupler +! (done earlier with cpl_receive_frac). These fields are the temperature and +! albedo at sea ice surface and fraction of sea ice. +! The fields are transformed into 1D arrays with valid points from index 1 to knon. +! + +! Input arguments +!************************************************************************************* + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + +! Output arguments +!************************************************************************************* + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb_new + REAL, DIMENSION(klon), INTENT(OUT) :: u0_new + REAL, DIMENSION(klon), INTENT(OUT) :: v0_new + +! Local variables +!************************************************************************************* + INTEGER :: i + REAL, DIMENSION(klon) :: sic_new + +!************************************************************************************* +! Transform fields read from coupler from 2D into compressed 1D variables +! +!************************************************************************************* + CALL cpl2gath(read_sit, tsurf_new, knon, knindex) + CALL cpl2gath(read_alb_sic, alb_new, knon, knindex) + CALL cpl2gath(read_sic, sic_new, knon, knindex) + CALL cpl2gath(read_u0, u0_new, knon, knindex) + CALL cpl2gath(read_v0, v0_new, knon, knindex) + +!************************************************************************************* +! The fields received from the coupler have to be weighted with the sea-ice +! concentration (in relation to the total sea-ice + ocean). +! +!************************************************************************************* + DO i= 1, knon + tsurf_new(i) = tsurf_new(i) / sic_new(i) + alb_new(i) = alb_new(i) / sic_new(i) + END DO + + END SUBROUTINE cpl_receive_seaice_fields + +! +!************************************************************************************* +! + + SUBROUTINE cpl_send_ocean_fields(itime, knon, knindex, & + swdown, lwdown, fluxlat, fluxsens, & + precip_rain, precip_snow, evap, tsurf, fder, albsol, taux, tauy, windsp) +! +! This subroutine cumulates some fields for each time-step during a coupling +! period. At last time-step in a coupling period the fields are transformed to the +! grid accepted by the coupler. No sending to the coupler will be done from here +! (it is done in cpl_send_seaice_fields). +! + USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, co2_send + INCLUDE "indicesol.h" + INCLUDE "dimensions.h" + +! Input arguments +!************************************************************************************* + INTEGER, INTENT(IN) :: itime + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, DIMENSION(klon), INTENT(IN) :: swdown, lwdown + REAL, DIMENSION(klon), INTENT(IN) :: fluxlat, fluxsens + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: evap, tsurf, fder, albsol + REAL, DIMENSION(klon), INTENT(IN) :: taux, tauy, windsp + +! Local variables +!************************************************************************************* + INTEGER :: cpl_index, ig + INTEGER :: error, sum_error + CHARACTER(len = 25) :: modname = 'cpl_send_ocean_fields' + CHARACTER(len = 80) :: abort_message + +!************************************************************************************* +! Start calculation +! The ocean points are saved with second array index=1 +! +!************************************************************************************* + cpl_index = 1 + +!************************************************************************************* +! Reset fields to zero in the beginning of a new coupling period +! +!************************************************************************************* + IF (MOD(itime, nexca) == 1) THEN + cpl_sols(1:knon,cpl_index) = 0.0 + cpl_nsol(1:knon,cpl_index) = 0.0 + cpl_rain(1:knon,cpl_index) = 0.0 + cpl_snow(1:knon,cpl_index) = 0.0 + cpl_evap(1:knon,cpl_index) = 0.0 + cpl_tsol(1:knon,cpl_index) = 0.0 + cpl_fder(1:knon,cpl_index) = 0.0 + cpl_albe(1:knon,cpl_index) = 0.0 + cpl_taux(1:knon,cpl_index) = 0.0 + cpl_tauy(1:knon,cpl_index) = 0.0 + cpl_windsp(1:knon,cpl_index) = 0.0 + cpl_taumod(1:knon,cpl_index) = 0.0 + IF (carbon_cycle_cpl) cpl_atm_co2(1:knon,cpl_index) = 0.0 + ENDIF + +!************************************************************************************* +! Cumulate at each time-step +! +!************************************************************************************* + DO ig = 1, knon + cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + & + swdown(ig) / FLOAT(nexca) + cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + & + (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / FLOAT(nexca) + cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + & + precip_rain(ig) / FLOAT(nexca) + cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + & + precip_snow(ig) / FLOAT(nexca) + cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + & + evap(ig) / FLOAT(nexca) + cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + & + tsurf(ig) / FLOAT(nexca) + cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + & + fder(ig) / FLOAT(nexca) + cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + & + albsol(ig) / FLOAT(nexca) + cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + & + taux(ig) / FLOAT(nexca) + cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + & + tauy(ig) / FLOAT(nexca) + cpl_windsp(ig,cpl_index) = cpl_windsp(ig,cpl_index) + & + windsp(ig) / FLOAT(nexca) + cpl_taumod(ig,cpl_index) = cpl_taumod(ig,cpl_index) + & + SQRT ( taux(ig)*taux(ig)+tauy(ig)*tauy(ig) ) / FLOAT (nexca) + + IF (carbon_cycle_cpl) THEN + cpl_atm_co2(ig,cpl_index) = cpl_atm_co2(ig,cpl_index) + & + co2_send(knindex(ig))/ FLOAT(nexca) + END IF + ENDDO + +!************************************************************************************* +! If the time-step corresponds to the end of coupling period the +! fields are transformed to the 2D grid. +! No sending to the coupler (it is done from cpl_send_seaice_fields). +! +!************************************************************************************* + IF (MOD(itime, nexca) == 0) THEN + + IF (.NOT. ALLOCATED(cpl_sols2D)) THEN + sum_error = 0 + ALLOCATE(cpl_sols2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_nsol2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_rain2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_snow2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_evap2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_tsol2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_fder2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_albe2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_taux2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_tauy2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_windsp2D(iim,jj_nb), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_taumod2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + + IF (carbon_cycle_cpl) THEN + ALLOCATE(cpl_atm_co22D(iim,jj_nb), stat=error) + sum_error = sum_error + error + END IF + + IF (sum_error /= 0) THEN + abort_message='Pb allocation variables couplees pour l''ecriture' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + + + CALL gath2cpl(cpl_sols(:,cpl_index), cpl_sols2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_nsol(:,cpl_index), cpl_nsol2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_rain(:,cpl_index), cpl_rain2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_snow(:,cpl_index), cpl_snow2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_evap(:,cpl_index), cpl_evap2D(:,:,cpl_index), & + knon, knindex) + +! cpl_tsol2D(:,:,:) not used! + CALL gath2cpl(cpl_tsol(:,cpl_index), cpl_tsol2D(:,:, cpl_index), & + knon, knindex) + +! cpl_fder2D(:,:,1) not used, only cpl_fder(:,:,2)! + CALL gath2cpl(cpl_fder(:,cpl_index), cpl_fder2D(:,:,cpl_index), & + knon, knindex) + +! cpl_albe2D(:,:,:) not used! + CALL gath2cpl(cpl_albe(:,cpl_index), cpl_albe2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_taux(:,cpl_index), cpl_taux2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_tauy(:,cpl_index), cpl_tauy2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_windsp(:,cpl_index), cpl_windsp2D(:,:), & + knon, knindex) + + CALL gath2cpl(cpl_taumod(:,cpl_index), cpl_taumod2D(:,:,cpl_index), & + knon, knindex) + + IF (carbon_cycle_cpl) & + CALL gath2cpl(cpl_atm_co2(:,cpl_index), cpl_atm_co22D(:,:), knon, knindex) + ENDIF + + END SUBROUTINE cpl_send_ocean_fields + +! +!************************************************************************************* +! + + SUBROUTINE cpl_send_seaice_fields(itime, dtime, knon, knindex, & + pctsrf, lafin, rlon, rlat, & + swdown, lwdown, fluxlat, fluxsens, & + precip_rain, precip_snow, evap, tsurf, fder, albsol, taux, tauy) +! +! This subroutine cumulates some fields for each time-step during a coupling +! period. At last time-step in a coupling period the fields are transformed to the +! grid accepted by the coupler. All fields for all types of surfaces are sent to +! the coupler. +! + USE carbon_cycle_mod, ONLY : carbon_cycle_cpl + INCLUDE "indicesol.h" + INCLUDE "dimensions.h" + +! Input arguments +!************************************************************************************* + INTEGER, INTENT(IN) :: itime + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(IN) :: swdown, lwdown + REAL, DIMENSION(klon), INTENT(IN) :: fluxlat, fluxsens + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: evap, tsurf, fder + REAL, DIMENSION(klon), INTENT(IN) :: albsol, taux, tauy + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + LOGICAL, INTENT(IN) :: lafin + +! Local variables +!************************************************************************************* + INTEGER :: cpl_index, ig + INTEGER :: error, sum_error + CHARACTER(len = 25) :: modname = 'cpl_send_seaice_fields' + CHARACTER(len = 80) :: abort_message + REAL, DIMENSION(klon) :: cpl_fder_tmp + +!************************************************************************************* +! Start calulation +! The sea-ice points are saved with second array index=2 +! +!************************************************************************************* + cpl_index = 2 + +!************************************************************************************* +! Reset fields to zero in the beginning of a new coupling period +! +!************************************************************************************* + IF (MOD(itime, nexca) == 1) THEN + cpl_sols(1:knon,cpl_index) = 0.0 + cpl_nsol(1:knon,cpl_index) = 0.0 + cpl_rain(1:knon,cpl_index) = 0.0 + cpl_snow(1:knon,cpl_index) = 0.0 + cpl_evap(1:knon,cpl_index) = 0.0 + cpl_tsol(1:knon,cpl_index) = 0.0 + cpl_fder(1:knon,cpl_index) = 0.0 + cpl_albe(1:knon,cpl_index) = 0.0 + cpl_taux(1:knon,cpl_index) = 0.0 + cpl_tauy(1:knon,cpl_index) = 0.0 + cpl_taumod(1:knon,cpl_index) = 0.0 + ENDIF + +!************************************************************************************* +! Cumulate at each time-step +! +!************************************************************************************* + DO ig = 1, knon + cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + & + swdown(ig) / FLOAT(nexca) + cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + & + (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / FLOAT(nexca) + cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + & + precip_rain(ig) / FLOAT(nexca) + cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + & + precip_snow(ig) / FLOAT(nexca) + cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + & + evap(ig) / FLOAT(nexca) + cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + & + tsurf(ig) / FLOAT(nexca) + cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + & + fder(ig) / FLOAT(nexca) + cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + & + albsol(ig) / FLOAT(nexca) + cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + & + taux(ig) / FLOAT(nexca) + cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + & + tauy(ig) / FLOAT(nexca) + cpl_taumod(ig,cpl_index) = cpl_taumod(ig,cpl_index) + & + SQRT ( taux(ig)*taux(ig)+tauy(ig)*tauy(ig) ) / FLOAT(nexca) + ENDDO + +!************************************************************************************* +! If the time-step corresponds to the end of coupling period the +! fields are transformed to the 2D grid and all fields are sent to coupler. +! +!************************************************************************************* + IF (MOD(itime, nexca) == 0) THEN + IF (.NOT. ALLOCATED(cpl_sols2D)) THEN + sum_error = 0 + ALLOCATE(cpl_sols2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_nsol2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_rain2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_snow2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_evap2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_tsol2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_fder2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_albe2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_taux2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_tauy2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_windsp2D(iim,jj_nb), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_taumod2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + + IF (carbon_cycle_cpl) THEN + ALLOCATE(cpl_atm_co22D(iim,jj_nb), stat=error) + sum_error = sum_error + error + END IF + + IF (sum_error /= 0) THEN + abort_message='Pb allocation variables couplees pour l''ecriture' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + + CALL gath2cpl(cpl_sols(:,cpl_index), cpl_sols2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_nsol(:,cpl_index), cpl_nsol2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_rain(:,cpl_index), cpl_rain2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_snow(:,cpl_index), cpl_snow2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_evap(:,cpl_index), cpl_evap2D(:,:,cpl_index), & + knon, knindex) + +! cpl_tsol2D(:,:,:) not used! + CALL gath2cpl(cpl_tsol(:,cpl_index), cpl_tsol2D(:,:, cpl_index), & + knon, knindex) + + ! Set default value and decompress before gath2cpl + cpl_fder_tmp(:) = -20. + DO ig = 1, knon + cpl_fder_tmp(knindex(ig))=cpl_fder(ig,cpl_index) + END DO + CALL gath2cpl(cpl_fder_tmp(:), cpl_fder2D(:,:,cpl_index), & + klon, unity) + +! cpl_albe2D(:,:,:) not used! + CALL gath2cpl(cpl_albe(:,cpl_index), cpl_albe2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_taux(:,cpl_index), cpl_taux2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_tauy(:,cpl_index), cpl_tauy2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_taumod(:,cpl_index), cpl_taumod2D(:,:,cpl_index), & + knon, knindex) + + ! Send all fields + CALL cpl_send_all(itime, dtime, pctsrf, lafin, rlon, rlat) + ENDIF + + END SUBROUTINE cpl_send_seaice_fields + +! +!************************************************************************************* +! + + SUBROUTINE cpl_send_land_fields(itime, knon, knindex, rriv_in, rcoa_in) +! +! This subroutine cumulates some fields for each time-step during a coupling +! period. At last time-step in a coupling period the fields are transformed to the +! grid accepted by the coupler. No sending to the coupler will be done from here +! (it is done in cpl_send_seaice_fields). +! + INCLUDE "dimensions.h" + +! Input arguments +!************************************************************************************* + INTEGER, INTENT(IN) :: itime + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, DIMENSION(klon), INTENT(IN) :: rriv_in + REAL, DIMENSION(klon), INTENT(IN) :: rcoa_in + +! Local variables +!************************************************************************************* + REAL, DIMENSION(iim,jj_nb) :: rriv2D + REAL, DIMENSION(iim,jj_nb) :: rcoa2D + +!************************************************************************************* +! Rearrange fields in 2D variables +! First initialize to zero to avoid unvalid points causing problems +! +!************************************************************************************* +!$OMP MASTER + rriv2D(:,:) = 0.0 + rcoa2D(:,:) = 0.0 +!$OMP END MASTER + CALL gath2cpl(rriv_in, rriv2D, knon, knindex) + CALL gath2cpl(rcoa_in, rcoa2D, knon, knindex) + +!************************************************************************************* +! Reset cumulated fields to zero in the beginning of a new coupling period +! +!************************************************************************************* + IF (MOD(itime, nexca) == 1) THEN +!$OMP MASTER + cpl_rriv2D(:,:) = 0.0 + cpl_rcoa2D(:,:) = 0.0 +!$OMP END MASTER + ENDIF + +!************************************************************************************* +! Cumulate : Following fields should be cumulated at each time-step +! +!************************************************************************************* +!$OMP MASTER + cpl_rriv2D(:,:) = cpl_rriv2D(:,:) + rriv2D(:,:) / FLOAT(nexca) + cpl_rcoa2D(:,:) = cpl_rcoa2D(:,:) + rcoa2D(:,:) / FLOAT(nexca) +!$OMP END MASTER + + END SUBROUTINE cpl_send_land_fields + +! +!************************************************************************************* +! + + SUBROUTINE cpl_send_landice_fields(itime, knon, knindex, rlic_in) +! This subroutine cumulates the field for melting ice for each time-step +! during a coupling period. This routine will not send to coupler. Sending +! will be done in cpl_send_seaice_fields. +! + + INCLUDE "dimensions.h" + +! Input varibales +!************************************************************************************* + INTEGER, INTENT(IN) :: itime + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, DIMENSION(klon), INTENT(IN) :: rlic_in + +! Local varibales +!************************************************************************************* + REAL, DIMENSION(iim,jj_nb) :: rlic2D + +!************************************************************************************* +! Rearrange field in a 2D variable +! First initialize to zero to avoid unvalid points causing problems +! +!************************************************************************************* +!$OMP MASTER + rlic2D(:,:) = 0.0 +!$OMP END MASTER + CALL gath2cpl(rlic_in, rlic2D, knon, knindex) + +!************************************************************************************* +! Reset field to zero in the beginning of a new coupling period +! +!************************************************************************************* + IF (MOD(itime, nexca) == 1) THEN +!$OMP MASTER + cpl_rlic2D(:,:) = 0.0 +!$OMP END MASTER + ENDIF + +!************************************************************************************* +! Cumulate : Melting ice should be cumulated at each time-step +! +!************************************************************************************* +!$OMP MASTER + cpl_rlic2D(:,:) = cpl_rlic2D(:,:) + rlic2D(:,:) / FLOAT(nexca) +!$OMP END MASTER + + END SUBROUTINE cpl_send_landice_fields + +! +!************************************************************************************* +! + + SUBROUTINE cpl_send_all(itime, dtime, pctsrf, lafin, rlon, rlat) +! This routine will send fields for all different surfaces to the coupler. +! This subroutine should be executed after calculations by the last surface(sea-ice), +! all calculations at the different surfaces have to be done before. +! + USE surface_data + USE carbon_cycle_mod, ONLY : carbon_cycle_cpl +! Some includes +!************************************************************************************* + INCLUDE "indicesol.h" + INCLUDE "temps.h" + INCLUDE "dimensions.h" + +! Input arguments +!************************************************************************************* + INTEGER, INTENT(IN) :: itime + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + LOGICAL, INTENT(IN) :: lafin + +! Local variables +!************************************************************************************* + INTEGER :: error, sum_error, j + INTEGER :: itau_w + INTEGER :: time_sec + INTEGER, DIMENSION(iim*(jjm+1)) :: ndexct + REAL :: Up, Down + REAL, DIMENSION(iim, jj_nb) :: tmp_lon, tmp_lat + REAL, DIMENSION(iim, jj_nb, 4) :: pctsrf2D + REAL, DIMENSION(iim, jj_nb) :: deno + CHARACTER(len = 20) :: modname = 'cpl_send_all' + CHARACTER(len = 80) :: abort_message + +! Variables with fields to coupler + REAL, DIMENSION(iim, jj_nb) :: tmp_taux + REAL, DIMENSION(iim, jj_nb) :: tmp_tauy + REAL, DIMENSION(iim, jj_nb) :: tmp_calv +! Table with all fields to send to coupler + REAL, DIMENSION(iim, jj_nb, maxsend) :: tab_flds + REAL, DIMENSION(klon_mpi) :: rlon_mpi, rlat_mpi + +#ifdef CPP_MPI + INCLUDE 'mpif.h' + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status +#endif + +! End definitions +!************************************************************************************* + + + +!************************************************************************************* +! All fields are stored in a table tab_flds(:,:,:) +! First store the fields which are already on the right format +! +!************************************************************************************* +!$OMP MASTER + tab_flds(:,:,ids_windsp) = cpl_windsp2D(:,:) + tab_flds(:,:,ids_shfice) = cpl_sols2D(:,:,2) + tab_flds(:,:,ids_nsfice) = cpl_nsol2D(:,:,2) + tab_flds(:,:,ids_dflxdt) = cpl_fder2D(:,:,2) + + IF (version_ocean=='nemo') THEN + tab_flds(:,:,ids_liqrun) = cpl_rriv2D(:,:) + cpl_rcoa2D(:,:) + IF (carbon_cycle_cpl) tab_flds(:,:,ids_atmco2)=cpl_atm_co22D(:,:) + ELSE IF (version_ocean=='opa8') THEN + tab_flds(:,:,ids_shfoce) = cpl_sols2D(:,:,1) + tab_flds(:,:,ids_nsfoce) = cpl_nsol2D(:,:,1) + tab_flds(:,:,ids_icevap) = cpl_evap2D(:,:,2) + tab_flds(:,:,ids_ocevap) = cpl_evap2D(:,:,1) + tab_flds(:,:,ids_runcoa) = cpl_rcoa2D(:,:) + tab_flds(:,:,ids_rivflu) = cpl_rriv2D(:,:) + END IF + +!************************************************************************************* +! Transform the fraction of sub-surfaces from 1D to 2D array +! +!************************************************************************************* + pctsrf2D(:,:,:) = 0. +!$OMP END MASTER + CALL gath2cpl(pctsrf(:,is_oce), pctsrf2D(:,:,is_oce), klon, unity) + CALL gath2cpl(pctsrf(:,is_sic), pctsrf2D(:,:,is_sic), klon, unity) + CALL gath2cpl(pctsrf(:,is_lic), pctsrf2D(:,:,is_lic), klon, unity) + +!************************************************************************************* +! Calculate the average calving per latitude +! Store calving in tab_flds(:,:,19) +! +!************************************************************************************* + IF (is_omp_root) THEN + + DO j = 1, jj_nb + tmp_calv(:,j) = DOT_PRODUCT (cpl_rlic2D(1:iim,j), & + pctsrf2D(1:iim,j,is_lic)) / REAL(iim) + ENDDO + + + IF (is_parallel) THEN + IF (.NOT. is_north_pole) THEN +#ifdef CPP_MPI + CALL MPI_RECV(Up,1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,status,error) + CALL MPI_SEND(tmp_calv(1,1),1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,error) +#endif + ENDIF + + IF (.NOT. is_south_pole) THEN +#ifdef CPP_MPI + CALL MPI_SEND(tmp_calv(1,jj_nb),1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,error) + CALL MPI_RECV(down,1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,status,error) +#endif + ENDIF + + IF (.NOT. is_north_pole .AND. ii_begin /=1) THEN + Up=Up+tmp_calv(iim,1) + tmp_calv(:,1)=Up + ENDIF + + IF (.NOT. is_south_pole .AND. ii_end /= iim) THEN + Down=Down+tmp_calv(1,jj_nb) + tmp_calv(:,jj_nb)=Down + ENDIF + ENDIF + + tab_flds(:,:,ids_calvin) = tmp_calv(:,:) + +!************************************************************************************* +! Calculate total flux for snow, rain and wind with weighted addition using the +! fractions of ocean and seaice. +! +!************************************************************************************* + ! fraction oce+seaice + deno = pctsrf2D(:,:,is_oce) + pctsrf2D(:,:,is_sic) + + IF (version_ocean=='nemo') THEN + tab_flds(:,:,ids_shftot) = 0.0 + tab_flds(:,:,ids_nsftot) = 0.0 + tab_flds(:,:,ids_totrai) = 0.0 + tab_flds(:,:,ids_totsno) = 0.0 + tab_flds(:,:,ids_toteva) = 0.0 + tab_flds(:,:,ids_taumod) = 0.0 + + tmp_taux(:,:) = 0.0 + tmp_tauy(:,:) = 0.0 + ! For all valid grid cells containing some fraction of ocean or sea-ice + WHERE ( deno(:,:) /= 0 ) + tmp_taux = cpl_taux2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_taux2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + tmp_tauy = cpl_tauy2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_tauy2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + + tab_flds(:,:,ids_shftot) = cpl_sols2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_sols2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + tab_flds(:,:,ids_nsftot) = cpl_nsol2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_nsol2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + tab_flds(:,:,ids_totrai) = cpl_rain2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_rain2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + tab_flds(:,:,ids_totsno) = cpl_snow2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_snow2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + tab_flds(:,:,ids_toteva) = cpl_evap2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_evap2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + tab_flds(:,:,ids_taumod) = cpl_taumod2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_taumod2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + + ENDWHERE + + tab_flds(:,:,ids_icevap) = cpl_evap2D(:,:,2) + + ELSE IF (version_ocean=='opa8') THEN + ! Store fields for rain and snow in tab_flds(:,:,15) and tab_flds(:,:,16) + tab_flds(:,:,ids_totrai) = 0.0 + tab_flds(:,:,ids_totsno) = 0.0 + tmp_taux(:,:) = 0.0 + tmp_tauy(:,:) = 0.0 + ! For all valid grid cells containing some fraction of ocean or sea-ice + WHERE ( deno(:,:) /= 0 ) + tab_flds(:,:,ids_totrai) = cpl_rain2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_rain2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + tab_flds(:,:,ids_totsno) = cpl_snow2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_snow2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + + tmp_taux = cpl_taux2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_taux2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + tmp_tauy = cpl_tauy2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_tauy2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + ENDWHERE + END IF + + ENDIF ! is_omp_root + +!************************************************************************************* +! Transform the wind components from local atmospheric 2D coordinates to geocentric +! 3D coordinates. +! Store the resulting wind components in tab_flds(:,:,1:6) +!************************************************************************************* + +! Transform the longitudes and latitudes on 2D arrays + + CALL gather_omp(rlon,rlon_mpi) + CALL gather_omp(rlat,rlat_mpi) +!$OMP MASTER + CALL Grid1DTo2D_mpi(rlon_mpi,tmp_lon) + CALL Grid1DTo2D_mpi(rlat_mpi,tmp_lat) +!$OMP END MASTER + + IF (is_sequential) THEN + IF (is_north_pole) tmp_lon(:,1) = tmp_lon(:,2) + IF (is_south_pole) tmp_lon(:,jjm+1) = tmp_lon(:,jjm) + ENDIF + +! NetCDF output of the wind before transformation of coordinate system + IF (is_sequential) THEN + ndexct(:) = 0 + itau_w = itau_phy + itime + CALL histwrite(nidct,'tauxe',itau_w,tmp_taux,iim*(jjm+1),ndexct) + CALL histwrite(nidct,'tauyn',itau_w,tmp_tauy,iim*(jjm+1),ndexct) + CALL histwrite(nidct,'tmp_lon',itau_w,tmp_lon,iim*(jjm+1),ndexct) + CALL histwrite(nidct,'tmp_lat',itau_w,tmp_lat,iim*(jjm+1),ndexct) + ENDIF + +! Transform the wind from spherical atmospheric 2D coordinates to geocentric +! cartesian 3D coordinates +!$OMP MASTER + CALL atm2geo (iim, jj_nb, tmp_taux, tmp_tauy, tmp_lon, tmp_lat, & + tab_flds(:,:,ids_tauxxu), tab_flds(:,:,ids_tauyyu), tab_flds(:,:,ids_tauzzu) ) + + tab_flds(:,:,ids_tauxxv) = tab_flds(:,:,ids_tauxxu) + tab_flds(:,:,ids_tauyyv) = tab_flds(:,:,ids_tauyyu) + tab_flds(:,:,ids_tauzzv) = tab_flds(:,:,ids_tauzzu) +!$OMP END MASTER + +!************************************************************************************* +! NetCDF output of all fields just before sending to coupler. +! +!************************************************************************************* + IF (is_sequential) THEN + DO j=1,maxsend + IF (infosend(j)%action) CALL histwrite(nidct,infosend(j)%name, itau_w, & + tab_flds(:,:,j),iim*(jjm+1),ndexct) + ENDDO + ENDIF +!************************************************************************************* +! Send the table of all fields +! +!************************************************************************************* + time_sec=(itime-1)*dtime +#ifdef CPP_COUPLE +!$OMP MASTER + CALL intocpl(time_sec, lafin, tab_flds(:,:,:)) +!$OMP END MASTER +#endif + +!************************************************************************************* +! Finish with some dellocate +! +!************************************************************************************* + sum_error=0 + DEALLOCATE(cpl_sols2D, cpl_nsol2D, cpl_rain2D, cpl_snow2D, stat=error ) + sum_error = sum_error + error + DEALLOCATE(cpl_evap2D, cpl_tsol2D, cpl_fder2D, cpl_albe2D, stat=error ) + sum_error = sum_error + error + DEALLOCATE(cpl_taux2D, cpl_tauy2D, cpl_windsp2D, cpl_taumod2D, stat=error ) + sum_error = sum_error + error + + IF (carbon_cycle_cpl) THEN + DEALLOCATE(cpl_atm_co22D, stat=error ) + sum_error = sum_error + error + END IF + + IF (sum_error /= 0) THEN + abort_message='Pb in deallocation of cpl_xxxx2D coupling variables' + CALL abort_gcm(modname,abort_message,1) + ENDIF + + END SUBROUTINE cpl_send_all +! +!************************************************************************************* +! + SUBROUTINE cpl2gath(champ_in, champ_out, knon, knindex) + USE mod_phys_lmdz_para +! Cette routine transforme un champs de la grille 2D recu du coupleur sur la grille +! 'gathered' (la grille physiq comprime). +! +! +! input: +! champ_in champ sur la grille 2D +! knon nombre de points dans le domaine a traiter +! knindex index des points de la surface a traiter +! +! output: +! champ_out champ sur la grille 'gatherd' +! + INCLUDE "dimensions.h" + +! Input + INTEGER, INTENT(IN) :: knon + REAL, DIMENSION(iim,jj_nb), INTENT(IN) :: champ_in + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + +! Output + REAL, DIMENSION(klon_mpi), INTENT(OUT) :: champ_out + +! Local + INTEGER :: i, ig + REAL, DIMENSION(klon_mpi) :: temp_mpi + REAL, DIMENSION(klon) :: temp_omp + +!************************************************************************************* +! + + +! Transform from 2 dimensions (iim,jj_nb) to 1 dimension (klon) +!$OMP MASTER + CALL Grid2Dto1D_mpi(champ_in,temp_mpi) +!$OMP END MASTER + + CALL scatter_omp(temp_mpi,temp_omp) + +! Compress from klon to knon + DO i = 1, knon + ig = knindex(i) + champ_out(i) = temp_omp(ig) + ENDDO + + END SUBROUTINE cpl2gath +! +!************************************************************************************* +! + SUBROUTINE gath2cpl(champ_in, champ_out, knon, knindex) + USE mod_phys_lmdz_para +! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer +! au coupleur. +! +! input: +! champ_in champ sur la grille gathere +! knon nombre de points dans le domaine a traiter +! knindex index des points de la surface a traiter +! +! output: +! champ_out champ sur la grille 2D +! + INCLUDE "dimensions.h" + +! Input arguments +!************************************************************************************* + INTEGER, INTENT(IN) :: knon + REAL, DIMENSION(klon), INTENT(IN) :: champ_in + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + +! Output arguments +!************************************************************************************* + REAL, DIMENSION(iim,jj_nb), INTENT(OUT) :: champ_out + +! Local variables +!************************************************************************************* + INTEGER :: i, ig + REAL, DIMENSION(klon) :: temp_omp + REAL, DIMENSION(klon_mpi) :: temp_mpi +!************************************************************************************* + +! Decompress from knon to klon + temp_omp = 0. + DO i = 1, knon + ig = knindex(i) + temp_omp(ig) = champ_in(i) + ENDDO + +! Transform from 1 dimension (klon) to 2 dimensions (iim,jj_nb) + CALL gather_omp(temp_omp,temp_mpi) + +!$OMP MASTER + CALL Grid1Dto2D_mpi(temp_mpi,champ_out) + + IF (is_north_pole) champ_out(:,1)=temp_mpi(1) + IF (is_south_pole) champ_out(:,jj_nb)=temp_mpi(klon) +!$OMP END MASTER + + END SUBROUTINE gath2cpl +! +!************************************************************************************* +! +END MODULE cpl_mod + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv30_routines.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv30_routines.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv30_routines.F (revision 1280) @@ -0,0 +1,3145 @@ +! +! $Header$ +! +c +c + SUBROUTINE cv30_param(nd,delt) + implicit none + +c------------------------------------------------------------ +c Set parameters for convectL for iflag_con = 3 +c------------------------------------------------------------ + +C +C *** PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE *** +C *** PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO *** +C *** PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. *** +C *** EFFICIENCY IS ASSUMED TO BE UNITY *** +C *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** +C *** SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** +C *** OF CLOUD *** +C +C [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA] +C *** ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) *** +C *** (BETA MUST BE LESS THAN OR EQUAL TO 1) *** +C +C *** DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** IT MUST BE LESS THAN 0 *** + +#include "cv30param.h" +#include "conema3.h" + + integer nd + real delt ! timestep (seconds) + +c noff: integer limit for convection (nd-noff) +c minorig: First level of convection + +c -- limit levels for convection: + + noff = 1 + minorig = 1 + nl=nd-noff + nlp=nl+1 + nlm=nl-1 + +c -- "microphysical" parameters: + + sigd = 0.01 + spfac = 0.15 + pbcrit = 150.0 + ptcrit = 500.0 +cIM cf. FH epmax = 0.993 + + omtrain = 45.0 ! used also for snow (no disctinction rain/snow) + +c -- misc: + + dtovsh = -0.2 ! dT for overshoot + dpbase = -40. ! definition cloud base (400m above LCL) + dttrig = 5. ! (loose) condition for triggering + +c -- rate of approach to quasi-equilibrium: + + dtcrit = -2.0 + tau = 8000. + beta = 1.0 - delt/tau + alpha = 1.5E-3 * delt/tau +c increase alpha to compensate W decrease: + alpha = alpha*1.5 + +c -- interface cloud parameterization: + + delta=0.01 ! cld + +c -- interface with boundary-layer (gust factor): (sb) + + betad=10.0 ! original value (from convect 4.3) + + return + end + + SUBROUTINE cv30_prelim(len,nd,ndp1,t,q,p,ph + : ,lv,cpn,tv,gz,h,hm,th) + implicit none + +!===================================================================== +! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY +! "ori": from convect4.3 (vectorized) +! "convect3": to be exactly consistent with convect3 +!===================================================================== + +c inputs: + integer len, nd, ndp1 + real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1) + +c outputs: + real lv(len,nd), cpn(len,nd), tv(len,nd) + real gz(len,nd), h(len,nd), hm(len,nd) + real th(len,nd) + +c local variables: + integer k, i + real rdcp + real tvx,tvy ! convect3 + real cpx(len,nd) + +#include "cvthermo.h" +#include "cv30param.h" + + +c ori do 110 k=1,nlp + do 110 k=1,nl ! convect3 + do 100 i=1,len +cdebug lv(i,k)= lv0-clmcpv*(t(i,k)-t0) + lv(i,k)= lv0-clmcpv*(t(i,k)-273.15) + cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k) + cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k) +c ori tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1) + tv(i,k)=t(i,k)*(1.0+q(i,k)/eps-q(i,k)) + rdcp=(rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i,k) + th(i,k)=t(i,k)*(1000.0/p(i,k))**rdcp + 100 continue + 110 continue +c +c gz = phi at the full levels (same as p). +c + do 120 i=1,len + gz(i,1)=0.0 + 120 continue +c ori do 140 k=2,nlp + do 140 k=2,nl ! convect3 + do 130 i=1,len + tvx=t(i,k)*(1.+q(i,k)/eps-q(i,k)) !convect3 + tvy=t(i,k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3 + gz(i,k)=gz(i,k-1)+0.5*rrd*(tvx+tvy) !convect3 + & *(p(i,k-1)-p(i,k))/ph(i,k) !convect3 + +c ori gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k)) +c ori & *(p(i,k-1)-p(i,k))/ph(i,k) + 130 continue + 140 continue +c +c h = phi + cpT (dry static energy). +c hm = phi + cp(T-Tbase)+Lq +c +c ori do 170 k=1,nlp + do 170 k=1,nl ! convect3 + do 160 i=1,len + h(i,k)=gz(i,k)+cpn(i,k)*t(i,k) + hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k) + 160 continue + 170 continue + + return + end + + SUBROUTINE cv30_feed(len,nd,t,q,qs,p,ph,hm,gz + : ,nk,icb,icbmax,iflag,tnk,qnk,gznk,plcl) + implicit none + +C================================================================ +C Purpose: CONVECTIVE FEED +C +C Main differences with cv_feed: +C - ph added in input +C - here, nk(i)=minorig +C - icb defined differently (plcl compared with ph instead of p) +C +C Main differences with convect3: +C - we do not compute dplcldt and dplcldr of CLIFT anymore +C - values iflag different (but tests identical) +C - A,B explicitely defined (!...) +C================================================================ + +#include "cv30param.h" + +c inputs: + integer len, nd + real t(len,nd), q(len,nd), qs(len,nd), p(len,nd) + real hm(len,nd), gz(len,nd) + real ph(len,nd+1) + +c outputs: + integer iflag(len), nk(len), icb(len), icbmax + real tnk(len), qnk(len), gznk(len), plcl(len) + +c local variables: + integer i, k + integer ihmin(len) + real work(len) + real pnk(len), qsnk(len), rh(len), chi(len) + real A, B ! convect3 +cym + plcl=0.0 +c@ !------------------------------------------------------------------- +c@ ! --- Find level of minimum moist static energy +c@ ! --- If level of minimum moist static energy coincides with +c@ ! --- or is lower than minimum allowable parcel origin level, +c@ ! --- set iflag to 6. +c@ !------------------------------------------------------------------- +c@ +c@ do 180 i=1,len +c@ work(i)=1.0e12 +c@ ihmin(i)=nl +c@ 180 continue +c@ do 200 k=2,nlp +c@ do 190 i=1,len +c@ if((hm(i,k).lt.work(i)).and. +c@ & (hm(i,k).lt.hm(i,k-1)))then +c@ work(i)=hm(i,k) +c@ ihmin(i)=k +c@ endif +c@ 190 continue +c@ 200 continue +c@ do 210 i=1,len +c@ ihmin(i)=min(ihmin(i),nlm) +c@ if(ihmin(i).le.minorig)then +c@ iflag(i)=6 +c@ endif +c@ 210 continue +c@ c +c@ !------------------------------------------------------------------- +c@ ! --- Find that model level below the level of minimum moist static +c@ ! --- energy that has the maximum value of moist static energy +c@ !------------------------------------------------------------------- +c@ +c@ do 220 i=1,len +c@ work(i)=hm(i,minorig) +c@ nk(i)=minorig +c@ 220 continue +c@ do 240 k=minorig+1,nl +c@ do 230 i=1,len +c@ if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then +c@ work(i)=hm(i,k) +c@ nk(i)=k +c@ endif +c@ 230 continue +c@ 240 continue + +!------------------------------------------------------------------- +! --- Origin level of ascending parcels for convect3: +!------------------------------------------------------------------- + + do 220 i=1,len + nk(i)=minorig + 220 continue + +!------------------------------------------------------------------- +! --- Check whether parcel level temperature and specific humidity +! --- are reasonable +!------------------------------------------------------------------- + do 250 i=1,len + if( ( ( t(i,nk(i)).lt.250.0 ) + & .or.( q(i,nk(i)).le.0.0 ) ) +c@ & .or.( p(i,ihmin(i)).lt.400.0 ) ) + & .and. + & ( iflag(i).eq.0) ) iflag(i)=7 + 250 continue +!------------------------------------------------------------------- +! --- Calculate lifted condensation level of air at parcel origin level +! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980) +!------------------------------------------------------------------- + + A = 1669.0 ! convect3 + B = 122.0 ! convect3 + + do 260 i=1,len + + if (iflag(i).ne.7) then ! modif sb Jun7th 2002 + + tnk(i)=t(i,nk(i)) + qnk(i)=q(i,nk(i)) + gznk(i)=gz(i,nk(i)) + pnk(i)=p(i,nk(i)) + qsnk(i)=qs(i,nk(i)) +c + rh(i)=qnk(i)/qsnk(i) +c ori rh(i)=min(1.0,rh(i)) ! removed for convect3 +c ori chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i)) + chi(i)=tnk(i)/(A-B*rh(i)-tnk(i)) ! convect3 + plcl(i)=pnk(i)*(rh(i)**chi(i)) + if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0)) + & .and.(iflag(i).eq.0))iflag(i)=8 + + endif ! iflag=7 + + 260 continue + +!------------------------------------------------------------------- +! --- Calculate first level above lcl (=icb) +!------------------------------------------------------------------- + +c@ do 270 i=1,len +c@ icb(i)=nlm +c@ 270 continue +c@c +c@ do 290 k=minorig,nl +c@ do 280 i=1,len +c@ if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i))) +c@ & icb(i)=min(icb(i),k) +c@ 280 continue +c@ 290 continue +c@c +c@ do 300 i=1,len +c@ if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9 +c@ 300 continue + + do 270 i=1,len + icb(i)=nlm + 270 continue +c +c la modification consiste a comparer plcl a ph et non a p: +c icb est defini par : ph(icb)p(icb), then icbs=icb +c +c * the routine above computes tvp from minorig to icbs (included). +c +c * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1) +c must be known. This is the case if icbs=icb+1, but not if icbs=icb. +c +c * therefore, in the case icbs=icb, we compute tvp at level icb+1 +c (tvp at other levels will be computed in cv3_undilute2.F) +c + + do i=1,len + ticb(i)=t(i,icb(i)+1) + gzicb(i)=gz(i,icb(i)+1) + qsicb(i)=qs(i,icb(i)+1) + enddo + + do 460 i=1,len + tg=ticb(i) + qg=qsicb(i) ! convect3 +cdebug alv=lv0-clmcpv*(ticb(i)-t0) + alv=lv0-clmcpv*(ticb(i)-273.15) +c +c First iteration. +c +c ori s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) + s=cpd*(1.-qnk(i))+cl*qnk(i) ! convect3 + : +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3 + s=1./s +c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3 + tg=tg+s*(ah0(i)-ahg) +c ori tg=max(tg,35.0) +cdebug tc=tg-t0 + tc=tg-273.15 + denom=243.5+tc + denom=MAX(denom,1.0) ! convect3 +c ori if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) +c ori else +c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +c ori endif +c ori qg=eps*es/(p(i,icb(i))-es*(1.-eps)) + qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps)) +c +c Second iteration. +c + +c ori s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) +c ori s=1./s +c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3 + tg=tg+s*(ah0(i)-ahg) +c ori tg=max(tg,35.0) +cdebug tc=tg-t0 + tc=tg-273.15 + denom=243.5+tc + denom=MAX(denom,1.0) ! convect3 +c ori if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) +c ori else +c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +c ori end if +c ori qg=eps*es/(p(i,icb(i))-es*(1.-eps)) + qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps)) + + alv=lv0-clmcpv*(ticb(i)-273.15) + +c ori c approximation here: +c ori tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i) +c ori & -gz(i,icb(i))-alv*qg)/cpd + +c convect3: no approximation: + tp(i,icb(i)+1)=(ah0(i)-gz(i,icb(i)+1)-alv*qg) + : /(cpd+(cl-cpd)*qnk(i)) + +c ori clw(i,icb(i))=qnk(i)-qg +c ori clw(i,icb(i))=max(0.0,clw(i,icb(i))) + clw(i,icb(i)+1)=qnk(i)-qg + clw(i,icb(i)+1)=max(0.0,clw(i,icb(i)+1)) + + rg=qg/(1.-qnk(i)) +c ori tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi) +c convect3: (qg utilise au lieu du vrai mixing ratio rg) + tvp(i,icb(i)+1)=tp(i,icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing + + 460 continue + + return + end + + SUBROUTINE cv30_trigger(len,nd,icb,plcl,p,th,tv,tvp + o ,pbase,buoybase,iflag,sig,w0) + implicit none + +!------------------------------------------------------------------- +! --- TRIGGERING +! +! - computes the cloud base +! - triggering (crude in this version) +! - relaxation of sig and w0 when no convection +! +! Caution1: if no convection, we set iflag=4 +! (it used to be 0 in convect3) +! +! Caution2: at this stage, tvp (and thus buoy) are know up +! through icb only! +! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy +!------------------------------------------------------------------- + +#include "cv30param.h" + +c input: + integer len, nd + integer icb(len) + real plcl(len), p(len,nd) + real th(len,nd), tv(len,nd), tvp(len,nd) + +c output: + real pbase(len), buoybase(len) + +c input AND output: + integer iflag(len) + real sig(len,nd), w0(len,nd) + +c local variables: + integer i,k + real tvpbase, tvbase, tdif, ath, ath1 + +c +c *** set cloud base buoyancy at (plcl+dpbase) level buoyancy +c + do 100 i=1,len + pbase(i) = plcl(i) + dpbase + tvpbase = tvp(i,icb(i))*(pbase(i)-p(i,icb(i)+1)) + : /(p(i,icb(i))-p(i,icb(i)+1)) + : + tvp(i,icb(i)+1)*(p(i,icb(i))-pbase(i)) + : /(p(i,icb(i))-p(i,icb(i)+1)) + tvbase = tv(i,icb(i))*(pbase(i)-p(i,icb(i)+1)) + : /(p(i,icb(i))-p(i,icb(i)+1)) + : + tv(i,icb(i)+1)*(p(i,icb(i))-pbase(i)) + : /(p(i,icb(i))-p(i,icb(i)+1)) + buoybase(i) = tvpbase - tvbase +100 continue + +c +c *** make sure that column is dry adiabatic between the surface *** +c *** and cloud base, and that lifted air is positively buoyant *** +c *** at cloud base *** +c *** if not, return to calling program after resetting *** +c *** sig(i) and w0(i) *** +c + +c oct3 do 200 i=1,len +c oct3 +c oct3 tdif = buoybase(i) +c oct3 ath1 = th(i,1) +c oct3 ath = th(i,icb(i)-1) - dttrig +c oct3 +c oct3 if (tdif.lt.dtcrit .or. ath.gt.ath1) then +c oct3 do 60 k=1,nl +c oct3 sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif +c oct3 sig(i,k) = AMAX1(sig(i,k),0.0) +c oct3 w0(i,k) = beta*w0(i,k) +c oct3 60 continue +c oct3 iflag(i)=4 ! pour version vectorisee +c oct3c convect3 iflag(i)=0 +c oct3cccc return +c oct3 endif +c oct3 +c oct3200 continue + +c -- oct3: on reecrit la boucle 200 (pour la vectorisation) + + do 60 k=1,nl + do 200 i=1,len + + tdif = buoybase(i) + ath1 = th(i,1) + ath = th(i,icb(i)-1) - dttrig + + if (tdif.lt.dtcrit .or. ath.gt.ath1) then + sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif + sig(i,k) = AMAX1(sig(i,k),0.0) + w0(i,k) = beta*w0(i,k) + iflag(i)=4 ! pour version vectorisee +c convect3 iflag(i)=0 + endif + +200 continue + 60 continue + +c fin oct3 -- + + return + end + + SUBROUTINE cv30_compress( len,nloc,ncum,nd,ntra + : ,iflag1,nk1,icb1,icbs1 + : ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1 + : ,t1,q1,qs1,u1,v1,gz1,th1 + : ,tra1 + : ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 + : ,sig1,w01 + o ,iflag,nk,icb,icbs + o ,plcl,tnk,qnk,gznk,pbase,buoybase + o ,t,q,qs,u,v,gz,th + o ,tra + o ,h,lv,cpn,p,ph,tv,tp,tvp,clw + o ,sig,w0 ) + implicit none + +#include "cv30param.h" + +c inputs: + integer len,ncum,nd,ntra,nloc + integer iflag1(len),nk1(len),icb1(len),icbs1(len) + real plcl1(len),tnk1(len),qnk1(len),gznk1(len) + real pbase1(len),buoybase1(len) + real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd) + real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd) + real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd) + real tvp1(len,nd),clw1(len,nd) + real th1(len,nd) + real sig1(len,nd), w01(len,nd) + real tra1(len,nd,ntra) + +c outputs: +c en fait, on a nloc=len pour l'instant (cf cv_driver) + integer iflag(nloc),nk(nloc),icb(nloc),icbs(nloc) + real plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc) + real pbase(nloc),buoybase(nloc) + real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd) + real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd) + real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd) + real tvp(nloc,nd),clw(nloc,nd) + real th(nloc,nd) + real sig(nloc,nd), w0(nloc,nd) + real tra(nloc,nd,ntra) + +c local variables: + integer i,k,nn,j + + + do 110 k=1,nl+1 + nn=0 + do 100 i=1,len + if(iflag1(i).eq.0)then + nn=nn+1 + sig(nn,k)=sig1(i,k) + w0(nn,k)=w01(i,k) + t(nn,k)=t1(i,k) + q(nn,k)=q1(i,k) + qs(nn,k)=qs1(i,k) + u(nn,k)=u1(i,k) + v(nn,k)=v1(i,k) + gz(nn,k)=gz1(i,k) + h(nn,k)=h1(i,k) + lv(nn,k)=lv1(i,k) + cpn(nn,k)=cpn1(i,k) + p(nn,k)=p1(i,k) + ph(nn,k)=ph1(i,k) + tv(nn,k)=tv1(i,k) + tp(nn,k)=tp1(i,k) + tvp(nn,k)=tvp1(i,k) + clw(nn,k)=clw1(i,k) + th(nn,k)=th1(i,k) + endif + 100 continue + 110 continue + +c do 121 j=1,ntra +c do 111 k=1,nd +c nn=0 +c do 101 i=1,len +c if(iflag1(i).eq.0)then +c nn=nn+1 +c tra(nn,k,j)=tra1(i,k,j) +c endif +c 101 continue +c 111 continue +c 121 continue + + if (nn.ne.ncum) then + print*,'strange! nn not equal to ncum: ',nn,ncum + stop + endif + + nn=0 + do 150 i=1,len + if(iflag1(i).eq.0)then + nn=nn+1 + pbase(nn)=pbase1(i) + buoybase(nn)=buoybase1(i) + plcl(nn)=plcl1(i) + tnk(nn)=tnk1(i) + qnk(nn)=qnk1(i) + gznk(nn)=gznk1(i) + nk(nn)=nk1(i) + icb(nn)=icb1(i) + icbs(nn)=icbs1(i) + iflag(nn)=iflag1(i) + endif + 150 continue + + return + end + + SUBROUTINE cv30_undilute2(nloc,ncum,nd,icb,icbs,nk + : ,tnk,qnk,gznk,t,q,qs,gz + : ,p,h,tv,lv,pbase,buoybase,plcl + o ,inb,tp,tvp,clw,hp,ep,sigp,buoy) + implicit none + +C--------------------------------------------------------------------- +C Purpose: +C FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +C & +C COMPUTE THE PRECIPITATION EFFICIENCIES AND THE +C FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD +C & +C FIND THE LEVEL OF NEUTRAL BUOYANCY +C +C Main differences convect3/convect4: +C - icbs (input) is the first level above LCL (may differ from icb) +C - many minor differences in the iterations +C - condensed water not removed from tvp in convect3 +C - vertical profile of buoyancy computed here (use of buoybase) +C - the determination of inb is different +C - no inb1, only inb in output +C--------------------------------------------------------------------- + +#include "cvthermo.h" +#include "cv30param.h" +#include "conema3.h" + +c inputs: + integer ncum, nd, nloc + integer icb(nloc), icbs(nloc), nk(nloc) + real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd) + real p(nloc,nd) + real tnk(nloc), qnk(nloc), gznk(nloc) + real lv(nloc,nd), tv(nloc,nd), h(nloc,nd) + real pbase(nloc), buoybase(nloc), plcl(nloc) + +c outputs: + integer inb(nloc) + real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd) + real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd) + real buoy(nloc,nd) + +c local variables: + integer i, k + real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit + real by, defrac, pden + real ah0(nloc), cape(nloc), capem(nloc), byp(nloc) + logical lcape(nloc) + +!===================================================================== +! --- SOME INITIALIZATIONS +!===================================================================== + + do 170 k=1,nl + do 160 i=1,ncum + ep(i,k)=0.0 + sigp(i,k)=spfac + 160 continue + 170 continue + +!===================================================================== +! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +!===================================================================== +c +c --- The procedure is to solve the equation. +c cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. +c +c *** Calculate certain parcel quantities, including static energy *** +c +c + do 240 i=1,ncum + ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) +cdebug & +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i) + & +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i) + 240 continue +c +c +c *** Find lifted parcel quantities above cloud base *** +c +c + do 300 k=minorig+1,nl + do 290 i=1,ncum +c ori if(k.ge.(icb(i)+1))then + if(k.ge.(icbs(i)+1))then ! convect3 + tg=t(i,k) + qg=qs(i,k) +cdebug alv=lv0-clmcpv*(t(i,k)-t0) + alv=lv0-clmcpv*(t(i,k)-273.15) +c +c First iteration. +c +c ori s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) + s=cpd*(1.-qnk(i))+cl*qnk(i) ! convect3 + : +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3 + s=1./s +c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3 + tg=tg+s*(ah0(i)-ahg) +c ori tg=max(tg,35.0) +cdebug tc=tg-t0 + tc=tg-273.15 + denom=243.5+tc + denom=MAX(denom,1.0) ! convect3 +c ori if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) +c ori else +c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +c ori endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c +c Second iteration. +c +c ori s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) +c ori s=1./s +c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3 + tg=tg+s*(ah0(i)-ahg) +c ori tg=max(tg,35.0) +cdebug tc=tg-t0 + tc=tg-273.15 + denom=243.5+tc + denom=MAX(denom,1.0) ! convect3 +c ori if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) +c ori else +c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +c ori endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c +cdebug alv=lv0-clmcpv*(t(i,k)-t0) + alv=lv0-clmcpv*(t(i,k)-273.15) +c print*,'cpd dans convect2 ',cpd +c print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd' +c print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd + +c ori c approximation here: +c ori tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd + +c convect3: no approximation: + tp(i,k)=(ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i)) + + clw(i,k)=qnk(i)-qg + clw(i,k)=max(0.0,clw(i,k)) + rg=qg/(1.-qnk(i)) +c ori tvp(i,k)=tp(i,k)*(1.+rg*epsi) +c convect3: (qg utilise au lieu du vrai mixing ratio rg): + tvp(i,k)=tp(i,k)*(1.+qg/eps-qnk(i)) ! whole thing + endif + 290 continue + 300 continue +c +!===================================================================== +! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF +! --- PRECIPITATION FALLING OUTSIDE OF CLOUD +! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I) +!===================================================================== +c +c ori do 320 k=minorig+1,nl + do 320 k=1,nl ! convect3 + do 310 i=1,ncum + pden=ptcrit-pbcrit + ep(i,k)=(plcl(i)-p(i,k)-pbcrit)/pden*epmax + ep(i,k)=amax1(ep(i,k),0.0) + ep(i,k)=amin1(ep(i,k),epmax) + sigp(i,k)=spfac +c ori if(k.ge.(nk(i)+1))then +c ori tca=tp(i,k)-t0 +c ori if(tca.ge.0.0)then +c ori elacrit=elcrit +c ori else +c ori elacrit=elcrit*(1.0-tca/tlcrit) +c ori endif +c ori elacrit=max(elacrit,0.0) +c ori ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8) +c ori ep(i,k)=max(ep(i,k),0.0 ) +c ori ep(i,k)=min(ep(i,k),1.0 ) +c ori sigp(i,k)=sigs +c ori endif + 310 continue + 320 continue +c +!===================================================================== +! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL +! --- VIRTUAL TEMPERATURE +!===================================================================== +c +c dans convect3, tvp est calcule en une seule fois, et sans retirer +c l'eau condensee (~> reversible CAPE) +c +c ori do 340 k=minorig+1,nl +c ori do 330 i=1,ncum +c ori if(k.ge.(icb(i)+1))then +c ori tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k)) +c oric print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)' +c oric print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k) +c ori endif +c ori 330 continue +c ori 340 continue + +c ori do 350 i=1,ncum +c ori tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd +c ori 350 continue + + do 350 i=1,ncum ! convect3 + tp(i,nlp)=tp(i,nl) ! convect3 + 350 continue ! convect3 +c +c===================================================================== +c --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only): +c===================================================================== + +c-- this is for convect3 only: + +c first estimate of buoyancy: + + do 500 i=1,ncum + do 501 k=1,nl + buoy(i,k)=tvp(i,k)-tv(i,k) + 501 continue + 500 continue + +c set buoyancy=buoybase for all levels below base +c for safety, set buoy(icb)=buoybase + + do 505 i=1,ncum + do 506 k=1,nl + if((k.ge.icb(i)).and.(k.le.nl).and.(p(i,k).ge.pbase(i)))then + buoy(i,k)=buoybase(i) + endif + 506 continue +cIM cf. CRio/JYG 270807 buoy(icb(i),k)=buoybase(i) + buoy(i,icb(i))=buoybase(i) + 505 continue + +c-- end convect3 + +c===================================================================== +c --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S +c --- LEVEL OF NEUTRAL BUOYANCY +c===================================================================== +c +c-- this is for convect3 only: + + do 510 i=1,ncum + inb(i)=nl-1 + 510 continue + + do 530 i=1,ncum + do 535 k=1,nl-1 + if ((k.ge.icb(i)).and.(buoy(i,k).lt.dtovsh)) then + inb(i)=MIN(inb(i),k) + endif + 535 continue + 530 continue + +c-- end convect3 + +c ori do 510 i=1,ncum +c ori cape(i)=0.0 +c ori capem(i)=0.0 +c ori inb(i)=icb(i)+1 +c ori inb1(i)=inb(i) +c ori 510 continue +c +c Originial Code +c +c do 530 k=minorig+1,nl-1 +c do 520 i=1,ncum +c if(k.ge.(icb(i)+1))then +c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c cape(i)=cape(i)+by +c if(by.ge.0.0)inb1(i)=k+1 +c if(cape(i).gt.0.0)then +c inb(i)=k+1 +c capem(i)=cape(i) +c endif +c endif +c520 continue +c530 continue +c do 540 i=1,ncum +c byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl) +c cape(i)=capem(i)+byp +c defrac=capem(i)-cape(i) +c defrac=max(defrac,0.001) +c frac(i)=-cape(i)/defrac +c frac(i)=min(frac(i),1.0) +c frac(i)=max(frac(i),0.0) +c540 continue +c +c K Emanuel fix +c +c call zilch(byp,ncum) +c do 530 k=minorig+1,nl-1 +c do 520 i=1,ncum +c if(k.ge.(icb(i)+1))then +c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c cape(i)=cape(i)+by +c if(by.ge.0.0)inb1(i)=k+1 +c if(cape(i).gt.0.0)then +c inb(i)=k+1 +c capem(i)=cape(i) +c byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c endif +c endif +c520 continue +c530 continue +c do 540 i=1,ncum +c inb(i)=max(inb(i),inb1(i)) +c cape(i)=capem(i)+byp(i) +c defrac=capem(i)-cape(i) +c defrac=max(defrac,0.001) +c frac(i)=-cape(i)/defrac +c frac(i)=min(frac(i),1.0) +c frac(i)=max(frac(i),0.0) +c540 continue +c +c J Teixeira fix +c +c ori call zilch(byp,ncum) +c ori do 515 i=1,ncum +c ori lcape(i)=.true. +c ori 515 continue +c ori do 530 k=minorig+1,nl-1 +c ori do 520 i=1,ncum +c ori if(cape(i).lt.0.0)lcape(i)=.false. +c ori if((k.ge.(icb(i)+1)).and.lcape(i))then +c ori by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c ori byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c ori cape(i)=cape(i)+by +c ori if(by.ge.0.0)inb1(i)=k+1 +c ori if(cape(i).gt.0.0)then +c ori inb(i)=k+1 +c ori capem(i)=cape(i) +c ori endif +c ori endif +c ori 520 continue +c ori 530 continue +c ori do 540 i=1,ncum +c ori cape(i)=capem(i)+byp(i) +c ori defrac=capem(i)-cape(i) +c ori defrac=max(defrac,0.001) +c ori frac(i)=-cape(i)/defrac +c ori frac(i)=min(frac(i),1.0) +c ori frac(i)=max(frac(i),0.0) +c ori 540 continue +c +c===================================================================== +c --- CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL +c===================================================================== +c +cym do i=1,ncum*nlp +cym hp(i,1)=h(i,1) +cym enddo + + do k=1,nlp + do i=1,ncum + hp(i,k)=h(i,k) + enddo + enddo + + do 600 k=minorig+1,nl + do 590 i=1,ncum + if((k.ge.icb(i)).and.(k.le.inb(i)))then + hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k) + endif + 590 continue + 600 continue + + return + end + + SUBROUTINE cv30_closure(nloc,ncum,nd,icb,inb + : ,pbase,p,ph,tv,buoy + o ,sig,w0,cape,m) + implicit none + +!=================================================================== +! --- CLOSURE OF CONVECT3 +! +! vectorization: S. Bony +!=================================================================== + +#include "cvthermo.h" +#include "cv30param.h" + +c input: + integer ncum, nd, nloc + integer icb(nloc), inb(nloc) + real pbase(nloc) + real p(nloc,nd), ph(nloc,nd+1) + real tv(nloc,nd), buoy(nloc,nd) + +c input/output: + real sig(nloc,nd), w0(nloc,nd) + +c output: + real cape(nloc) + real m(nloc,nd) + +c local variables: + integer i, j, k, icbmax + real deltap, fac, w, amu + real dtmin(nloc,nd), sigold(nloc,nd) + + +c ------------------------------------------------------- +c -- Initialization +c ------------------------------------------------------- + + do k=1,nl + do i=1,ncum + m(i,k)=0.0 + enddo + enddo + +c ------------------------------------------------------- +c -- Reset sig(i) and w0(i) for i>inb and i qnk(il) +! - vectorisation de la partie normalisation des flux (do 789...) +!--------------------------------------------------------------------- + +#include "cvthermo.h" +#include "cv30param.h" + +c inputs: + integer ncum, nd, na, ntra, nloc + integer icb(nloc), inb(nloc), nk(nloc) + real sig(nloc,nd) + real qnk(nloc) + real ph(nloc,nd+1) + real t(nloc,nd), rr(nloc,nd), rs(nloc,nd) + real u(nloc,nd), v(nloc,nd) + real tra(nloc,nd,ntra) ! input of convect3 + real lv(nloc,na), h(nloc,na), hp(nloc,na) + real tv(nloc,na), tvp(nloc,na), ep(nloc,na), clw(nloc,na) + real m(nloc,na) ! input of convect3 + +c outputs: + real ment(nloc,na,na), qent(nloc,na,na) + real uent(nloc,na,na), vent(nloc,na,na) + real sij(nloc,na,na), elij(nloc,na,na) + real traent(nloc,nd,nd,ntra) + real ments(nloc,nd,nd), qents(nloc,nd,nd) + real sigij(nloc,nd,nd) + +c local variables: + integer i, j, k, il, im, jm + integer num1, num2 + integer nent(nloc,na) + real rti, bf2, anum, denom, dei, altem, cwat, stemp, qp + real alt, smid, sjmin, sjmax, delp, delm + real asij(nloc), smax(nloc), scrit(nloc) + real asum(nloc,nd),bsum(nloc,nd),csum(nloc,nd) + real wgh + real zm(nloc,na) + logical lwork(nloc) + +c===================================================================== +c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS +c===================================================================== + +c ori do 360 i=1,ncum*nlp + do 361 j=1,nl + do 360 i=1,ncum + nent(i,j)=0 +c in convect3, m is computed in cv3_closure +c ori m(i,1)=0.0 + 360 continue + 361 continue + +c ori do 400 k=1,nlp +c ori do 390 j=1,nlp + do 400 j=1,nl + do 390 k=1,nl + do 385 i=1,ncum + qent(i,k,j)=rr(i,j) + uent(i,k,j)=u(i,j) + vent(i,k,j)=v(i,j) + elij(i,k,j)=0.0 +cym ment(i,k,j)=0.0 +cym sij(i,k,j)=0.0 + 385 continue + 390 continue + 400 continue + +cym + ment(1:ncum,1:nd,1:nd)=0.0 + sij(1:ncum,1:nd,1:nd)=0.0 + +c do k=1,ntra +c do j=1,nd ! instead nlp +c do i=1,nd ! instead nlp +c do il=1,ncum +c traent(il,i,j,k)=tra(il,j,k) +c enddo +c enddo +c enddo +c enddo + zm(:,:)=0. + +c===================================================================== +c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING +c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING +c --- FRACTION (sij) +c===================================================================== + + do 750 i=minorig+1, nl + + do 710 j=minorig,nl + do 700 il=1,ncum + if( (i.ge.icb(il)).and.(i.le.inb(il)).and. + : (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then + + rti=rr(il,1)-ep(il,i)*clw(il,i) + bf2=1.+lv(il,j)*lv(il,j)*rs(il,j)/(rrv*t(il,j)*t(il,j)*cpd) + anum=h(il,j)-hp(il,i)+(cpv-cpd)*t(il,j)*(rti-rr(il,j)) + denom=h(il,i)-hp(il,i)+(cpd-cpv)*(rr(il,i)-rti)*t(il,j) + dei=denom + if(abs(dei).lt.0.01)dei=0.01 + sij(il,i,j)=anum/dei + sij(il,i,i)=1.0 + altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j) + altem=altem/bf2 + cwat=clw(il,j)*(1.-ep(il,j)) + stemp=sij(il,i,j) + if((stemp.lt.0.0.or.stemp.gt.1.0.or.altem.gt.cwat) + : .and.j.gt.i)then + anum=anum-lv(il,j)*(rti-rs(il,j)-cwat*bf2) + denom=denom+lv(il,j)*(rr(il,i)-rti) + if(abs(denom).lt.0.01)denom=0.01 + sij(il,i,j)=anum/denom + altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j) + altem=altem-(bf2-1.)*cwat + end if + if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then + qent(il,i,j)=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti + uent(il,i,j)=sij(il,i,j)*u(il,i)+(1.-sij(il,i,j))*u(il,nk(il)) + vent(il,i,j)=sij(il,i,j)*v(il,i)+(1.-sij(il,i,j))*v(il,nk(il)) +c!!! do k=1,ntra +c!!! traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k) +c!!! : +(1.-sij(il,i,j))*tra(il,nk(il),k) +c!!! end do + elij(il,i,j)=altem + elij(il,i,j)=amax1(0.0,elij(il,i,j)) + ment(il,i,j)=m(il,i)/(1.-sij(il,i,j)) + nent(il,i)=nent(il,i)+1 + end if + sij(il,i,j)=amax1(0.0,sij(il,i,j)) + sij(il,i,j)=amin1(1.0,sij(il,i,j)) + endif ! new + 700 continue + 710 continue + +c do k=1,ntra +c do j=minorig,nl +c do il=1,ncum +c if( (i.ge.icb(il)).and.(i.le.inb(il)).and. +c : (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then +c traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k) +c : +(1.-sij(il,i,j))*tra(il,nk(il),k) +c endif +c enddo +c enddo +c enddo + +c +c *** if no air can entrain at level i assume that updraft detrains *** +c *** at that level and calculate detrained air flux and properties *** +c + +c@ do 170 i=icb(il),inb(il) + + do 740 il=1,ncum + if ((i.ge.icb(il)).and.(i.le.inb(il)).and.(nent(il,i).eq.0)) then +c@ if(nent(il,i).eq.0)then + ment(il,i,i)=m(il,i) + qent(il,i,i)=rr(il,nk(il))-ep(il,i)*clw(il,i) + uent(il,i,i)=u(il,nk(il)) + vent(il,i,i)=v(il,nk(il)) + elij(il,i,i)=clw(il,i) +cMAF sij(il,i,i)=1.0 + sij(il,i,i)=0.0 + end if + 740 continue + 750 continue + +c do j=1,ntra +c do i=minorig+1,nl +c do il=1,ncum +c if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then +c traent(il,i,i,j)=tra(il,nk(il),j) +c endif +c enddo +c enddo +c enddo + + do 100 j=minorig,nl + do 101 i=minorig,nl + do 102 il=1,ncum + if ((j.ge.(icb(il)-1)).and.(j.le.inb(il)) + : .and.(i.ge.icb(il)).and.(i.le.inb(il)))then + sigij(il,i,j)=sij(il,i,j) + endif + 102 continue + 101 continue + 100 continue +c@ enddo + +c@170 continue + +c===================================================================== +c --- NORMALIZE ENTRAINED AIR MASS FLUXES +c --- TO REPRESENT EQUAL PROBABILITIES OF MIXING +c===================================================================== + +cym call zilch(asum,ncum*nd) +cym call zilch(bsum,ncum*nd) +cym call zilch(csum,ncum*nd) + call zilch(asum,nloc*nd) + call zilch(csum,nloc*nd) + call zilch(csum,nloc*nd) + + do il=1,ncum + lwork(il) = .FALSE. + enddo + + DO 789 i=minorig+1,nl + + num1=0 + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) ) num1=num1+1 + enddo + if (num1.le.0) goto 789 + + + do 781 il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) ) then + lwork(il)=(nent(il,i).ne.0) + qp=rr(il,1)-ep(il,i)*clw(il,i) + anum=h(il,i)-hp(il,i)-lv(il,i)*(qp-rs(il,i)) + : +(cpv-cpd)*t(il,i)*(qp-rr(il,i)) + denom=h(il,i)-hp(il,i)+lv(il,i)*(rr(il,i)-qp) + : +(cpd-cpv)*t(il,i)*(rr(il,i)-qp) + if(abs(denom).lt.0.01)denom=0.01 + scrit(il)=anum/denom + alt=qp-rs(il,i)+scrit(il)*(rr(il,i)-qp) + if(scrit(il).le.0.0.or.alt.le.0.0)scrit(il)=1.0 + smax(il)=0.0 + asij(il)=0.0 + endif +781 continue + + do 175 j=nl,minorig,-1 + + num2=0 + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) num2=num2+1 + enddo + if (num2.le.0) goto 175 + + do 782 il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) then + + if(sij(il,i,j).gt.1.0e-16.and.sij(il,i,j).lt.0.95)then + wgh=1.0 + if(j.gt.i)then + sjmax=amax1(sij(il,i,j+1),smax(il)) + sjmax=amin1(sjmax,scrit(il)) + smax(il)=amax1(sij(il,i,j),smax(il)) + sjmin=amax1(sij(il,i,j-1),smax(il)) + sjmin=amin1(sjmin,scrit(il)) + if(sij(il,i,j).lt.(smax(il)-1.0e-16))wgh=0.0 + smid=amin1(sij(il,i,j),scrit(il)) + else + sjmax=amax1(sij(il,i,j+1),scrit(il)) + smid=amax1(sij(il,i,j),scrit(il)) + sjmin=0.0 + if(j.gt.1)sjmin=sij(il,i,j-1) + sjmin=amax1(sjmin,scrit(il)) + endif + delp=abs(sjmax-smid) + delm=abs(sjmin-smid) + asij(il)=asij(il)+wgh*(delp+delm) + ment(il,i,j)=ment(il,i,j)*(delp+delm)*wgh + endif + endif +782 continue + +175 continue + + do il=1,ncum + if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then + asij(il)=amax1(1.0e-16,asij(il)) + asij(il)=1.0/asij(il) + asum(il,i)=0.0 + bsum(il,i)=0.0 + csum(il,i)=0.0 + endif + enddo + + do 180 j=minorig,nl + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then + ment(il,i,j)=ment(il,i,j)*asij(il) + endif + enddo +180 continue + + do 190 j=minorig,nl + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then + asum(il,i)=asum(il,i)+ment(il,i,j) + ment(il,i,j)=ment(il,i,j)*sig(il,j) + bsum(il,i)=bsum(il,i)+ment(il,i,j) + endif + enddo +190 continue + + do il=1,ncum + if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then + bsum(il,i)=amax1(bsum(il,i),1.0e-16) + bsum(il,i)=1.0/bsum(il,i) + endif + enddo + + do 195 j=minorig,nl + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then + ment(il,i,j)=ment(il,i,j)*asum(il,i)*bsum(il,i) + endif + enddo +195 continue + + do 197 j=minorig,nl + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then + csum(il,i)=csum(il,i)+ment(il,i,j) + endif + enddo +197 continue + + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. csum(il,i).lt.m(il,i) ) then + nent(il,i)=0 + ment(il,i,i)=m(il,i) + qent(il,i,i)=rr(il,1)-ep(il,i)*clw(il,i) + uent(il,i,i)=u(il,nk(il)) + vent(il,i,i)=v(il,nk(il)) + elij(il,i,i)=clw(il,i) +cMAF sij(il,i,i)=1.0 + sij(il,i,i)=0.0 + endif + enddo ! il + +c do j=1,ntra +c do il=1,ncum +c if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) +c : .and. csum(il,i).lt.m(il,i) ) then +c traent(il,i,i,j)=tra(il,nk(il),j) +c endif +c enddo +c enddo +789 continue +c +c MAF: renormalisation de MENT + do jm=1,nd + do im=1,nd + do il=1,ncum + zm(il,im)=zm(il,im)+(1.-sij(il,im,jm))*ment(il,im,jm) + end do + end do + end do +c + do jm=1,nd + do im=1,nd + do il=1,ncum + if(zm(il,im).ne.0.) then + ment(il,im,jm)=ment(il,im,jm)*m(il,im)/zm(il,im) + endif + end do + end do + end do +c + do jm=1,nd + do im=1,nd + do 999 il=1,ncum + qents(il,im,jm)=qent(il,im,jm) + ments(il,im,jm)=ment(il,im,jm) +999 continue + enddo + enddo + + return + end + + + SUBROUTINE cv30_unsat(nloc,ncum,nd,na,ntra,icb,inb + : ,t,rr,rs,gz,u,v,tra,p,ph + : ,th,tv,lv,cpn,ep,sigp,clw + : ,m,ment,elij,delt,plcl + : ,mp,rp,up,vp,trap,wt,water,evap,b) + implicit none + + +#include "cvthermo.h" +#include "cv30param.h" +#include "cvflag.h" + +c inputs: + integer ncum, nd, na, ntra, nloc + integer icb(nloc), inb(nloc) + real delt, plcl(nloc) + real t(nloc,nd), rr(nloc,nd), rs(nloc,nd) + real u(nloc,nd), v(nloc,nd) + real tra(nloc,nd,ntra) + real p(nloc,nd), ph(nloc,nd+1) + real th(nloc,na), gz(nloc,na) + real lv(nloc,na), ep(nloc,na), sigp(nloc,na), clw(nloc,na) + real cpn(nloc,na), tv(nloc,na) + real m(nloc,na), ment(nloc,na,na), elij(nloc,na,na) + +c outputs: + real mp(nloc,na), rp(nloc,na), up(nloc,na), vp(nloc,na) + real water(nloc,na), evap(nloc,na), wt(nloc,na) + real trap(nloc,na,ntra) + real b(nloc,na) + +c local variables + integer i,j,k,il,num1 + real tinv, delti + real awat, afac, afac1, afac2, bfac + real pr1, pr2, sigt, b6, c6, revap, tevap, delth + real amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf + real ampmax + real lvcp(nloc,na) + real wdtrain(nloc) + logical lwork(nloc) + + +c------------------------------------------------------ + + delti = 1./delt + tinv=1./3. + + mp(:,:)=0. + + do i=1,nl + do il=1,ncum + mp(il,i)=0.0 + rp(il,i)=rr(il,i) + up(il,i)=u(il,i) + vp(il,i)=v(il,i) + wt(il,i)=0.001 + water(il,i)=0.0 + evap(il,i)=0.0 + b(il,i)=0.0 + lvcp(il,i)=lv(il,i)/cpn(il,i) + enddo + enddo + +c do k=1,ntra +c do i=1,nd +c do il=1,ncum +c trap(il,i,k)=tra(il,i,k) +c enddo +c enddo +c enddo + +c +c *** check whether ep(inb)=0, if so, skip precipitating *** +c *** downdraft calculation *** +c + + do il=1,ncum + lwork(il)=.TRUE. + if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE. + enddo + + call zilch(wdtrain,ncum) + + DO 400 i=nl+1,1,-1 + + num1=0 + do il=1,ncum + if ( i.le.inb(il) .and. lwork(il) ) num1=num1+1 + enddo + if (num1.le.0) goto 400 + +c +c *** integrate liquid water equation to find condensed water *** +c *** and condensed water flux *** +c + +c +c *** begin downdraft loop *** +c + +c +c *** calculate detrained precipitation *** +c + do il=1,ncum + if (i.le.inb(il) .and. lwork(il)) then + if (cvflag_grav) then + wdtrain(il)=grav*ep(il,i)*m(il,i)*clw(il,i) + else + wdtrain(il)=10.0*ep(il,i)*m(il,i)*clw(il,i) + endif + endif + enddo + + if(i.gt.1)then + do 320 j=1,i-1 + do il=1,ncum + if (i.le.inb(il) .and. lwork(il)) then + awat=elij(il,j,i)-(1.-ep(il,i))*clw(il,i) + awat=amax1(awat,0.0) + if (cvflag_grav) then + wdtrain(il)=wdtrain(il)+grav*awat*ment(il,j,i) + else + wdtrain(il)=wdtrain(il)+10.0*awat*ment(il,j,i) + endif + endif + enddo +320 continue + endif + +c +c *** find rain water and evaporation using provisional *** +c *** estimates of rp(i)and rp(i-1) *** +c + + do 999 il=1,ncum + + if (i.le.inb(il) .and. lwork(il)) then + + wt(il,i)=45.0 + + if(i.lt.inb(il))then + rp(il,i)=rp(il,i+1) + : +(cpd*(t(il,i+1)-t(il,i))+gz(il,i+1)-gz(il,i))/lv(il,i) + rp(il,i)=0.5*(rp(il,i)+rr(il,i)) + endif + rp(il,i)=amax1(rp(il,i),0.0) + rp(il,i)=amin1(rp(il,i),rs(il,i)) + rp(il,inb(il))=rr(il,inb(il)) + + if(i.eq.1)then + afac=p(il,1)*(rs(il,1)-rp(il,1))/(1.0e4+2000.0*p(il,1)*rs(il,1)) + else + rp(il,i-1)=rp(il,i) + : +(cpd*(t(il,i)-t(il,i-1))+gz(il,i)-gz(il,i-1))/lv(il,i) + rp(il,i-1)=0.5*(rp(il,i-1)+rr(il,i-1)) + rp(il,i-1)=amin1(rp(il,i-1),rs(il,i-1)) + rp(il,i-1)=amax1(rp(il,i-1),0.0) + afac1=p(il,i)*(rs(il,i)-rp(il,i))/(1.0e4+2000.0*p(il,i)*rs(il,i)) + afac2=p(il,i-1)*(rs(il,i-1)-rp(il,i-1)) + : /(1.0e4+2000.0*p(il,i-1)*rs(il,i-1)) + afac=0.5*(afac1+afac2) + endif + if(i.eq.inb(il))afac=0.0 + afac=amax1(afac,0.0) + bfac=1./(sigd*wt(il,i)) +c +cjyg1 +ccc sigt=1.0 +ccc if(i.ge.icb)sigt=sigp(i) +c prise en compte de la variation progressive de sigt dans +c les couches icb et icb-1: +c pour plclph(i), pr1=1 & pr2=0 +c pour ph(i+1)9)WRITE(lunout,*) & + & pdf, Qmix(ff), aire, ff + ff=ff+df + enddo +c +c do ff=0.0+df,1.0 - 2.*df,df + ff=df + dowhile ( ff .le. 1.0 - 2.*df ) + pdf = (Qmix(ff+df)- Qmix(ff)) * (1.-ff) / df + sigma = sigma+pdf*(ff - mu)*(ff - mu)*df + ff=ff+df + enddo + sigma = sqrt(sigma) +c + if (abs(aire-1.0) .gt. 0.02) then + print *,'WARNING:: AREA OF MIXING PDF IS::', aire + stop + else + print *,'Area, mean & std deviation are ::', aire,mu,sigma + endif + endif ! (iflag_mix .gt. 0) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv3_mixscale.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv3_mixscale.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv3_mixscale.F (revision 1280) @@ -0,0 +1,29 @@ + SUBROUTINE cv3_mixscale(nloc,ncum,na,ment,m) +*************************************************************** +* * +* CV3_MIXSCALE * +* * +* * +* written by : Jean-Yves Grandpeix, 30/05/2003, 16.34.37 * +* modified by : * +*************************************************************** +* + implicit none + +#include "cv3param.h" + + integer nloc,ncum,na + integer i,j,il + real ment(nloc,na,na),m(nloc,na) +c + do 100 j=1,nl + do 101 i=1,nl + do 102 il=1,ncum + ment(il,i,j) = m(il,i)*ment(il,i,j) +102 continue +101 continue +100 continue + +c + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv3_routines.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv3_routines.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv3_routines.F (revision 1280) @@ -0,0 +1,3497 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/cv3_routines.F,v 1.16 2008-11-06 16:29:35 lmdzadmin Exp $ +! +c +c + SUBROUTINE cv3_param(nd,delt) + implicit none + +c------------------------------------------------------------ +c Set parameters for convectL for iflag_con = 3 +c------------------------------------------------------------ + +C +C *** PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE *** +C *** PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO *** +C *** PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. *** +C *** EFFICIENCY IS ASSUMED TO BE UNITY *** +C *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** +C *** SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** +C *** OF CLOUD *** +C +C [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA] +C *** ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) *** +C *** (BETA MUST BE LESS THAN OR EQUAL TO 1) *** +C +C *** DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** IT MUST BE LESS THAN 0 *** + +#include "cv3param.h" +#include "conema3.h" + + integer nd + real delt ! timestep (seconds) + +c noff: integer limit for convection (nd-noff) +c minorig: First level of convection + +c -- limit levels for convection: + + noff = 1 + minorig = 1 + nl=nd-noff + nlp=nl+1 + nlm=nl-1 + +c -- "microphysical" parameters: + sigdz=0.01 +c sigd=0.003 +c sigd = 0.01 +cCR:test sur la fraction des descentes precipitantes + spfac = 0.15 + pbcrit = 150.0 + ptcrit = 500.0 +cIM lu dans physiq.def via conf_phys.F90 epmax = 0.993 + + omtrain = 45.0 ! used also for snow (no disctinction rain/snow) + +c -- misc: + + dtovsh = -0.2 ! dT for overshoot + dpbase = -40. ! definition cloud base (400m above LCL) +ccc dttrig = 5. ! (loose) condition for triggering + dttrig = 10. ! (loose) condition for triggering + +c -- rate of approach to quasi-equilibrium: + + dtcrit = -2.0 +c dtcrit = -5.0 +c tau = 3000. +cc tau = 1800. +c tau= 2800. + tau=8000. + beta = 1.0 - delt/tau + alpha1 = 1.5e-3 + alpha = alpha1 * delt/tau +c increase alpha to compensate W decrease: + alpha = alpha*1.5 + +c -- interface cloud parameterization: + + delta=0.01 ! cld + +c -- interface with boundary-layer (gust factor): (sb) + + betad=10.0 ! original value (from convect 4.3) + + return + end + + SUBROUTINE cv3_prelim(len,nd,ndp1,t,q,p,ph + : ,lv,cpn,tv,gz,h,hm,th) + implicit none + +!===================================================================== +! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY +! "ori": from convect4.3 (vectorized) +! "convect3": to be exactly consistent with convect3 +!===================================================================== + +c inputs: + integer len, nd, ndp1 + real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1) + +c outputs: + real lv(len,nd), cpn(len,nd), tv(len,nd) + real gz(len,nd), h(len,nd), hm(len,nd) + real th(len,nd) + +c local variables: + integer k, i + real rdcp + real tvx,tvy ! convect3 + real cpx(len,nd) + +#include "cvthermo.h" +#include "cv3param.h" + + +c ori do 110 k=1,nlp +! abderr do 110 k=1,nl ! convect3 + do 110 k=1,nlp + + do 100 i=1,len +cdebug lv(i,k)= lv0-clmcpv*(t(i,k)-t0) + lv(i,k)= lv0-clmcpv*(t(i,k)-273.15) + cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k) + cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k) +c ori tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1) + tv(i,k)=t(i,k)*(1.0+q(i,k)/eps-q(i,k)) + rdcp=(rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i,k) + th(i,k)=t(i,k)*(1000.0/p(i,k))**rdcp + 100 continue + 110 continue +c +c gz = phi at the full levels (same as p). +c + do 120 i=1,len + gz(i,1)=0.0 + 120 continue +c ori do 140 k=2,nlp + do 140 k=2,nl ! convect3 + do 130 i=1,len + tvx=t(i,k)*(1.+q(i,k)/eps-q(i,k)) !convect3 + tvy=t(i,k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3 + gz(i,k)=gz(i,k-1)+0.5*rrd*(tvx+tvy) !convect3 + & *(p(i,k-1)-p(i,k))/ph(i,k) !convect3 +c +cc print *,' gz(',k,')',gz(i,k),' tvx',tvx,' tvy ',tvy +c +c ori gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k)) +c ori & *(p(i,k-1)-p(i,k))/ph(i,k) + 130 continue + 140 continue +c +c h = phi + cpT (dry static energy). +c hm = phi + cp(T-Tbase)+Lq +c +c ori do 170 k=1,nlp + do 170 k=1,nl ! convect3 + do 160 i=1,len + h(i,k)=gz(i,k)+cpn(i,k)*t(i,k) + hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k) + 160 continue + 170 continue + + return + end + + SUBROUTINE cv3_feed(len,nd,t,q,u,v,p,ph,hm,gz + : ,p1feed,p2feed,wght + : ,wghti,tnk,thnk,qnk,qsnk,unk,vnk + : ,cpnk,hnk,nk,icb,icbmax,iflag,gznk,plcl) + implicit none + +C================================================================ +C Purpose: CONVECTIVE FEED +C +C Main differences with cv_feed: +C - ph added in input +C - here, nk(i)=minorig +C - icb defined differently (plcl compared with ph instead of p) +C +C Main differences with convect3: +C - we do not compute dplcldt and dplcldr of CLIFT anymore +C - values iflag different (but tests identical) +C - A,B explicitely defined (!...) +C================================================================ + +#include "cv3param.h" +#include "cvthermo.h" + +c inputs: + integer len, nd + real t(len,nd), q(len,nd), p(len,nd) + real u(len,nd), v(len,nd) + real hm(len,nd), gz(len,nd) + real ph(len,nd+1) + real p1feed(len) +c, wght(len) + real wght(nd) +c input-output + real p2feed(len) +c outputs: + integer iflag(len), nk(len), icb(len), icbmax +c real wghti(len) + real wghti(len,nd) + real tnk(len), thnk(len), qnk(len), qsnk(len) + real unk(len), vnk(len) + real cpnk(len), hnk(len), gznk(len) + real plcl(len) + +c local variables: + integer i, k, iter, niter + integer ihmin(len) + real work(len) + real pup(len),plo(len),pfeed(len) + real plclup(len),plcllo(len),plclfeed(len) + real posit(len) + logical nocond(len) +! +!------------------------------------------------------------------- +! --- Origin level of ascending parcels for convect3: +!------------------------------------------------------------------- + + do 220 i=1,len + nk(i)=minorig + gznk(i)=gz(i,nk(i)) + 220 continue +! +!------------------------------------------------------------------- +! --- Adjust feeding layer thickness so that lifting up to the top of +! --- the feeding layer does not induce condensation (i.e. so that +! --- plcl < p2feed). +! --- Method : iterative secant method. +!------------------------------------------------------------------- +! +c 1- First bracketing of the solution : ph(nk+1), p2feed +c +c 1.a- LCL associated to p2feed + do i = 1,len + pup(i) = p2feed(i) + enddo + call cv3_vertmix(len,nd,iflag,p1feed,pup,p,ph + i ,t,q,u,v,wght + o ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plclup) +c 1.b- LCL associated to ph(nk+1) + do i = 1,len + plo(i) = ph(i,nk(i)+1) + enddo + call cv3_vertmix(len,nd,iflag,p1feed,plo,p,ph + i ,t,q,u,v,wght + o ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plcllo) +c 2- Iterations + niter = 5 + do iter = 1,niter + do i = 1,len + plcllo(i) = min(plo(i),plcllo(i)) + plclup(i) = max(pup(i),plclup(i)) + nocond(i) = plclup(i).le.pup(i) + enddo + do i = 1,len + if(nocond(i)) then + pfeed(i)=pup(i) + else + pfeed(i) = (pup(i)*(plo(i)-plcllo(i))+ + : plo(i)*(plclup(i)-pup(i)))/ + : (plo(i)-plcllo(i)+plclup(i)-pup(i)) + endif + enddo + call cv3_vertmix(len,nd,iflag,p1feed,pfeed,p,ph + i ,t,q,u,v,wght + o ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plclfeed) + do i = 1,len + posit(i) = (sign(1.,plclfeed(i)-pfeed(i))+1.)*0.5 + if (plclfeed(i) .eq. pfeed(i)) posit(i) = 1. +c- posit = 1 when lcl is below top of feeding layer (plclfeed>pfeed) +c- => pup=pfeed +c- posit = 0 when lcl is above top of feeding layer (plclfeed plo=pfeed + pup(i) = posit(i)*pfeed(i) + (1.-posit(i))*pup(i) + plo(i) = (1.-posit(i))*pfeed(i) + posit(i)*plo(i) + plclup(i) = posit(i)*plclfeed(i) + (1.-posit(i))*plclup(i) + plcllo(i) = (1.-posit(i))*plclfeed(i) + posit(i)*plcllo(i) + enddo + enddo ! iter + do i = 1,len + p2feed(i) = pfeed(i) + plcl(i) = plclfeed(i) + enddo +! + do 175 i=1,len + cpnk(i)=cpd*(1.0-qnk(i))+cpv*qnk(i) + hnk(i)=gz(i,1)+cpnk(i)*tnk(i) + 175 continue +! +!------------------------------------------------------------------- +! --- Check whether parcel level temperature and specific humidity +! --- are reasonable +!------------------------------------------------------------------- + do 250 i=1,len + if( ( ( tnk(i).lt.250.0 ) + & .or.( qnk(i).le.0.0 ) ) + & .and. + & ( iflag(i).eq.0) ) iflag(i)=7 + 250 continue +c +!------------------------------------------------------------------- +! --- Calculate first level above lcl (=icb) +!------------------------------------------------------------------- + +c@ do 270 i=1,len +c@ icb(i)=nlm +c@ 270 continue +c@c +c@ do 290 k=minorig,nl +c@ do 280 i=1,len +c@ if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i))) +c@ & icb(i)=min(icb(i),k) +c@ 280 continue +c@ 290 continue +c@c +c@ do 300 i=1,len +c@ if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9 +c@ 300 continue + + do 270 i=1,len + icb(i)=nlm + 270 continue +c +c la modification consiste a comparer plcl a ph et non a p: +c icb est defini par : ph(icb)p(icb), then icbs=icb +c +c * the routine above computes tvp from minorig to icbs (included). +c +c * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1) +c must be known. This is the case if icbs=icb+1, but not if icbs=icb. +c +c * therefore, in the case icbs=icb, we compute tvp at level icb+1 +c (tvp at other levels will be computed in cv3_undilute2.F) +c + + do i=1,len + ticb(i)=t(i,icb(i)+1) + gzicb(i)=gz(i,icb(i)+1) + qsicb(i)=qs(i,icb(i)+1) + enddo + + do 460 i=1,len + tg=ticb(i) + qg=qsicb(i) ! convect3 +cdebug alv=lv0-clmcpv*(ticb(i)-t0) + alv=lv0-clmcpv*(ticb(i)-273.15) +c +c First iteration. +c +c ori s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) + s=cpd*(1.-qnk(i))+cl*qnk(i) ! convect3 + : +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3 + s=1./s +c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3 + tg=tg+s*(ah0(i)-ahg) +c ori tg=max(tg,35.0) +cdebug tc=tg-t0 + tc=tg-273.15 + denom=243.5+tc + denom=MAX(denom,1.0) ! convect3 +c ori if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) +c ori else +c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +c ori endif +c ori qg=eps*es/(p(i,icb(i))-es*(1.-eps)) + qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps)) +c +c Second iteration. +c + +c ori s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) +c ori s=1./s +c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3 + tg=tg+s*(ah0(i)-ahg) +c ori tg=max(tg,35.0) +cdebug tc=tg-t0 + tc=tg-273.15 + denom=243.5+tc + denom=MAX(denom,1.0) ! convect3 +c ori if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) +c ori else +c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +c ori end if +c ori qg=eps*es/(p(i,icb(i))-es*(1.-eps)) + qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps)) + + alv=lv0-clmcpv*(ticb(i)-273.15) + +c ori c approximation here: +c ori tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i) +c ori & -gz(i,icb(i))-alv*qg)/cpd + +c convect3: no approximation: + tp(i,icb(i)+1)=(ah0(i)-gz(i,icb(i)+1)-alv*qg) + : /(cpd+(cl-cpd)*qnk(i)) + +c ori clw(i,icb(i))=qnk(i)-qg +c ori clw(i,icb(i))=max(0.0,clw(i,icb(i))) + clw(i,icb(i)+1)=qnk(i)-qg + clw(i,icb(i)+1)=max(0.0,clw(i,icb(i)+1)) + + rg=qg/(1.-qnk(i)) +c ori tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi) +c convect3: (qg utilise au lieu du vrai mixing ratio rg) + tvp(i,icb(i)+1)=tp(i,icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing + + 460 continue + + return + end + + SUBROUTINE cv3_trigger(len,nd,icb,plcl,p,th,tv,tvp,thnk, + o pbase,buoybase,iflag,sig,w0) + implicit none + +!------------------------------------------------------------------- +! --- TRIGGERING +! +! - computes the cloud base +! - triggering (crude in this version) +! - relaxation of sig and w0 when no convection +! +! Caution1: if no convection, we set iflag=4 +! (it used to be 0 in convect3) +! +! Caution2: at this stage, tvp (and thus buoy) are know up +! through icb only! +! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy +!------------------------------------------------------------------- + +#include "cv3param.h" + +c input: + integer len, nd + integer icb(len) + real plcl(len), p(len,nd) + real th(len,nd), tv(len,nd), tvp(len,nd) + real thnk(len) + +c output: + real pbase(len), buoybase(len) + +c input AND output: + integer iflag(len) + real sig(len,nd), w0(len,nd) + +c local variables: + integer i,k + real tvpbase, tvbase, tdif, ath, ath1 + +c +c *** set cloud base buoyancy at (plcl+dpbase) level buoyancy +c + do 100 i=1,len + pbase(i) = plcl(i) + dpbase + tvpbase = tvp(i,icb(i))*(pbase(i)-p(i,icb(i)+1)) + : /(p(i,icb(i))-p(i,icb(i)+1)) + : + tvp(i,icb(i)+1)*(p(i,icb(i))-pbase(i)) + : /(p(i,icb(i))-p(i,icb(i)+1)) + tvbase = tv(i,icb(i))*(pbase(i)-p(i,icb(i)+1)) + : /(p(i,icb(i))-p(i,icb(i)+1)) + : + tv(i,icb(i)+1)*(p(i,icb(i))-pbase(i)) + : /(p(i,icb(i))-p(i,icb(i)+1)) + buoybase(i) = tvpbase - tvbase +100 continue + +c +c *** make sure that column is dry adiabatic between the surface *** +c *** and cloud base, and that lifted air is positively buoyant *** +c *** at cloud base *** +c *** if not, return to calling program after resetting *** +c *** sig(i) and w0(i) *** +c + +c oct3 do 200 i=1,len +c oct3 +c oct3 tdif = buoybase(i) +c oct3 ath1 = th(i,1) +c oct3 ath = th(i,icb(i)-1) - dttrig +c oct3 +c oct3 if (tdif.lt.dtcrit .or. ath.gt.ath1) then +c oct3 do 60 k=1,nl +c oct3 sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif +c oct3 sig(i,k) = AMAX1(sig(i,k),0.0) +c oct3 w0(i,k) = beta*w0(i,k) +c oct3 60 continue +c oct3 iflag(i)=4 ! pour version vectorisee +c oct3c convect3 iflag(i)=0 +c oct3cccc return +c oct3 endif +c oct3 +c oct3200 continue + +c -- oct3: on reecrit la boucle 200 (pour la vectorisation) + + do 60 k=1,nl + do 200 i=1,len + + tdif = buoybase(i) + ath1 = thnk(i) + ath = th(i,icb(i)-1) - dttrig + + if (tdif.lt.dtcrit .or. ath.gt.ath1) then + sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif + sig(i,k) = AMAX1(sig(i,k),0.0) + w0(i,k) = beta*w0(i,k) + iflag(i)=4 ! pour version vectorisee +c convect3 iflag(i)=0 + endif + +200 continue + 60 continue + +c fin oct3 -- + + return + end + + SUBROUTINE cv3_compress( len,nloc,ncum,nd,ntra + : ,iflag1,nk1,icb1,icbs1 + : ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1 + : ,t1,q1,qs1,u1,v1,gz1,th1 + : ,tra1 + : ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 + : ,sig1,w01 + o ,iflag,nk,icb,icbs + o ,plcl,tnk,qnk,gznk,pbase,buoybase + o ,t,q,qs,u,v,gz,th + o ,tra + o ,h,lv,cpn,p,ph,tv,tp,tvp,clw + o ,sig,w0 ) + implicit none + +#include "cv3param.h" + +c inputs: + integer len,ncum,nd,ntra,nloc + integer iflag1(len),nk1(len),icb1(len),icbs1(len) + real plcl1(len),tnk1(len),qnk1(len),gznk1(len) + real pbase1(len),buoybase1(len) + real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd) + real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd) + real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd) + real tvp1(len,nd),clw1(len,nd) + real th1(len,nd) + real sig1(len,nd), w01(len,nd) + real tra1(len,nd,ntra) + +c outputs: +c en fait, on a nloc=len pour l'instant (cf cv_driver) + integer iflag(nloc),nk(nloc),icb(nloc),icbs(nloc) + real plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc) + real pbase(nloc),buoybase(nloc) + real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd) + real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd) + real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd) + real tvp(nloc,nd),clw(nloc,nd) + real th(nloc,nd) + real sig(nloc,nd), w0(nloc,nd) + real tra(nloc,nd,ntra) + +c local variables: + integer i,k,nn,j + + + do 110 k=1,nl+1 + nn=0 + do 100 i=1,len + if(iflag1(i).eq.0)then + nn=nn+1 + sig(nn,k)=sig1(i,k) + w0(nn,k)=w01(i,k) + t(nn,k)=t1(i,k) + q(nn,k)=q1(i,k) + qs(nn,k)=qs1(i,k) + u(nn,k)=u1(i,k) + v(nn,k)=v1(i,k) + gz(nn,k)=gz1(i,k) + h(nn,k)=h1(i,k) + lv(nn,k)=lv1(i,k) + cpn(nn,k)=cpn1(i,k) + p(nn,k)=p1(i,k) + ph(nn,k)=ph1(i,k) + tv(nn,k)=tv1(i,k) + tp(nn,k)=tp1(i,k) + tvp(nn,k)=tvp1(i,k) + clw(nn,k)=clw1(i,k) + th(nn,k)=th1(i,k) + endif + 100 continue + 110 continue + + do 121 j=1,ntra +ccccc do 111 k=1,nl+1 + do 111 k=1,nd + nn=0 + do 101 i=1,len + if(iflag1(i).eq.0)then + nn=nn+1 + tra(nn,k,j)=tra1(i,k,j) + endif + 101 continue + 111 continue + 121 continue + + if (nn.ne.ncum) then + print*,'strange! nn not equal to ncum: ',nn,ncum + stop + endif + + nn=0 + do 150 i=1,len + if(iflag1(i).eq.0)then + nn=nn+1 + pbase(nn)=pbase1(i) + buoybase(nn)=buoybase1(i) + plcl(nn)=plcl1(i) + tnk(nn)=tnk1(i) + qnk(nn)=qnk1(i) + gznk(nn)=gznk1(i) + nk(nn)=nk1(i) + icb(nn)=icb1(i) + icbs(nn)=icbs1(i) + iflag(nn)=iflag1(i) + endif + 150 continue + + return + end + + SUBROUTINE cv3_undilute2(nloc,ncum,nd,icb,icbs,nk + : ,tnk,qnk,gznk,hnk,t,q,qs,gz + : ,p,h,tv,lv,pbase,buoybase,plcl + o ,inb,tp,tvp,clw,hp,ep,sigp,buoy) + implicit none + +C--------------------------------------------------------------------- +C Purpose: +C FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +C & +C COMPUTE THE PRECIPITATION EFFICIENCIES AND THE +C FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD +C & +C FIND THE LEVEL OF NEUTRAL BUOYANCY +C +C Main differences convect3/convect4: +C - icbs (input) is the first level above LCL (may differ from icb) +C - many minor differences in the iterations +C - condensed water not removed from tvp in convect3 +C - vertical profile of buoyancy computed here (use of buoybase) +C - the determination of inb is different +C - no inb1, only inb in output +C--------------------------------------------------------------------- + +#include "cvthermo.h" +#include "cv3param.h" +#include "conema3.h" + +c inputs: + integer ncum, nd, nloc + integer icb(nloc), icbs(nloc), nk(nloc) + real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd) + real p(nloc,nd) + real tnk(nloc), qnk(nloc), gznk(nloc) + real hnk(nloc) + real lv(nloc,nd), tv(nloc,nd), h(nloc,nd) + real pbase(nloc), buoybase(nloc), plcl(nloc) + +c outputs: + integer inb(nloc) + real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd) + real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd) + real buoy(nloc,nd) + +c local variables: + integer i, k + real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit + real by, defrac, pden + real ah0(nloc), cape(nloc), capem(nloc), byp(nloc) + logical lcape(nloc) + integer iposit(nloc) + +!===================================================================== +! --- SOME INITIALIZATIONS +!===================================================================== + + do 170 k=1,nl + do 160 i=1,ncum + ep(i,k)=0.0 + sigp(i,k)=spfac + 160 continue + 170 continue + +!===================================================================== +! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +!===================================================================== +c +c --- The procedure is to solve the equation. +c cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. +c +c *** Calculate certain parcel quantities, including static energy *** +c +c + do 240 i=1,ncum + ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) +cdebug & +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i) + & +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i) + 240 continue +c +c +c *** Find lifted parcel quantities above cloud base *** +c +c + do 300 k=minorig+1,nl + do 290 i=1,ncum +c ori if(k.ge.(icb(i)+1))then + if(k.ge.(icbs(i)+1))then ! convect3 + tg=t(i,k) + qg=qs(i,k) +cdebug alv=lv0-clmcpv*(t(i,k)-t0) + alv=lv0-clmcpv*(t(i,k)-273.15) +c +c First iteration. +c +c ori s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) + s=cpd*(1.-qnk(i))+cl*qnk(i) ! convect3 + : +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3 + s=1./s +c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3 + tg=tg+s*(ah0(i)-ahg) +c ori tg=max(tg,35.0) +cdebug tc=tg-t0 + tc=tg-273.15 + denom=243.5+tc + denom=MAX(denom,1.0) ! convect3 +c ori if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) +c ori else +c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +c ori endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c +c Second iteration. +c +c ori s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) +c ori s=1./s +c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3 + tg=tg+s*(ah0(i)-ahg) +c ori tg=max(tg,35.0) +cdebug tc=tg-t0 + tc=tg-273.15 + denom=243.5+tc + denom=MAX(denom,1.0) ! convect3 +c ori if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) +c ori else +c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +c ori endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c +cdebug alv=lv0-clmcpv*(t(i,k)-t0) + alv=lv0-clmcpv*(t(i,k)-273.15) +c print*,'cpd dans convect2 ',cpd +c print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd' +c print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd + +c ori c approximation here: +c ori tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd + +c convect3: no approximation: + tp(i,k)=(ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i)) + + clw(i,k)=qnk(i)-qg + clw(i,k)=max(0.0,clw(i,k)) + rg=qg/(1.-qnk(i)) +c ori tvp(i,k)=tp(i,k)*(1.+rg*epsi) +c convect3: (qg utilise au lieu du vrai mixing ratio rg): + tvp(i,k)=tp(i,k)*(1.+qg/eps-qnk(i)) ! whole thing + endif + 290 continue + 300 continue +c +!===================================================================== +! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF +! --- PRECIPITATION FALLING OUTSIDE OF CLOUD +! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I) +!===================================================================== +c +c ori do 320 k=minorig+1,nl + do 320 k=1,nl ! convect3 + do 310 i=1,ncum + pden=ptcrit-pbcrit + ep(i,k)=(plcl(i)-p(i,k)-pbcrit)/pden*epmax + ep(i,k)=amax1(ep(i,k),0.0) + ep(i,k)=amin1(ep(i,k),epmax) + sigp(i,k)=spfac +c ori if(k.ge.(nk(i)+1))then +c ori tca=tp(i,k)-t0 +c ori if(tca.ge.0.0)then +c ori elacrit=elcrit +c ori else +c ori elacrit=elcrit*(1.0-tca/tlcrit) +c ori endif +c ori elacrit=max(elacrit,0.0) +c ori ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8) +c ori ep(i,k)=max(ep(i,k),0.0 ) +c ori ep(i,k)=min(ep(i,k),1.0 ) +c ori sigp(i,k)=sigs +c ori endif + 310 continue + 320 continue +c +!===================================================================== +! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL +! --- VIRTUAL TEMPERATURE +!===================================================================== +c +c dans convect3, tvp est calcule en une seule fois, et sans retirer +c l'eau condensee (~> reversible CAPE) +c +c ori do 340 k=minorig+1,nl +c ori do 330 i=1,ncum +c ori if(k.ge.(icb(i)+1))then +c ori tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k)) +c oric print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)' +c oric print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k) +c ori endif +c ori 330 continue +c ori 340 continue + +c ori do 350 i=1,ncum +c ori tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd +c ori 350 continue + + do 350 i=1,ncum ! convect3 + tp(i,nlp)=tp(i,nl) ! convect3 + 350 continue ! convect3 +c +c===================================================================== +c --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only): +c===================================================================== + +c-- this is for convect3 only: + +c first estimate of buoyancy: + + do 500 i=1,ncum + do 501 k=1,nl + buoy(i,k)=tvp(i,k)-tv(i,k) + 501 continue + 500 continue + +c set buoyancy=buoybase for all levels below base +c for safety, set buoy(icb)=buoybase + + do 505 i=1,ncum + do 506 k=1,nl + if((k.ge.icb(i)).and.(k.le.nl).and.(p(i,k).ge.pbase(i)))then + buoy(i,k)=buoybase(i) + endif + 506 continue +c buoy(icb(i),k)=buoybase(i) + buoy(i,icb(i))=buoybase(i) + 505 continue + +c-- end convect3 + +c===================================================================== +c --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S +c --- LEVEL OF NEUTRAL BUOYANCY +c===================================================================== +c +c-- this is for convect3 only: + + do 510 i=1,ncum + inb(i)=nl-1 + iposit(i) = nl + 510 continue + +c +c-- iposit(i) = first level, above icb, with positive buoyancy + do k = 1,nl-1 + do i = 1,ncum + if (k .ge. icb(i) .and. buoy(i,k) .gt. 0.) then + iposit(i) = min(iposit(i),k) + endif + enddo + enddo + + do i = 1,ncum + if (iposit(i) .eq. nl) then + iposit(i) = icb(i) + endif + enddo + + do 530 i=1,ncum + do 535 k=1,nl-1 + if ((k.ge.iposit(i)).and.(buoy(i,k).lt.dtovsh)) then + inb(i)=MIN(inb(i),k) + endif + 535 continue + 530 continue + +c-- end convect3 + +c ori do 510 i=1,ncum +c ori cape(i)=0.0 +c ori capem(i)=0.0 +c ori inb(i)=icb(i)+1 +c ori inb1(i)=inb(i) +c ori 510 continue +c +c Originial Code +c +c do 530 k=minorig+1,nl-1 +c do 520 i=1,ncum +c if(k.ge.(icb(i)+1))then +c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c cape(i)=cape(i)+by +c if(by.ge.0.0)inb1(i)=k+1 +c if(cape(i).gt.0.0)then +c inb(i)=k+1 +c capem(i)=cape(i) +c endif +c endif +c520 continue +c530 continue +c do 540 i=1,ncum +c byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl) +c cape(i)=capem(i)+byp +c defrac=capem(i)-cape(i) +c defrac=max(defrac,0.001) +c frac(i)=-cape(i)/defrac +c frac(i)=min(frac(i),1.0) +c frac(i)=max(frac(i),0.0) +c540 continue +c +c K Emanuel fix +c +c call zilch(byp,ncum) +c do 530 k=minorig+1,nl-1 +c do 520 i=1,ncum +c if(k.ge.(icb(i)+1))then +c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c cape(i)=cape(i)+by +c if(by.ge.0.0)inb1(i)=k+1 +c if(cape(i).gt.0.0)then +c inb(i)=k+1 +c capem(i)=cape(i) +c byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c endif +c endif +c520 continue +c530 continue +c do 540 i=1,ncum +c inb(i)=max(inb(i),inb1(i)) +c cape(i)=capem(i)+byp(i) +c defrac=capem(i)-cape(i) +c defrac=max(defrac,0.001) +c frac(i)=-cape(i)/defrac +c frac(i)=min(frac(i),1.0) +c frac(i)=max(frac(i),0.0) +c540 continue +c +c J Teixeira fix +c +c ori call zilch(byp,ncum) +c ori do 515 i=1,ncum +c ori lcape(i)=.true. +c ori 515 continue +c ori do 530 k=minorig+1,nl-1 +c ori do 520 i=1,ncum +c ori if(cape(i).lt.0.0)lcape(i)=.false. +c ori if((k.ge.(icb(i)+1)).and.lcape(i))then +c ori by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c ori byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c ori cape(i)=cape(i)+by +c ori if(by.ge.0.0)inb1(i)=k+1 +c ori if(cape(i).gt.0.0)then +c ori inb(i)=k+1 +c ori capem(i)=cape(i) +c ori endif +c ori endif +c ori 520 continue +c ori 530 continue +c ori do 540 i=1,ncum +c ori cape(i)=capem(i)+byp(i) +c ori defrac=capem(i)-cape(i) +c ori defrac=max(defrac,0.001) +c ori frac(i)=-cape(i)/defrac +c ori frac(i)=min(frac(i),1.0) +c ori frac(i)=max(frac(i),0.0) +c ori 540 continue +c +c===================================================================== +c --- CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL +c===================================================================== +c + do k = 1,nd + do i=1,ncum + hp(i,k)=h(i,k) + enddo + enddo + + do 600 k=minorig+1,nl + do 590 i=1,ncum + if((k.ge.icb(i)).and.(k.le.inb(i)))then + hp(i,k)=hnk(i)+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k) + endif + 590 continue + 600 continue + + return + end + + SUBROUTINE cv3_closure(nloc,ncum,nd,icb,inb + : ,pbase,p,ph,tv,buoy + o ,sig,w0,cape,m,iflag) + implicit none + +!=================================================================== +! --- CLOSURE OF CONVECT3 +! +! vectorization: S. Bony +!=================================================================== + +#include "cvthermo.h" +#include "cv3param.h" + +c input: + integer ncum, nd, nloc + integer icb(nloc), inb(nloc) + real pbase(nloc) + real p(nloc,nd), ph(nloc,nd+1) + real tv(nloc,nd), buoy(nloc,nd) + +c input/output: + real sig(nloc,nd), w0(nloc,nd) + integer iflag(nloc) + +c output: + real cape(nloc) + real m(nloc,nd) + +c local variables: + integer i, j, k, icbmax + real deltap, fac, w, amu + real dtmin(nloc,nd), sigold(nloc,nd) + real cbmflast(nloc) + + +c ------------------------------------------------------- +c -- Initialization +c ------------------------------------------------------- + + do k=1,nl + do i=1,ncum + m(i,k)=0.0 + enddo + enddo + +c ------------------------------------------------------- +c -- Reset sig(i) and w0(i) for i>inb and iph(i), pr1=1 & pr2=0 +c pour ph(i+1) cv3p1_closure, Ale ',ale(1) +c + +c ------------------------------------------------------- +c -- Initialization +c ------------------------------------------------------- + +c +c + do il = 1,ncum + alp2(il) = max(alp(il),1.e-5) +cIM + alp2(il) = max(alp(il),1.e-12) + enddo +c + PBMXUP=50. ! PBMXUP+PBCRIT = cloud depth above which mixed updraughts +c exist (if any) + + if(prt_level.GE.20) + . print*,'cv3p1_param nloc ncum nd icb inb nl',nloc,ncum,nd, + . icb(nloc),inb(nloc),nl + do k=1,nl + do il=1,ncum + m(il,k)=0.0 + enddo + enddo + +c ------------------------------------------------------- +c -- Reset sig(i) and w0(i) for i>inb and iI, if any, and new critical value Scrit2 +c such that : Sij > Scrit2 => mixed draught will detrain at J mixed draught will detrain at J>I +c + Sx = 0. + Jx = 0. + Sbef(il) = max(0.,signhpmh(il)) + DO j = i+1,inb(il) + IF (Sbef(il) .LT. Sij(il,i,j)) THEN + Sx = max(Sij(il,i,j),Sx) + Jx = J + ENDIF + Sbef(il) = Sij(il,i,j) + ENDDO +c + Scrit2 = min(Scrit(il),Sx)*max(0.,-signhpmh(il)) + : +Scrit(il)*max(0.,signhpmh(il)) +c + Scrit(il) = Scrit2 +c +cjyg Correction pour la nouvelle logique; la correction pour ALT +c est un peu au hazard + if(scrit(il).le.0.0)scrit(il)=0.0 + if(alt.le.0.0) scrit(il)=1.0 +C + smax(il)=0.0 + asij(il)=0.0 + Sup(il)=0. ! upper S-value reached by descending draughts + endif +781 continue + + do 175 j=minorig,nl + + num2=0 + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) num2=num2+1 + enddo + if (num2.le.0) goto 175 + +c ----------------------------------------------- + IF (j .GT. i) THEN +c ----------------------------------------------- + do 782 il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) then + if(sij(il,i,j).gt.0.0)then + Smid(il)=min(Sij(il,i,j),Scrit(il)) + Sjmax(il)=Smid(il) + Sjmin(il)=Smid(il) + IF (Smid(il) .LT. Smin(il) .AND. + 1 Sij(il,i,j+1) .LT. Smid(il)) THEN + Smin(il)=Smid(il) + Sjmax(il)=min( (Sij(il,i,j+1)+Sij(il,i,j))/2. , + 1 Sij(il,i,j) , + 1 Scrit(il) ) + Sjmin(il)=max( (Sbef(il)+Sij(il,i,j))/2. , + 1 Sij(il,i,j) ) + Sjmin(il)=min(Sjmin(il),Scrit(il)) + Sbef(il) = Sij(il,i,j) + ENDIF + endif + endif +782 continue +c ----------------------------------------------- + ELSE IF (j .EQ. i) THEN +c ----------------------------------------------- + do 783 il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) then + if(sij(il,i,j).gt.0.0)then + Smid(il) = 1. + Sjmin(il) = max((Sij(il,i,j-1)+Smid(il))/2.,Scrit(il)) + 1 *max(0.,-signhpmh(il)) + 1 +min((Sij(il,i,j+1)+Smid(il))/2.,Scrit(il)) + 1 *max(0., signhpmh(il)) + Sjmin(il) = max(Sjmin(il),Sup(il)) + Sjmax(il) = 1. +c +c- preparation des variables Scrit, Smin et Sbef pour la partie j>i + Scrit(il) = min(Sjmin(il),Sjmax(il),Scrit(il)) + + Smin(il) = 1. + Sbef(il) = max(0.,signhpmh(il)) + Supmax(il,i) = sign(Scrit(il),-signhpmh(il)) + endif + endif +783 continue +c ----------------------------------------------- + ELSE IF ( j .LT. i) THEN +c ----------------------------------------------- + do 784 il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) then + if(sij(il,i,j).gt.0.0)then + Smid(il)=max(Sij(il,i,j),Scrit(il)) + Sjmax(il) = Smid(il) + Sjmin(il) = Smid(il) + IF (Smid(il) .GT. Smax(il) .AND. + 1 Sij(il,i,j+1) .GT. Smid(il)) THEN + Smax(il) = Smid(il) + Sjmax(il) = max( (Sij(il,i,j+1)+Sij(il,i,j))/2. , + 1 Sij(il,i,j) ) + Sjmax(il) = max(Sjmax(il),Scrit(il)) + Sjmin(il) = min( (Sbef(il)+Sij(il,i,j))/2. , + 1 Sij(il,i,j) ) + Sjmin(il) = max(Sjmin(il),Scrit(il)) + Sbef(il) = Sij(il,i,j) + ENDIF + IF (abs(Sjmin(il)-Sjmax(il)) .GT. 1.e-10) Sup(il)= + 1 max(Sjmin(il),Sjmax(il),Sup(il)) + endif + endif +784 continue +c ----------------------------------------------- + END IF +c ----------------------------------------------- +c +c + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) then + if(sij(il,i,j).gt.0.0)then + rti=qnk(il)-ep(il,i)*clw(il,i) + Qmixmax(il)=Qmix(Sjmax(il)) + Qmixmin(il)=Qmix(Sjmin(il)) + Rmixmax(il)=Rmix(Sjmax(il)) + Rmixmin(il)=Rmix(Sjmin(il)) + SQmRmax(il)= Sjmax(il)*Qmix(Sjmax(il))-Rmix(Sjmax(il)) + SQmRmin(il)= Sjmin(il)*Qmix(Sjmin(il))-Rmix(Sjmin(il)) +c + Ment(il,i,j) = abs(Qmixmax(il)-Qmixmin(il))*Ment(il,i,j) +c +c Sigij(i,j) is the 'true' mixing fraction of mixture Ment(i,j) + IF (abs(Qmixmax(il)-Qmixmin(il)) .GT. 1.e-10) THEN + Sigij(il,i,j) = + : (SQmRmax(il)-SQmRmin(il))/(Qmixmax(il)-Qmixmin(il)) + ELSE + Sigij(il,i,j) = 0. + ENDIF +c +c -- Compute Qent, uent, vent according to the true mixing fraction + Qent(il,i,j) = (1.-Sigij(il,i,j))*rti + : + Sigij(il,i,j)*rr(il,i) + uent(il,i,j) = (1.-Sigij(il,i,j))*unk(il) + : + Sigij(il,i,j)*u(il,i) + vent(il,i,j) = (1.-Sigij(il,i,j))*vnk(il) + : + Sigij(il,i,j)*v(il,i) +c +c-- Compute liquid water static energy of mixed draughts +c IF (j .GT. i) THEN +c awat=elij(il,i,j)-(1.-ep(il,j))*clw(il,j) +c awat=amax1(awat,0.0) +c ELSE +c awat = 0. +c ENDIF +c Hent(il,i,j) = (1.-Sigij(il,i,j))*HP(il,i) +c : + Sigij(il,i,j)*H(il,i) +c : + (LV(il,j)+(cpd-cpv)*t(il,j))*awat +cIM 301008 beg + Hent(il,i,j) = (1.-Sigij(il,i,j))*HP(il,i) + : + Sigij(il,i,j)*H(il,i) + + Elij(il,i,j) = Qent(il,i,j)-rs(il,j) + Elij(il,i,j) = Elij(il,i,j) + : + ((h(il,j)-Hent(il,i,j))*rs(il,j)*LV(il,j) + : / ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv) + : * rrv*t(il,j)*t(il,j))) + Elij(il,i,j) = Elij(il,i,j) + : / (1.+LV(il,j)*LV(il,j)*rs(il,j) + : / ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv) + : * rrv*t(il,j)*t(il,j))) + + Elij(il,i,j) = max(elij(il,i,j),0.) + + Elij(il,i,j) = min(elij(il,i,j),Qent(il,i,j)) + + IF (j .GT. i) THEN + awat=elij(il,i,j)-(1.-ep(il,j))*clw(il,j) + awat=amax1(awat,0.0) + ELSE + awat = 0. + ENDIF + +c print *,h(il,j)-hent(il,i,j),LV(il,j)*rs(il,j)/(cpd*rrv*t(il,j)* +c : t(il,j)) + + Hent(il,i,j) = Hent(il,i,j)+(LV(il,j)+(cpd-cpv)*t(il,j)) + : * awat +cIM 301008 end +c +c print *,'mix : i,j,hent(il,i,j),sigij(il,i,j) ', +c : i,j,hent(il,i,j),sigij(il,i,j) +c +c -- ASij is the integral of P(F) over the relevant F interval + ASij(il) = ASij(il) + 1 + abs(Qmixmax(il)*(1.-Sjmax(il))+Rmixmax(il) + 1 -Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il)) +c + endif + endif + enddo + do k=1,ntra + do il=1,ncum + if( (i.ge.icb(il)).and.(i.le.inb(il)).and. + : (j.ge.(icb(il)-1)).and.(j.le.inb(il)) + : .and. lwork(il) ) then + if(sij(il,i,j).gt.0.0)then + traent(il,i,j,k)=sigij(il,i,j)*tra(il,i,k) + : +(1.-sigij(il,i,j))*tra(il,nk(il),k) + endif + endif + enddo + enddo +c +c -- If I=J (detrainement and entrainement at the same level), then only the +c -- adiabatic ascent part of the mixture is considered + IF (I .EQ. J) THEN + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) then + if(sij(il,i,j).gt.0.0)then + rti=qnk(il)-ep(il,i)*clw(il,i) +ccc Ment(il,i,i) = m(il,i)*abs(Qmixmax(il)*(1.-Sjmax(il)) + Ment(il,i,i) = abs(Qmixmax(il)*(1.-Sjmax(il)) + 1 +Rmixmax(il) + 1 -Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il)) + Qent(il,i,i) = rti + uent(il,i,i) = unk(il) + vent(il,i,i) = vnk(il) + Hent(il,i,i) = hp(il,i) + Elij(il,i,i) = clw(il,i)*(1.-ep(il,i)) + Sigij(il,i,i) = 0. + endif + endif + enddo + do k=1,ntra + do il=1,ncum + if( (i.ge.icb(il)).and.(i.le.inb(il)).and. + : (j.ge.(icb(il)-1)).and.(j.le.inb(il)) + : .and. lwork(il) ) then + if(sij(il,i,j).gt.0.0)then + traent(il,i,i,k)=tra(il,nk(il),k) + endif + endif + enddo + enddo +c + ENDIF +c +175 continue + + do il=1,ncum + if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then + asij(il)=amax1(1.0e-16,asij(il)) + asij(il)=1.0/asij(il) + csum(il,i)=0.0 + endif + enddo + + do 180 j=minorig,nl + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then + ment(il,i,j)=ment(il,i,j)*asij(il) + endif + enddo +180 continue + + do 197 j=minorig,nl + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then + csum(il,i)=csum(il,i)+ment(il,i,j) + endif + enddo +197 continue + + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. csum(il,i).lt.1. ) then +ccc : .and. csum(il,i).lt.m(il,i) ) then + nent(il,i)=0 +ccc ment(il,i,i)=m(il,i) + ment(il,i,i)=1. + qent(il,i,i)=qnk(il)-ep(il,i)*clw(il,i) + uent(il,i,i)=unk(il) + vent(il,i,i)=vnk(il) + elij(il,i,i)=clw(il,i)*(1.-ep(il,i)) + sij(il,i,i)=0.0 + endif + enddo ! il + + do j=1,ntra + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. csum(il,i).lt.1. ) then +ccc : .and. csum(il,i).lt.m(il,i) ) then + traent(il,i,i,j)=tra(il,nk(il),j) + endif + enddo + enddo +c +789 continue +c + return + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv3param.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv3param.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv3param.h (revision 1280) @@ -0,0 +1,25 @@ +c------------------------------------------------------------ +c Parameters for convectL, iflag_con=3: +c (includes - microphysical parameters, +c - parameters that control the rate of approach +c to quasi-equilibrium) +c - noff & minorig (previously in input of convect1) +c------------------------------------------------------------ + + integer noff, minorig, nl, nlp, nlm + real sigdz, spfac + real pbcrit, ptcrit + real omtrain + real dtovsh, dpbase, dttrig + real dtcrit, tau, beta, alpha, alpha1 + real delta + real betad + + COMMON /cv3param/ noff, minorig, nl, nlp, nlm + : , sigdz, spfac + : ,pbcrit, ptcrit + : ,omtrain + : ,dtovsh, dpbase, dttrig + : ,dtcrit, tau, beta, alpha, alpha1, delta, betad +!$OMP THREADPRIVATE(/cv3param/) + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv_driver.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv_driver.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv_driver.F (revision 1280) @@ -0,0 +1,707 @@ +! +! $Header$ +! + SUBROUTINE cv_driver(len,nd,ndp1,ntra,iflag_con, + & t1,q1,qs1,u1,v1,tra1, + & p1,ph1,iflag1,ft1,fq1,fu1,fv1,ftra1, + & precip1,VPrecip1, + & cbmf1,sig1,w01, + & icb1,inb1, + & delt,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1, + & da1,phi1,mp1) +C + USE dimphy + implicit none +C +C.............................START PROLOGUE............................ +C +C PARAMETERS: +C Name Type Usage Description +C ---------- ---------- ------- ---------------------------- +C +C len Integer Input first (i) dimension +C nd Integer Input vertical (k) dimension +C ndp1 Integer Input nd + 1 +C ntra Integer Input number of tracors +C iflag_con Integer Input version of convect (3/4) +C t1 Real Input temperature +C q1 Real Input specific hum +C qs1 Real Input sat specific hum +C u1 Real Input u-wind +C v1 Real Input v-wind +C tra1 Real Input tracors +C p1 Real Input full level pressure +C ph1 Real Input half level pressure +C iflag1 Integer Output flag for Emanuel conditions +C ft1 Real Output temp tend +C fq1 Real Output spec hum tend +C fu1 Real Output u-wind tend +C fv1 Real Output v-wind tend +C ftra1 Real Output tracor tend +C precip1 Real Output precipitation +C VPrecip1 Real Output vertical profile of precipitations +C cbmf1 Real Output cloud base mass flux +C sig1 Real In/Out section adiabatic updraft +C w01 Real In/Out vertical velocity within adiab updraft +C delt Real Input time step +C Ma1 Real Output mass flux adiabatic updraft +C upwd1 Real Output total upward mass flux (adiab+mixed) +C dnwd1 Real Output saturated downward mass flux (mixed) +C dnwd01 Real Output unsaturated downward mass flux +C qcondc1 Real Output in-cld mixing ratio of condensed water +C wd1 Real Output downdraft velocity scale for sfc fluxes +C cape1 Real Output CAPE +C +C S. Bony, Mar 2002: +C * Several modules corresponding to different physical processes +C * Several versions of convect may be used: +C - iflag_con=3: version lmd (previously named convect3) +C - iflag_con=4: version 4.3b (vect. version, previously convect1/2) +C + tard: - iflag_con=5: version lmd with ice (previously named convectg) +C S. Bony, Oct 2002: +C * Vectorization of convect3 (ie version lmd) +C +C..............................END PROLOGUE............................. +c +c +cym#include "dimensions.h" +cym#include "dimphy.h" + + integer len + integer nd + integer ndp1 + integer noff + integer iflag_con + integer ntra + real t1(len,nd) + real q1(len,nd) + real qs1(len,nd) + real u1(len,nd) + real v1(len,nd) + real p1(len,nd) + real ph1(len,ndp1) + integer iflag1(len) + real ft1(len,nd) + real fq1(len,nd) + real fu1(len,nd) + real fv1(len,nd) + real precip1(len) + real cbmf1(len) + real VPrecip1(len,nd+1) + real Ma1(len,nd) + real upwd1(len,nd) + real dnwd1(len,nd) + real dnwd01(len,nd) + + real qcondc1(len,nd) ! cld + real wd1(len) ! gust + real cape1(len) + + real da1(len,nd),phi1(len,nd,nd),mp1(len,nd) + real da(len,nd),phi(len,nd,nd),mp(len,nd) + real tra1(len,nd,ntra) + real ftra1(len,nd,ntra) + + real delt + +!------------------------------------------------------------------- +! --- ARGUMENTS +!------------------------------------------------------------------- +! --- On input: +! +! t: Array of absolute temperature (K) of dimension ND, with first +! index corresponding to lowest model level. Note that this array +! will be altered by the subroutine if dry convective adjustment +! occurs and if IPBL is not equal to 0. +! +! q: Array of specific humidity (gm/gm) of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! qs: Array of saturation specific humidity of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! u: Array of zonal wind velocity (m/s) of dimension ND, witth first +! index corresponding with the lowest model level. Defined at +! same levels as T. Note that this array will be altered if +! dry convective adjustment occurs and if IPBL is not equal to 0. +! +! v: Same as u but for meridional velocity. +! +! tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA), +! where NTRA is the number of different tracers. If no +! convective tracer transport is needed, define a dummy +! input array of dimension (ND,1). Tracers are defined at +! same vertical levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! p: Array of pressure (mb) of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. +! +! ph: Array of pressure (mb) of dimension ND+1, with first index +! corresponding to lowest level. These pressures are defined at +! levels intermediate between those of P, T, Q and QS. The first +! value of PH should be greater than (i.e. at a lower level than) +! the first value of the array P. +! +! nl: The maximum number of levels to which convection can penetrate, plus 1. +! NL MUST be less than or equal to ND-1. +! +! delt: The model time step (sec) between calls to CONVECT +! +!---------------------------------------------------------------------------- +! --- On Output: +! +! iflag: An output integer whose value denotes the following: +! VALUE INTERPRETATION +! ----- -------------- +! 0 Moist convection occurs. +! 1 Moist convection occurs, but a CFL condition +! on the subsidence warming is violated. This +! does not cause the scheme to terminate. +! 2 Moist convection, but no precip because ep(inb) lt 0.0001 +! 3 No moist convection because new cbmf is 0 and old cbmf is 0. +! 4 No moist convection; atmosphere is not +! unstable +! 6 No moist convection because ihmin le minorig. +! 7 No moist convection because unreasonable +! parcel level temperature or specific humidity. +! 8 No moist convection: lifted condensation +! level is above the 200 mb level. +! 9 No moist convection: cloud base is higher +! then the level NL-1. +! +! ft: Array of temperature tendency (K/s) of dimension ND, defined at same +! grid levels as T, Q, QS and P. +! +! fq: Array of specific humidity tendencies ((gm/gm)/s) of dimension ND, +! defined at same grid levels as T, Q, QS and P. +! +! fu: Array of forcing of zonal velocity (m/s^2) of dimension ND, +! defined at same grid levels as T. +! +! fv: Same as FU, but for forcing of meridional velocity. +! +! ftra: Array of forcing of tracer content, in tracer mixing ratio per +! second, defined at same levels as T. Dimensioned (ND,NTRA). +! +! precip: Scalar convective precipitation rate (mm/day). +! +! VPrecip: Vertical profile of convective precipitation (kg/m2/s). +! +! wd: A convective downdraft velocity scale. For use in surface +! flux parameterizations. See convect.ps file for details. +! +! tprime: A convective downdraft temperature perturbation scale (K). +! For use in surface flux parameterizations. See convect.ps +! file for details. +! +! qprime: A convective downdraft specific humidity +! perturbation scale (gm/gm). +! For use in surface flux parameterizations. See convect.ps +! file for details. +! +! cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST +! BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT +! ITS NEXT CALL. That is, the value of CBMF must be "remembered" +! by the calling program between calls to CONVECT. +! +! det: Array of detrainment mass flux of dimension ND. +! +!------------------------------------------------------------------- +c +c Local arrays +c + + integer i,k,n,il,j + integer icbmax + integer nk1(klon) + integer icb1(klon) + integer inb1(klon) + integer icbs1(klon) + + real plcl1(klon) + real tnk1(klon) + real qnk1(klon) + real gznk1(klon) + real pnk1(klon) + real qsnk1(klon) + real pbase1(klon) + real buoybase1(klon) + + real lv1(klon,klev) + real cpn1(klon,klev) + real tv1(klon,klev) + real gz1(klon,klev) + real hm1(klon,klev) + real h1(klon,klev) + real tp1(klon,klev) + real tvp1(klon,klev) + real clw1(klon,klev) + real sig1(klon,klev) + real w01(klon,klev) + real th1(klon,klev) +c + integer ncum +c +c (local) compressed fields: +c +cym integer nloc +cym parameter (nloc=klon) ! pour l'instant +#define nloc klon + integer idcum(nloc) + integer iflag(nloc),nk(nloc),icb(nloc) + integer nent(nloc,klev) + integer icbs(nloc) + integer inb(nloc), inbis(nloc) + + real cbmf(nloc),plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc) + real t(nloc,klev),q(nloc,klev),qs(nloc,klev) + real u(nloc,klev),v(nloc,klev) + real gz(nloc,klev),h(nloc,klev),lv(nloc,klev),cpn(nloc,klev) + real p(nloc,klev),ph(nloc,klev+1),tv(nloc,klev),tp(nloc,klev) + real clw(nloc,klev) + real dph(nloc,klev) + real pbase(nloc), buoybase(nloc), th(nloc,klev) + real tvp(nloc,klev) + real sig(nloc,klev), w0(nloc,klev) + real hp(nloc,klev), ep(nloc,klev), sigp(nloc,klev) + real frac(nloc), buoy(nloc,klev) + real cape(nloc) + real m(nloc,klev), ment(nloc,klev,klev), qent(nloc,klev,klev) + real uent(nloc,klev,klev), vent(nloc,klev,klev) + real ments(nloc,klev,klev), qents(nloc,klev,klev) + real sij(nloc,klev,klev), elij(nloc,klev,klev) + real qp(nloc,klev), up(nloc,klev), vp(nloc,klev) + real wt(nloc,klev), water(nloc,klev), evap(nloc,klev) + real b(nloc,klev), ft(nloc,klev), fq(nloc,klev) + real fu(nloc,klev), fv(nloc,klev) + real upwd(nloc,klev), dnwd(nloc,klev), dnwd0(nloc,klev) + real Ma(nloc,klev), mike(nloc,klev), tls(nloc,klev) + real tps(nloc,klev), qprime(nloc), tprime(nloc) + real precip(nloc) + real VPrecip(nloc,klev+1) + real tra(nloc,klev,ntra), trap(nloc,klev,ntra) + real ftra(nloc,klev,ntra), traent(nloc,klev,klev,ntra) + real qcondc(nloc,klev) ! cld + real wd(nloc) ! gust + + nent(:,:)=0 +!------------------------------------------------------------------- +! --- SET CONSTANTS AND PARAMETERS +!------------------------------------------------------------------- + +c -- set simulation flags: +c (common cvflag) + + CALL cv_flag + +c -- set thermodynamical constants: +c (common cvthermo) + + CALL cv_thermo(iflag_con) + +c -- set convect parameters +c +c includes microphysical parameters and parameters that +c control the rate of approach to quasi-equilibrium) +c (common cvparam) + + + if (iflag_con.eq.30) then + CALL cv30_param(nd,delt) + endif + + if (iflag_con.eq.4) then + CALL cv_param(nd) + endif + +!--------------------------------------------------------------------- +! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS +!--------------------------------------------------------------------- + + do 20 k=1,nd + do 10 i=1,len + ft1(i,k)=0.0 + fq1(i,k)=0.0 + fu1(i,k)=0.0 + fv1(i,k)=0.0 + tvp1(i,k)=0.0 + tp1(i,k)=0.0 + clw1(i,k)=0.0 +cym + clw(i,k)=0.0 + gz1(i,k) = 0. + VPrecip1(i,k) = 0. + Ma1(i,k)=0.0 + upwd1(i,k)=0.0 + dnwd1(i,k)=0.0 + dnwd01(i,k)=0.0 + qcondc1(i,k)=0.0 + 10 continue + 20 continue + + do 30 j=1,ntra + do 31 k=1,nd + do 32 i=1,len + ftra1(i,k,j)=0.0 + 32 continue + 31 continue + 30 continue + + do 60 i=1,len + precip1(i)=0.0 + iflag1(i)=0 + wd1(i)=0.0 + cape1(i)=0.0 + VPrecip1(i,nd+1)=0.0 + 60 continue + + if (iflag_con.eq.30) then + do il=1,len + sig1(il,nd)=sig1(il,nd)+1. + sig1(il,nd)=amin1(sig1(il,nd),12.1) + enddo + endif + +!-------------------------------------------------------------------- +! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY +!-------------------------------------------------------------------- + + if (iflag_con.eq.30) then + +! print*,'Emanuel version 30 ' + CALL cv30_prelim(len,nd,ndp1,t1,q1,p1,ph1 ! nd->na + o ,lv1,cpn1,tv1,gz1,h1,hm1,th1) + endif + + if (iflag_con.eq.4) then + CALL cv_prelim(len,nd,ndp1,t1,q1,p1,ph1 + o ,lv1,cpn1,tv1,gz1,h1,hm1) + endif + +!-------------------------------------------------------------------- +! --- CONVECTIVE FEED +!-------------------------------------------------------------------- + + if (iflag_con.eq.30) then + CALL cv30_feed(len,nd,t1,q1,qs1,p1,ph1,hm1,gz1 ! nd->na + o ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1) + endif + + if (iflag_con.eq.4) then + CALL cv_feed(len,nd,t1,q1,qs1,p1,hm1,gz1 + o ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1) + endif + +!-------------------------------------------------------------------- +! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part +! (up through ICB for convect4, up through ICB+1 for convect3) +! Calculates the lifted parcel virtual temperature at nk, the +! actual temperature, and the adiabatic liquid water content. +!-------------------------------------------------------------------- + + if (iflag_con.eq.30) then + CALL cv30_undilute1(len,nd,t1,q1,qs1,gz1,plcl1,p1,nk1,icb1 ! nd->na + o ,tp1,tvp1,clw1,icbs1) + endif + + if (iflag_con.eq.4) then + CALL cv_undilute1(len,nd,t1,q1,qs1,gz1,p1,nk1,icb1,icbmax + : ,tp1,tvp1,clw1) + endif + +!------------------------------------------------------------------- +! --- TRIGGERING +!------------------------------------------------------------------- + + if (iflag_con.eq.30) then + CALL cv30_trigger(len,nd,icb1,plcl1,p1,th1,tv1,tvp1 ! nd->na + o ,pbase1,buoybase1,iflag1,sig1,w01) + endif + + if (iflag_con.eq.4) then + CALL cv_trigger(len,nd,icb1,cbmf1,tv1,tvp1,iflag1) + endif + +!===================================================================== +! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY +!===================================================================== + + ncum=0 + do 400 i=1,len + if(iflag1(i).eq.0)then + ncum=ncum+1 + idcum(ncum)=i + endif + 400 continue + +c print*,'klon, ncum = ',len,ncum + + IF (ncum.gt.0) THEN + +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! --- COMPRESS THE FIELDS +! (-> vectorization over convective gridpoints) +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + if (iflag_con.eq.30) then + CALL cv30_compress( len,nloc,ncum,nd,ntra + : ,iflag1,nk1,icb1,icbs1 + : ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1 + : ,t1,q1,qs1,u1,v1,gz1,th1 + : ,tra1 + : ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 + : ,sig1,w01 + o ,iflag,nk,icb,icbs + o ,plcl,tnk,qnk,gznk,pbase,buoybase + o ,t,q,qs,u,v,gz,th + o ,tra + o ,h,lv,cpn,p,ph,tv,tp,tvp,clw + o ,sig,w0 ) + endif + + if (iflag_con.eq.4) then + CALL cv_compress( len,nloc,ncum,nd + : ,iflag1,nk1,icb1 + : ,cbmf1,plcl1,tnk1,qnk1,gznk1 + : ,t1,q1,qs1,u1,v1,gz1 + : ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 + o ,iflag,nk,icb + o ,cbmf,plcl,tnk,qnk,gznk + o ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw + o ,dph ) + endif + +!------------------------------------------------------------------- +! --- UNDILUTE (ADIABATIC) UPDRAFT / second part : +! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +! --- & +! --- COMPUTE THE PRECIPITATION EFFICIENCIES AND THE +! --- FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD +! --- & +! --- FIND THE LEVEL OF NEUTRAL BUOYANCY +!------------------------------------------------------------------- + + if (iflag_con.eq.30) then + CALL cv30_undilute2(nloc,ncum,nd,icb,icbs,nk !na->nd + : ,tnk,qnk,gznk,t,q,qs,gz + : ,p,h,tv,lv,pbase,buoybase,plcl + o ,inb,tp,tvp,clw,hp,ep,sigp,buoy) + endif + + if (iflag_con.eq.4) then + CALL cv_undilute2(nloc,ncum,nd,icb,nk + : ,tnk,qnk,gznk,t,q,qs,gz + : ,p,dph,h,tv,lv + o ,inb,inbis,tp,tvp,clw,hp,ep,sigp,frac) + endif + +!------------------------------------------------------------------- +! --- CLOSURE +!------------------------------------------------------------------- + + if (iflag_con.eq.30) then + CALL cv30_closure(nloc,ncum,nd,icb,inb ! na->nd + : ,pbase,p,ph,tv,buoy + o ,sig,w0,cape,m) + endif + + if (iflag_con.eq.4) then + CALL cv_closure(nloc,ncum,nd,nk,icb + : ,tv,tvp,p,ph,dph,plcl,cpn + o ,iflag,cbmf) + endif + +!------------------------------------------------------------------- +! --- MIXING +!------------------------------------------------------------------- + + if (iflag_con.eq.30) then + CALL cv30_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb ! na->nd + : ,ph,t,q,qs,u,v,tra,h,lv,qnk + : ,hp,tv,tvp,ep,clw,m,sig + o ,ment,qent,uent,vent,sij,elij,ments,qents,traent) + endif + + if (iflag_con.eq.4) then + CALL cv_mixing(nloc,ncum,nd,icb,nk,inb,inbis + : ,ph,t,q,qs,u,v,h,lv,qnk + : ,hp,tv,tvp,ep,clw,cbmf + o ,m,ment,qent,uent,vent,nent,sij,elij) + endif + +!------------------------------------------------------------------- +! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS +!------------------------------------------------------------------- + + if (iflag_con.eq.30) then + CALL cv30_unsat(nloc,ncum,nd,nd,ntra,icb,inb ! na->nd + : ,t,q,qs,gz,u,v,tra,p,ph + : ,th,tv,lv,cpn,ep,sigp,clw + : ,m,ment,elij,delt,plcl + o ,mp,qp,up,vp,trap,wt,water,evap,b) + endif + + if (iflag_con.eq.4) then + CALL cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph + : ,h,lv,ep,sigp,clw,m,ment,elij + o ,iflag,mp,qp,up,vp,wt,water,evap) + endif + +!------------------------------------------------------------------- +! --- YIELD +! (tendencies, precipitation, variables of interface with other +! processes, etc) +!------------------------------------------------------------------- + + if (iflag_con.eq.30) then + CALL cv30_yield(nloc,ncum,nd,nd,ntra ! na->nd + : ,icb,inb,delt + : ,t,q,u,v,tra,gz,p,ph,h,hp,lv,cpn,th + : ,ep,clw,m,tp,mp,qp,up,vp,trap + : ,wt,water,evap,b + : ,ment,qent,uent,vent,nent,elij,traent,sig + : ,tv,tvp + o ,iflag,precip,VPrecip,ft,fq,fu,fv,ftra + o ,upwd,dnwd,dnwd0,ma,mike,tls,tps,qcondc,wd) + endif + + if (iflag_con.eq.4) then + CALL cv_yield(nloc,ncum,nd,nk,icb,inb,delt + : ,t,q,u,v,gz,p,ph,h,hp,lv,cpn + : ,ep,clw,frac,m,mp,qp,up,vp + : ,wt,water,evap + : ,ment,qent,uent,vent,nent,elij + : ,tv,tvp + o ,iflag,wd,qprime,tprime + o ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc) + endif + +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! --- passive tracers +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + if (iflag_con.eq.30) then + CALL cv30_tracer(nloc,len,ncum,nd,nd, + : ment,sij,da,phi) + endif + +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! --- UNCOMPRESS THE FIELDS +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +c set iflag1 =42 for non convective points + do i=1,len + iflag1(i)=42 + end do +c + if (iflag_con.eq.30) then + CALL cv30_uncompress(nloc,len,ncum,nd,ntra,idcum + : ,iflag + : ,precip,VPrecip,sig,w0 + : ,ft,fq,fu,fv,ftra + : ,inb + : ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape + : ,da,phi,mp + o ,iflag1 + o ,precip1,VPrecip1,sig1,w01 + o ,ft1,fq1,fu1,fv1,ftra1 + o ,inb1 + o ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1 + o ,da1,phi1,mp1) + endif + + if (iflag_con.eq.4) then + CALL cv_uncompress(nloc,len,ncum,nd,idcum + : ,iflag + : ,precip,cbmf + : ,ft,fq,fu,fv + : ,Ma,qcondc + o ,iflag1 + o ,precip1,cbmf1 + o ,ft1,fq1,fu1,fv1 + o ,Ma1,qcondc1 ) + endif + + ENDIF ! ncum>0 + +9999 continue + + return + end + +!================================================================== + SUBROUTINE cv_flag + implicit none + +#include "cvflag.h" + +c -- si .TRUE., on rend la gravite plus explicite et eventuellement +c differente de 10.0 dans convect3: + cvflag_grav = .TRUE. + + return + end + +!================================================================== + SUBROUTINE cv_thermo(iflag_con) + implicit none + +c------------------------------------------------------------- +c Set thermodynamical constants for convectL +c------------------------------------------------------------- + +#include "YOMCST.h" +#include "cvthermo.h" + + integer iflag_con + + +c original set from convect: + if (iflag_con.eq.4) then + cpd=1005.7 + cpv=1870.0 + cl=4190.0 + rrv=461.5 + rrd=287.04 + lv0=2.501E6 + g=9.8 + t0=273.15 + grav=g + else + +c constants consistent with LMDZ: + cpd = RCPD + cpv = RCPV + cl = RCW + rrv = RV + rrd = RD + lv0 = RLVTT + g = RG ! not used in convect3 +c ori t0 = RTT + t0 = 273.15 ! convect3 (RTT=273.16) +c maf grav= 10. ! implicitely or explicitely used in convect3 + grav= g ! implicitely or explicitely used in convect3 + endif + + rowl=1000.0 !(a quelle variable de YOMCST cela correspond-il?) + + clmcpv=cl-cpv + clmcpd=cl-cpd + cpdmcp=cpd-cpv + cpvmcpd=cpv-cpd + cpvmcl=cl-cpv ! for convect3 + eps=rrd/rrv + epsi=1.0/eps + epsim1=epsi-1.0 +c ginv=1.0/g + ginv=1.0/grav + hrd=0.5*rrd + + return + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv_routines.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv_routines.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cv_routines.F (revision 1280) @@ -0,0 +1,1755 @@ +! +! $Header$ +! + SUBROUTINE cv_param(nd) + implicit none + +c------------------------------------------------------------ +c Set parameters for convectL +c (includes microphysical parameters and parameters that +c control the rate of approach to quasi-equilibrium) +c------------------------------------------------------------ + +C *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) *** +C *** TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO- *** +C *** CONVERSION THRESHOLD IS ASSUMED TO BE ZERO *** +C *** (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY *** +C *** BETWEEN 0 C AND TLCRIT) *** +C *** ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT *** +C *** FORMULATION *** +C *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** +C *** SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** +C *** OF CLOUD *** +C *** OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN *** +C *** OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW *** +C *** COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** +C *** OF RAIN *** +C *** COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** +C *** OF SNOW *** +C *** CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM *** +C *** TRANSPORT *** +C *** DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION *** +C *** A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC *** +C *** ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** (THEIR STANDARD VALUES ARE 0.20 AND 0.1, RESPECTIVELY) *** +C *** (DAMP MUST BE LESS THAN 1) *** + +#include "cvparam.h" + integer nd + +c noff: integer limit for convection (nd-noff) +c minorig: First level of convection + + noff = 2 + minorig = 2 + + nl=nd-noff + nlp=nl+1 + nlm=nl-1 + + elcrit=0.0011 + tlcrit=-55.0 + entp=1.5 + sigs=0.12 + sigd=0.05 + omtrain=50.0 + omtsnow=5.5 + coeffr=1.0 + coeffs=0.8 + dtmax=0.9 +c + cu=0.70 +c + betad=10.0 +c + damp=0.1 + alpha=0.2 +c + delta=0.01 ! cld +c + return + end + + SUBROUTINE cv_prelim(len,nd,ndp1,t,q,p,ph + : ,lv,cpn,tv,gz,h,hm) + implicit none + +!===================================================================== +! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY +!===================================================================== + +c inputs: + integer len, nd, ndp1 + real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1) + +c outputs: + real lv(len,nd), cpn(len,nd), tv(len,nd) + real gz(len,nd), h(len,nd), hm(len,nd) + +c local variables: + integer k, i + real cpx(len,nd) + +#include "cvthermo.h" +#include "cvparam.h" + + + do 110 k=1,nlp + do 100 i=1,len + lv(i,k)= lv0-clmcpv*(t(i,k)-t0) + cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k) + cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k) + tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1) + 100 continue + 110 continue +c +c gz = phi at the full levels (same as p). +c + do 120 i=1,len + gz(i,1)=0.0 + 120 continue + do 140 k=2,nlp + do 130 i=1,len + gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k)) + & *(p(i,k-1)-p(i,k))/ph(i,k) + 130 continue + 140 continue +c +c h = phi + cpT (dry static energy). +c hm = phi + cp(T-Tbase)+Lq +c + do 170 k=1,nlp + do 160 i=1,len + h(i,k)=gz(i,k)+cpn(i,k)*t(i,k) + hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k) + 160 continue + 170 continue + + return + end + + SUBROUTINE cv_feed(len,nd,t,q,qs,p,hm,gz + : ,nk,icb,icbmax,iflag,tnk,qnk,gznk,plcl) + implicit none + +C================================================================ +C Purpose: CONVECTIVE FEED +C================================================================ + +#include "cvparam.h" + +c inputs: + integer len, nd + real t(len,nd), q(len,nd), qs(len,nd), p(len,nd) + real hm(len,nd), gz(len,nd) + +c outputs: + integer iflag(len), nk(len), icb(len), icbmax + real tnk(len), qnk(len), gznk(len), plcl(len) + +c local variables: + integer i, k + integer ihmin(len) + real work(len) + real pnk(len), qsnk(len), rh(len), chi(len) + +!------------------------------------------------------------------- +! --- Find level of minimum moist static energy +! --- If level of minimum moist static energy coincides with +! --- or is lower than minimum allowable parcel origin level, +! --- set iflag to 6. +!------------------------------------------------------------------- + + do 180 i=1,len + work(i)=1.0e12 + ihmin(i)=nl + 180 continue + do 200 k=2,nlp + do 190 i=1,len + if((hm(i,k).lt.work(i)).and. + & (hm(i,k).lt.hm(i,k-1)))then + work(i)=hm(i,k) + ihmin(i)=k + endif + 190 continue + 200 continue + do 210 i=1,len + ihmin(i)=min(ihmin(i),nlm) + if(ihmin(i).le.minorig)then + iflag(i)=6 + endif + 210 continue +c +!------------------------------------------------------------------- +! --- Find that model level below the level of minimum moist static +! --- energy that has the maximum value of moist static energy +!------------------------------------------------------------------- + + do 220 i=1,len + work(i)=hm(i,minorig) + nk(i)=minorig + 220 continue + do 240 k=minorig+1,nl + do 230 i=1,len + if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then + work(i)=hm(i,k) + nk(i)=k + endif + 230 continue + 240 continue +!------------------------------------------------------------------- +! --- Check whether parcel level temperature and specific humidity +! --- are reasonable +!------------------------------------------------------------------- + do 250 i=1,len + if(((t(i,nk(i)).lt.250.0).or. + & (q(i,nk(i)).le.0.0).or. + & (p(i,ihmin(i)).lt.400.0)).and. + & (iflag(i).eq.0))iflag(i)=7 + 250 continue +!------------------------------------------------------------------- +! --- Calculate lifted condensation level of air at parcel origin level +! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980) +!------------------------------------------------------------------- + do 260 i=1,len + tnk(i)=t(i,nk(i)) + qnk(i)=q(i,nk(i)) + gznk(i)=gz(i,nk(i)) + pnk(i)=p(i,nk(i)) + qsnk(i)=qs(i,nk(i)) +c + rh(i)=qnk(i)/qsnk(i) + rh(i)=min(1.0,rh(i)) + chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i)) + plcl(i)=pnk(i)*(rh(i)**chi(i)) + if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0)) + & .and.(iflag(i).eq.0))iflag(i)=8 + 260 continue +!------------------------------------------------------------------- +! --- Calculate first level above lcl (=icb) +!------------------------------------------------------------------- + do 270 i=1,len + icb(i)=nlm + 270 continue +c + do 290 k=minorig,nl + do 280 i=1,len + if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i))) + & icb(i)=min(icb(i),k) + 280 continue + 290 continue +c + do 300 i=1,len + if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9 + 300 continue +c +c Compute icbmax. +c + icbmax=2 + do 310 i=1,len + icbmax=max(icbmax,icb(i)) + 310 continue + + return + end + + SUBROUTINE cv_undilute1(len,nd,t,q,qs,gz,p,nk,icb,icbmax + : ,tp,tvp,clw) + implicit none + +#include "cvthermo.h" +#include "cvparam.h" + +c inputs: + integer len, nd + integer nk(len), icb(len), icbmax + real t(len,nd), q(len,nd), qs(len,nd), gz(len,nd) + real p(len,nd) + +c outputs: + real tp(len,nd), tvp(len,nd), clw(len,nd) + +c local variables: + integer i, k + real tg, qg, alv, s, ahg, tc, denom, es, rg + real ah0(len), cpp(len) + real tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len) + +!------------------------------------------------------------------- +! --- Calculates the lifted parcel virtual temperature at nk, +! --- the actual temperature, and the adiabatic +! --- liquid water content. The procedure is to solve the equation. +! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. +!------------------------------------------------------------------- + + do 320 i=1,len + tnk(i)=t(i,nk(i)) + qnk(i)=q(i,nk(i)) + gznk(i)=gz(i,nk(i)) + ticb(i)=t(i,icb(i)) + gzicb(i)=gz(i,icb(i)) + 320 continue +c +c *** Calculate certain parcel quantities, including static energy *** +c + do 330 i=1,len + ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + & +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i) + cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv + 330 continue +c +c *** Calculate lifted parcel quantities below cloud base *** +c + do 350 k=minorig,icbmax-1 + do 340 i=1,len + tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))/cpp(i) + tvp(i,k)=tp(i,k)*(1.+qnk(i)*epsi) + 340 continue + 350 continue +c +c *** Find lifted parcel quantities above cloud base *** +c + do 360 i=1,len + tg=ticb(i) + qg=qs(i,icb(i)) + alv=lv0-clmcpv*(ticb(i)-t0) +c +c First iteration. +c + s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-t0 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + endif + qg=eps*es/(p(i,icb(i))-es*(1.-eps)) +c +c Second iteration. +c + s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-t0 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + end if + qg=eps*es/(p(i,icb(i))-es*(1.-eps)) +c + alv=lv0-clmcpv*(ticb(i)-273.15) + tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i) + & -gz(i,icb(i))-alv*qg)/cpd + clw(i,icb(i))=qnk(i)-qg + clw(i,icb(i))=max(0.0,clw(i,icb(i))) + rg=qg/(1.-qnk(i)) + tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi) + 360 continue +c + do 380 k=minorig,icbmax + do 370 i=1,len + tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i) + 370 continue + 380 continue +c + return + end + + SUBROUTINE cv_trigger(len,nd,icb,cbmf,tv,tvp,iflag) + implicit none + +!------------------------------------------------------------------- +! --- Test for instability. +! --- If there was no convection at last time step and parcel +! --- is stable at icb, then set iflag to 4. +!------------------------------------------------------------------- + +#include "cvparam.h" + +c inputs: + integer len, nd, icb(len) + real cbmf(len), tv(len,nd), tvp(len,nd) + +c outputs: + integer iflag(len) ! also an input + +c local variables: + integer i + + + do 390 i=1,len + if((cbmf(i).eq.0.0) .and.(iflag(i).eq.0).and. + & (tvp(i,icb(i)).le.(tv(i,icb(i))-dtmax)))iflag(i)=4 + 390 continue + + return + end + + SUBROUTINE cv_compress( len,nloc,ncum,nd + : ,iflag1,nk1,icb1 + : ,cbmf1,plcl1,tnk1,qnk1,gznk1 + : ,t1,q1,qs1,u1,v1,gz1 + : ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 + o ,iflag,nk,icb + o ,cbmf,plcl,tnk,qnk,gznk + o ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw + o ,dph ) + implicit none + +#include "cvparam.h" + +c inputs: + integer len,ncum,nd,nloc + integer iflag1(len),nk1(len),icb1(len) + real cbmf1(len),plcl1(len),tnk1(len),qnk1(len),gznk1(len) + real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd) + real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd) + real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd) + real tvp1(len,nd),clw1(len,nd) + +c outputs: + integer iflag(nloc),nk(nloc),icb(nloc) + real cbmf(nloc),plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc) + real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd) + real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd) + real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd) + real tvp(nloc,nd),clw(nloc,nd) + real dph(nloc,nd) + +c local variables: + integer i,k,nn + + + do 110 k=1,nl+1 + nn=0 + do 100 i=1,len + if(iflag1(i).eq.0)then + nn=nn+1 + t(nn,k)=t1(i,k) + q(nn,k)=q1(i,k) + qs(nn,k)=qs1(i,k) + u(nn,k)=u1(i,k) + v(nn,k)=v1(i,k) + gz(nn,k)=gz1(i,k) + h(nn,k)=h1(i,k) + lv(nn,k)=lv1(i,k) + cpn(nn,k)=cpn1(i,k) + p(nn,k)=p1(i,k) + ph(nn,k)=ph1(i,k) + tv(nn,k)=tv1(i,k) + tp(nn,k)=tp1(i,k) + tvp(nn,k)=tvp1(i,k) + clw(nn,k)=clw1(i,k) + endif + 100 continue + 110 continue + + if (nn.ne.ncum) then + print*,'strange! nn not equal to ncum: ',nn,ncum + stop + endif + + nn=0 + do 150 i=1,len + if(iflag1(i).eq.0)then + nn=nn+1 + cbmf(nn)=cbmf1(i) + plcl(nn)=plcl1(i) + tnk(nn)=tnk1(i) + qnk(nn)=qnk1(i) + gznk(nn)=gznk1(i) + nk(nn)=nk1(i) + icb(nn)=icb1(i) + iflag(nn)=iflag1(i) + endif + 150 continue + + do 170 k=1,nl + do 160 i=1,ncum + dph(i,k)=ph(i,k)-ph(i,k+1) + 160 continue + 170 continue + + return + end + + SUBROUTINE cv_undilute2(nloc,ncum,nd,icb,nk + : ,tnk,qnk,gznk,t,q,qs,gz + : ,p,dph,h,tv,lv + o ,inb,inb1,tp,tvp,clw,hp,ep,sigp,frac) + implicit none + +C--------------------------------------------------------------------- +C Purpose: +C FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +C & +C COMPUTE THE PRECIPITATION EFFICIENCIES AND THE +C FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD +C & +C FIND THE LEVEL OF NEUTRAL BUOYANCY +C--------------------------------------------------------------------- + +#include "cvthermo.h" +#include "cvparam.h" + +c inputs: + integer ncum, nd, nloc + integer icb(nloc), nk(nloc) + real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd) + real p(nloc,nd), dph(nloc,nd) + real tnk(nloc), qnk(nloc), gznk(nloc) + real lv(nloc,nd), tv(nloc,nd), h(nloc,nd) + +c outputs: + integer inb(nloc), inb1(nloc) + real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd) + real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd) + real frac(nloc) + +c local variables: + integer i, k + real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit + real by, defrac + real ah0(nloc), cape(nloc), capem(nloc), byp(nloc) + logical lcape(nloc) + +!===================================================================== +! --- SOME INITIALIZATIONS +!===================================================================== + + do 170 k=1,nl + do 160 i=1,ncum + ep(i,k)=0.0 + sigp(i,k)=sigs + 160 continue + 170 continue + +!===================================================================== +! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +!===================================================================== +c +c --- The procedure is to solve the equation. +c cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. +c +c *** Calculate certain parcel quantities, including static energy *** +c +c + do 240 i=1,ncum + ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + & +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i) + 240 continue +c +c +c *** Find lifted parcel quantities above cloud base *** +c +c + do 300 k=minorig+1,nl + do 290 i=1,ncum + if(k.ge.(icb(i)+1))then + tg=t(i,k) + qg=qs(i,k) + alv=lv0-clmcpv*(t(i,k)-t0) +c +c First iteration. +c + s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-t0 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c +c Second iteration. +c + s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-t0 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c + alv=lv0-clmcpv*(t(i,k)-t0) +c print*,'cpd dans convect2 ',cpd +c print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd' +c print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd + tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd +c if (.not.cpd.gt.1000.) then +c print*,'CPD=',cpd +c stop +c endif + clw(i,k)=qnk(i)-qg + clw(i,k)=max(0.0,clw(i,k)) + rg=qg/(1.-qnk(i)) + tvp(i,k)=tp(i,k)*(1.+rg*epsi) + endif + 290 continue + 300 continue +c +!===================================================================== +! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF +! --- PRECIPITATION FALLING OUTSIDE OF CLOUD +! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I) +!===================================================================== +c + do 320 k=minorig+1,nl + do 310 i=1,ncum + if(k.ge.(nk(i)+1))then + tca=tp(i,k)-t0 + if(tca.ge.0.0)then + elacrit=elcrit + else + elacrit=elcrit*(1.0-tca/tlcrit) + endif + elacrit=max(elacrit,0.0) + ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8) + ep(i,k)=max(ep(i,k),0.0 ) + ep(i,k)=min(ep(i,k),1.0 ) + sigp(i,k)=sigs + endif + 310 continue + 320 continue +c +!===================================================================== +! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL +! --- VIRTUAL TEMPERATURE +!===================================================================== +c + do 340 k=minorig+1,nl + do 330 i=1,ncum + if(k.ge.(icb(i)+1))then + tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k)) +c print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)' +c print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k) + endif + 330 continue + 340 continue + do 350 i=1,ncum + tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd + 350 continue +c +c===================================================================== +c --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S +c --- HIGHEST LEVEL OF NEUTRAL BUOYANCY +c --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB) +c===================================================================== +c + do 510 i=1,ncum + cape(i)=0.0 + capem(i)=0.0 + inb(i)=icb(i)+1 + inb1(i)=inb(i) + 510 continue +c +c Originial Code +c +c do 530 k=minorig+1,nl-1 +c do 520 i=1,ncum +c if(k.ge.(icb(i)+1))then +c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c cape(i)=cape(i)+by +c if(by.ge.0.0)inb1(i)=k+1 +c if(cape(i).gt.0.0)then +c inb(i)=k+1 +c capem(i)=cape(i) +c endif +c endif +c520 continue +c530 continue +c do 540 i=1,ncum +c byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl) +c cape(i)=capem(i)+byp +c defrac=capem(i)-cape(i) +c defrac=max(defrac,0.001) +c frac(i)=-cape(i)/defrac +c frac(i)=min(frac(i),1.0) +c frac(i)=max(frac(i),0.0) +c540 continue +c +c K Emanuel fix +c +c call zilch(byp,ncum) +c do 530 k=minorig+1,nl-1 +c do 520 i=1,ncum +c if(k.ge.(icb(i)+1))then +c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c cape(i)=cape(i)+by +c if(by.ge.0.0)inb1(i)=k+1 +c if(cape(i).gt.0.0)then +c inb(i)=k+1 +c capem(i)=cape(i) +c byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c endif +c endif +c520 continue +c530 continue +c do 540 i=1,ncum +c inb(i)=max(inb(i),inb1(i)) +c cape(i)=capem(i)+byp(i) +c defrac=capem(i)-cape(i) +c defrac=max(defrac,0.001) +c frac(i)=-cape(i)/defrac +c frac(i)=min(frac(i),1.0) +c frac(i)=max(frac(i),0.0) +c540 continue +c +c J Teixeira fix +c + call zilch(byp,ncum) + do 515 i=1,ncum + lcape(i)=.true. + 515 continue + do 530 k=minorig+1,nl-1 + do 520 i=1,ncum + if(cape(i).lt.0.0)lcape(i)=.false. + if((k.ge.(icb(i)+1)).and.lcape(i))then + by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) + byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) + cape(i)=cape(i)+by + if(by.ge.0.0)inb1(i)=k+1 + if(cape(i).gt.0.0)then + inb(i)=k+1 + capem(i)=cape(i) + endif + endif + 520 continue + 530 continue + do 540 i=1,ncum + cape(i)=capem(i)+byp(i) + defrac=capem(i)-cape(i) + defrac=max(defrac,0.001) + frac(i)=-cape(i)/defrac + frac(i)=min(frac(i),1.0) + frac(i)=max(frac(i),0.0) + 540 continue +c +c===================================================================== +c --- CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL +c===================================================================== +c +c initialization: + do i=1,ncum*nlp + hp(i,1)=h(i,1) + enddo + + do 600 k=minorig+1,nl + do 590 i=1,ncum + if((k.ge.icb(i)).and.(k.le.inb(i)))then + hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k) + endif + 590 continue + 600 continue +c + return + end +c + SUBROUTINE cv_closure(nloc,ncum,nd,nk,icb + : ,tv,tvp,p,ph,dph,plcl,cpn + : ,iflag,cbmf) + implicit none + +c inputs: + integer ncum, nd, nloc + integer nk(nloc), icb(nloc) + real tv(nloc,nd), tvp(nloc,nd), p(nloc,nd), dph(nloc,nd) + real ph(nloc,nd+1) ! caution nd instead ndp1 to be consistent... + real plcl(nloc), cpn(nloc,nd) + +c outputs: + integer iflag(nloc) + real cbmf(nloc) ! also an input + +c local variables: + integer i, k, icbmax + real dtpbl(nloc), dtmin(nloc), tvpplcl(nloc), tvaplcl(nloc) + real work(nloc) + +#include "cvthermo.h" +#include "cvparam.h" + +c------------------------------------------------------------------- +c Compute icbmax. +c------------------------------------------------------------------- + + icbmax=2 + do 230 i=1,ncum + icbmax=max(icbmax,icb(i)) + 230 continue + +c===================================================================== +c --- CALCULATE CLOUD BASE MASS FLUX +c===================================================================== +c +c tvpplcl = parcel temperature lifted adiabatically from level +c icb-1 to the LCL. +c tvaplcl = virtual temperature at the LCL. +c + do 610 i=1,ncum + dtpbl(i)=0.0 + tvpplcl(i)=tvp(i,icb(i)-1) + & -rrd*tvp(i,icb(i)-1)*(p(i,icb(i)-1)-plcl(i)) + & /(cpn(i,icb(i)-1)*p(i,icb(i)-1)) + tvaplcl(i)=tv(i,icb(i)) + & +(tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i,icb(i))) + & /(p(i,icb(i))-p(i,icb(i)+1)) + 610 continue + +c------------------------------------------------------------------- +c --- Interpolate difference between lifted parcel and +c --- environmental temperatures to lifted condensation level +c------------------------------------------------------------------- +c +c dtpbl = average of tvp-tv in the PBL (k=nk to icb-1). +c + do 630 k=minorig,icbmax + do 620 i=1,ncum + if((k.ge.nk(i)).and.(k.le.(icb(i)-1)))then + dtpbl(i)=dtpbl(i)+(tvp(i,k)-tv(i,k))*dph(i,k) + endif + 620 continue + 630 continue + do 640 i=1,ncum + dtpbl(i)=dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i))) + dtmin(i)=tvpplcl(i)-tvaplcl(i)+dtmax+dtpbl(i) + 640 continue +c +c------------------------------------------------------------------- +c --- Adjust cloud base mass flux +c------------------------------------------------------------------- +c + do 650 i=1,ncum + work(i)=cbmf(i) + cbmf(i)=max(0.0,(1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i)) + if((work(i).eq.0.0).and.(cbmf(i).eq.0.0))then + iflag(i)=3 + endif + 650 continue + + return + end + + SUBROUTINE cv_mixing(nloc,ncum,nd,icb,nk,inb,inb1 + : ,ph,t,q,qs,u,v,h,lv,qnk + : ,hp,tv,tvp,ep,clw,cbmf + : ,m,ment,qent,uent,vent,nent,sij,elij) + implicit none + +#include "cvthermo.h" +#include "cvparam.h" + +c inputs: + integer ncum, nd, nloc + integer icb(nloc), inb(nloc), inb1(nloc), nk(nloc) + real cbmf(nloc), qnk(nloc) + real ph(nloc,nd+1) + real t(nloc,nd), q(nloc,nd), qs(nloc,nd), lv(nloc,nd) + real u(nloc,nd), v(nloc,nd), h(nloc,nd), hp(nloc,nd) + real tv(nloc,nd), tvp(nloc,nd), ep(nloc,nd), clw(nloc,nd) + +c outputs: + integer nent(nloc,nd) + real m(nloc,nd), ment(nloc,nd,nd), qent(nloc,nd,nd) + real uent(nloc,nd,nd), vent(nloc,nd,nd) + real sij(nloc,nd,nd), elij(nloc,nd,nd) + +c local variables: + integer i, j, k, ij + integer num1, num2 + real dbo, qti, bf2, anum, denom, dei, altem, cwat, stemp + real alt, qp1, smid, sjmin, sjmax, delp, delm + real work(nloc), asij(nloc), smin(nloc), scrit(nloc) + real bsum(nloc,nd) + logical lwork(nloc) + +c===================================================================== +c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS +c===================================================================== +c + do 360 i=1,ncum*nlp + nent(i,1)=0 + m(i,1)=0.0 + 360 continue +c + do 400 k=1,nlp + do 390 j=1,nlp + do 385 i=1,ncum + qent(i,k,j)=q(i,j) + uent(i,k,j)=u(i,j) + vent(i,k,j)=v(i,j) + elij(i,k,j)=0.0 + ment(i,k,j)=0.0 + sij(i,k,j)=0.0 + 385 continue + 390 continue + 400 continue +c +c------------------------------------------------------------------- +c --- Calculate rates of mixing, m(i) +c------------------------------------------------------------------- +c + call zilch(work,ncum) +c + do 670 j=minorig+1,nl + do 660 i=1,ncum + if((j.ge.(icb(i)+1)).and.(j.le.inb(i)))then + k=min(j,inb1(i)) + dbo=abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1)) + & +entp*0.04*(ph(i,k)-ph(i,k+1)) + work(i)=work(i)+dbo + m(i,j)=cbmf(i)*dbo + endif + 660 continue + 670 continue + do 690 k=minorig+1,nl + do 680 i=1,ncum + if((k.ge.(icb(i)+1)).and.(k.le.inb(i)))then + m(i,k)=m(i,k)/work(i) + endif + 680 continue + 690 continue +c +c +c===================================================================== +c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING +c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING +c --- FRACTION (sij) +c===================================================================== +c +c + do 750 i=minorig+1,nl + do 710 j=minorig+1,nl + do 700 ij=1,ncum + if((i.ge.(icb(ij)+1)).and.(j.ge.icb(ij)) + & .and.(i.le.inb(ij)).and.(j.le.inb(ij)))then + qti=qnk(ij)-ep(ij,i)*clw(ij,i) + bf2=1.+lv(ij,j)*lv(ij,j)*qs(ij,j) + & /(rrv*t(ij,j)*t(ij,j)*cpd) + anum=h(ij,j)-hp(ij,i)+(cpv-cpd)*t(ij,j)*(qti-q(ij,j)) + denom=h(ij,i)-hp(ij,i)+(cpd-cpv)*(q(ij,i)-qti)*t(ij,j) + dei=denom + if(abs(dei).lt.0.01)dei=0.01 + sij(ij,i,j)=anum/dei + sij(ij,i,i)=1.0 + altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j) + altem=altem/bf2 + cwat=clw(ij,j)*(1.-ep(ij,j)) + stemp=sij(ij,i,j) + if((stemp.lt.0.0.or.stemp.gt.1.0.or. + 1 altem.gt.cwat).and.j.gt.i)then + anum=anum-lv(ij,j)*(qti-qs(ij,j)-cwat*bf2) + denom=denom+lv(ij,j)*(q(ij,i)-qti) + if(abs(denom).lt.0.01)denom=0.01 + sij(ij,i,j)=anum/denom + altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j) + altem=altem-(bf2-1.)*cwat + endif + if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then + qent(ij,i,j)=sij(ij,i,j)*q(ij,i) + & +(1.-sij(ij,i,j))*qti + uent(ij,i,j)=sij(ij,i,j)*u(ij,i) + & +(1.-sij(ij,i,j))*u(ij,nk(ij)) + vent(ij,i,j)=sij(ij,i,j)*v(ij,i) + & +(1.-sij(ij,i,j))*v(ij,nk(ij)) + elij(ij,i,j)=altem + elij(ij,i,j)=max(0.0,elij(ij,i,j)) + ment(ij,i,j)=m(ij,i)/(1.-sij(ij,i,j)) + nent(ij,i)=nent(ij,i)+1 + endif + sij(ij,i,j)=max(0.0,sij(ij,i,j)) + sij(ij,i,j)=min(1.0,sij(ij,i,j)) + endif + 700 continue + 710 continue +c +c *** If no air can entrain at level i assume that updraft detrains *** +c *** at that level and calculate detrained air flux and properties *** +c + do 740 ij=1,ncum + if((i.ge.(icb(ij)+1)).and.(i.le.inb(ij)) + & .and.(nent(ij,i).eq.0))then + ment(ij,i,i)=m(ij,i) + qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i) + uent(ij,i,i)=u(ij,nk(ij)) + vent(ij,i,i)=v(ij,nk(ij)) + elij(ij,i,i)=clw(ij,i) + sij(ij,i,i)=1.0 + endif + 740 continue + 750 continue +c + do 770 i=1,ncum + sij(i,inb(i),inb(i))=1.0 + 770 continue +c +c===================================================================== +c --- NORMALIZE ENTRAINED AIR MASS FLUXES +c --- TO REPRESENT EQUAL PROBABILITIES OF MIXING +c===================================================================== +c + call zilch(bsum,ncum*nlp) + do 780 ij=1,ncum + lwork(ij)=.false. + 780 continue + do 789 i=minorig+1,nl +c + num1=0 + do 779 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))num1=num1+1 + 779 continue + if(num1.le.0)go to 789 +c + do 781 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))then + lwork(ij)=(nent(ij,i).ne.0) + qp1=q(ij,nk(ij))-ep(ij,i)*clw(ij,i) + anum=h(ij,i)-hp(ij,i)-lv(ij,i)*(qp1-qs(ij,i)) + denom=h(ij,i)-hp(ij,i)+lv(ij,i)*(q(ij,i)-qp1) + if(abs(denom).lt.0.01)denom=0.01 + scrit(ij)=anum/denom + alt=qp1-qs(ij,i)+scrit(ij)*(q(ij,i)-qp1) + if(scrit(ij).lt.0.0.or.alt.lt.0.0)scrit(ij)=1.0 + asij(ij)=0.0 + smin(ij)=1.0 + endif + 781 continue + do 783 j=minorig,nl +c + num2=0 + do 778 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(j.ge.icb(ij)).and.(j.le.inb(ij)) + & .and.lwork(ij))num2=num2+1 + 778 continue + if(num2.le.0)go to 783 +c + do 782 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(j.ge.icb(ij)).and.(j.le.inb(ij)).and.lwork(ij))then + if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then + if(j.gt.i)then + smid=min(sij(ij,i,j),scrit(ij)) + sjmax=smid + sjmin=smid + if(smid.lt.smin(ij) + & .and.sij(ij,i,j+1).lt.smid)then + smin(ij)=smid + sjmax=min(sij(ij,i,j+1),sij(ij,i,j),scrit(ij)) + sjmin=max(sij(ij,i,j-1),sij(ij,i,j)) + sjmin=min(sjmin,scrit(ij)) + endif + else + sjmax=max(sij(ij,i,j+1),scrit(ij)) + smid=max(sij(ij,i,j),scrit(ij)) + sjmin=0.0 + if(j.gt.1)sjmin=sij(ij,i,j-1) + sjmin=max(sjmin,scrit(ij)) + endif + delp=abs(sjmax-smid) + delm=abs(sjmin-smid) + asij(ij)=asij(ij)+(delp+delm) + & *(ph(ij,j)-ph(ij,j+1)) + ment(ij,i,j)=ment(ij,i,j)*(delp+delm) + & *(ph(ij,j)-ph(ij,j+1)) + endif + endif + 782 continue + 783 continue + do 784 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)).and.lwork(ij))then + asij(ij)=max(1.0e-21,asij(ij)) + asij(ij)=1.0/asij(ij) + bsum(ij,i)=0.0 + endif + 784 continue + do 786 j=minorig,nl+1 + do 785 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(j.ge.icb(ij)).and.(j.le.inb(ij)) + & .and.lwork(ij))then + ment(ij,i,j)=ment(ij,i,j)*asij(ij) + bsum(ij,i)=bsum(ij,i)+ment(ij,i,j) + endif + 785 continue + 786 continue + do 787 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(bsum(ij,i).lt.1.0e-18).and.lwork(ij))then + nent(ij,i)=0 + ment(ij,i,i)=m(ij,i) + qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i) + uent(ij,i,i)=u(ij,nk(ij)) + vent(ij,i,i)=v(ij,nk(ij)) + elij(ij,i,i)=clw(ij,i) + sij(ij,i,i)=1.0 + endif + 787 continue + 789 continue +c + return + end + + SUBROUTINE cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph + : ,h,lv,ep,sigp,clw,m,ment,elij + : ,iflag,mp,qp,up,vp,wt,water,evap) + implicit none + + +#include "cvthermo.h" +#include "cvparam.h" + +c inputs: + integer ncum, nd, nloc + integer inb(nloc) + real t(nloc,nd), q(nloc,nd), qs(nloc,nd) + real gz(nloc,nd), u(nloc,nd), v(nloc,nd) + real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd) + real lv(nloc,nd), ep(nloc,nd), sigp(nloc,nd), clw(nloc,nd) + real m(nloc,nd), ment(nloc,nd,nd), elij(nloc,nd,nd) + +c outputs: + integer iflag(nloc) ! also an input + real mp(nloc,nd), qp(nloc,nd), up(nloc,nd), vp(nloc,nd) + real water(nloc,nd), evap(nloc,nd), wt(nloc,nd) + +c local variables: + integer i,j,k,ij,num1 + integer jtt(nloc) + real awat, coeff, qsm, afac, sigt, b6, c6, revap + real dhdp, fac, qstm, rat + real wdtrain(nloc) + logical lwork(nloc) + +c===================================================================== +c --- PRECIPITATING DOWNDRAFT CALCULATION +c===================================================================== +c +c Initializations: +c + do i = 1, ncum + do k = 1, nl+1 + wt(i,k) = omtsnow + mp(i,k) = 0.0 + evap(i,k) = 0.0 + water(i,k) = 0.0 + enddo + enddo + + do 420 i=1,ncum + qp(i,1)=q(i,1) + up(i,1)=u(i,1) + vp(i,1)=v(i,1) + 420 continue + + do 440 k=2,nl+1 + do 430 i=1,ncum + qp(i,k)=q(i,k-1) + up(i,k)=u(i,k-1) + vp(i,k)=v(i,k-1) + 430 continue + 440 continue + + +c *** Check whether ep(inb)=0, if so, skip precipitating *** +c *** downdraft calculation *** +c +c +c *** Integrate liquid water equation to find condensed water *** +c *** and condensed water flux *** +c +c + do 890 i=1,ncum + jtt(i)=2 + if(ep(i,inb(i)).le.0.0001)iflag(i)=2 + if(iflag(i).eq.0)then + lwork(i)=.true. + else + lwork(i)=.false. + endif + 890 continue +c +c *** Begin downdraft loop *** +c +c + call zilch(wdtrain,ncum) + do 899 i=nl+1,1,-1 +c + num1=0 + do 879 ij=1,ncum + if((i.le.inb(ij)).and.lwork(ij))num1=num1+1 + 879 continue + if(num1.le.0)go to 899 +c +c +c *** Calculate detrained precipitation *** +c + do 891 ij=1,ncum + if((i.le.inb(ij)).and.(lwork(ij)))then + wdtrain(ij)=g*ep(ij,i)*m(ij,i)*clw(ij,i) + endif + 891 continue +c + if(i.gt.1)then + do 893 j=1,i-1 + do 892 ij=1,ncum + if((i.le.inb(ij)).and.(lwork(ij)))then + awat=elij(ij,j,i)-(1.-ep(ij,i))*clw(ij,i) + awat=max(0.0,awat) + wdtrain(ij)=wdtrain(ij)+g*awat*ment(ij,j,i) + endif + 892 continue + 893 continue + endif +c +c *** Find rain water and evaporation using provisional *** +c *** estimates of qp(i)and qp(i-1) *** +c +c +c *** Value of terminal velocity and coeffecient of evaporation for snow *** +c + do 894 ij=1,ncum + if((i.le.inb(ij)).and.(lwork(ij)))then + coeff=coeffs + wt(ij,i)=omtsnow +c +c *** Value of terminal velocity and coeffecient of evaporation for rain *** +c + if(t(ij,i).gt.273.0)then + coeff=coeffr + wt(ij,i)=omtrain + endif + qsm=0.5*(q(ij,i)+qp(ij,i+1)) + afac=coeff*ph(ij,i)*(qs(ij,i)-qsm) + & /(1.0e4+2.0e3*ph(ij,i)*qs(ij,i)) + afac=max(afac,0.0) + sigt=sigp(ij,i) + sigt=max(0.0,sigt) + sigt=min(1.0,sigt) + b6=100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij,i) + c6=(water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij,i) + revap=0.5*(-b6+sqrt(b6*b6+4.*c6)) + evap(ij,i)=sigt*afac*revap + water(ij,i)=revap*revap +c +c *** Calculate precipitating downdraft mass flux under *** +c *** hydrostatic approximation *** +c + if(i.gt.1)then + dhdp=(h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i)) + dhdp=max(dhdp,10.0) + mp(ij,i)=100.*ginv*lv(ij,i)*sigd*evap(ij,i)/dhdp + mp(ij,i)=max(mp(ij,i),0.0) +c +c *** Add small amount of inertia to downdraft *** +c + fac=20.0/(ph(ij,i-1)-ph(ij,i)) + mp(ij,i)=(fac*mp(ij,i+1)+mp(ij,i))/(1.+fac) +c +c *** Force mp to decrease linearly to zero *** +c *** between about 950 mb and the surface *** +c + if(p(ij,i).gt.(0.949*p(ij,1)))then + jtt(ij)=max(jtt(ij),i) + mp(ij,i)=mp(ij,jtt(ij))*(p(ij,1)-p(ij,i)) + & /(p(ij,1)-p(ij,jtt(ij))) + endif + endif +c +c *** Find mixing ratio of precipitating downdraft *** +c + if(i.ne.inb(ij))then + if(i.eq.1)then + qstm=qs(ij,1) + else + qstm=qs(ij,i-1) + endif + if(mp(ij,i).gt.mp(ij,i+1))then + rat=mp(ij,i+1)/mp(ij,i) + qp(ij,i)=qp(ij,i+1)*rat+q(ij,i)*(1.0-rat)+100.*ginv* + & sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i)) + up(ij,i)=up(ij,i+1)*rat+u(ij,i)*(1.-rat) + vp(ij,i)=vp(ij,i+1)*rat+v(ij,i)*(1.-rat) + else + if(mp(ij,i+1).gt.0.0)then + qp(ij,i)=(gz(ij,i+1)-gz(ij,i) + & +qp(ij,i+1)*(lv(ij,i+1)+t(ij,i+1) + & *(cl-cpd))+cpd*(t(ij,i+1)-t(ij,i))) + & /(lv(ij,i)+t(ij,i)*(cl-cpd)) + up(ij,i)=up(ij,i+1) + vp(ij,i)=vp(ij,i+1) + endif + endif + qp(ij,i)=min(qp(ij,i),qstm) + qp(ij,i)=max(qp(ij,i),0.0) + endif + endif + 894 continue + 899 continue +c + return + end + + SUBROUTINE cv_yield(nloc,ncum,nd,nk,icb,inb,delt + : ,t,q,u,v,gz,p,ph,h,hp,lv,cpn + : ,ep,clw,frac,m,mp,qp,up,vp + : ,wt,water,evap + : ,ment,qent,uent,vent,nent,elij + : ,tv,tvp + o ,iflag,wd,qprime,tprime + o ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc) + implicit none + +#include "cvthermo.h" +#include "cvparam.h" + +c inputs + integer ncum, nd, nloc + integer nk(nloc), icb(nloc), inb(nloc) + integer nent(nloc,nd) + real delt + real t(nloc,nd), q(nloc,nd), u(nloc,nd), v(nloc,nd) + real gz(nloc,nd) + real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd) + real hp(nloc,nd), lv(nloc,nd) + real cpn(nloc,nd), ep(nloc,nd), clw(nloc,nd), frac(nloc) + real m(nloc,nd), mp(nloc,nd), qp(nloc,nd) + real up(nloc,nd), vp(nloc,nd) + real wt(nloc,nd), water(nloc,nd), evap(nloc,nd) + real ment(nloc,nd,nd), qent(nloc,nd,nd), elij(nloc,nd,nd) + real uent(nloc,nd,nd), vent(nloc,nd,nd) + real tv(nloc,nd), tvp(nloc,nd) + +c outputs + integer iflag(nloc) ! also an input + real cbmf(nloc) ! also an input + real wd(nloc), tprime(nloc), qprime(nloc) + real precip(nloc) + real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd) + real Ma(nloc,nd) + real qcondc(nloc,nd) + +c local variables + integer i,j,ij,k,num1 + real dpinv,cpinv,awat,fqold,ftold,fuold,fvold,delti + real work(nloc), am(nloc),amp1(nloc),ad(nloc) + real ents(nloc), uav(nloc),vav(nloc),lvcp(nloc,nd) + real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd) ! cld + real siga(nloc,nd), ax(nloc,nd), mac(nloc,nd) ! cld + + +c -- initializations: + + delti = 1.0/delt + + do 160 i=1,ncum + precip(i)=0.0 + wd(i)=0.0 + tprime(i)=0.0 + qprime(i)=0.0 + do 170 k=1,nl+1 + ft(i,k)=0.0 + fu(i,k)=0.0 + fv(i,k)=0.0 + fq(i,k)=0.0 + lvcp(i,k)=lv(i,k)/cpn(i,k) + qcondc(i,k)=0.0 ! cld + qcond(i,k)=0.0 ! cld + nqcond(i,k)=0.0 ! cld + 170 continue + 160 continue + +c +c *** Calculate surface precipitation in mm/day *** +c + do 1190 i=1,ncum + if(iflag(i).le.1)then +cc precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000. +cc & /(rowl*g) +cc precip(i)=precip(i)*delt/86400. + precip(i) = wt(i,1)*sigd*water(i,1)*86400/g + endif + 1190 continue +c +c +c *** Calculate downdraft velocity scale and surface temperature and *** +c *** water vapor fluctuations *** +c + do i=1,ncum + wd(i)=betad*abs(mp(i,icb(i)))*0.01*rrd*t(i,icb(i)) + : /(sigd*p(i,icb(i))) + qprime(i)=0.5*(qp(i,1)-q(i,1)) + tprime(i)=lv0*qprime(i)/cpd + enddo +c +c *** Calculate tendencies of lowest level potential temperature *** +c *** and mixing ratio *** +c + do 1200 i=1,ncum + work(i)=0.01/(ph(i,1)-ph(i,2)) + am(i)=0.0 + 1200 continue + do 1220 k=2,nl + do 1210 i=1,ncum + if((nk(i).eq.1).and.(k.le.inb(i)).and.(nk(i).eq.1))then + am(i)=am(i)+m(i,k) + endif + 1210 continue + 1220 continue + do 1240 i=1,ncum + if((g*work(i)*am(i)).ge.delti)iflag(i)=1 + ft(i,1)=ft(i,1)+g*work(i)*am(i)*(t(i,2)-t(i,1) + & +(gz(i,2)-gz(i,1))/cpn(i,1)) + ft(i,1)=ft(i,1)-lvcp(i,1)*sigd*evap(i,1) + ft(i,1)=ft(i,1)+sigd*wt(i,2)*(cl-cpd)*water(i,2)*(t(i,2) + & -t(i,1))*work(i)/cpn(i,1) + fq(i,1)=fq(i,1)+g*mp(i,2)*(qp(i,2)-q(i,1))* + & work(i)+sigd*evap(i,1) + fq(i,1)=fq(i,1)+g*am(i)*(q(i,2)-q(i,1))*work(i) + fu(i,1)=fu(i,1)+g*work(i)*(mp(i,2)*(up(i,2)-u(i,1)) + & +am(i)*(u(i,2)-u(i,1))) + fv(i,1)=fv(i,1)+g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1)) + & +am(i)*(v(i,2)-v(i,1))) + 1240 continue + do 1260 j=2,nl + do 1250 i=1,ncum + if(j.le.inb(i))then + fq(i,1)=fq(i,1) + & +g*work(i)*ment(i,j,1)*(qent(i,j,1)-q(i,1)) + fu(i,1)=fu(i,1) + & +g*work(i)*ment(i,j,1)*(uent(i,j,1)-u(i,1)) + fv(i,1)=fv(i,1) + & +g*work(i)*ment(i,j,1)*(vent(i,j,1)-v(i,1)) + endif + 1250 continue + 1260 continue +c +c *** Calculate tendencies of potential temperature and mixing ratio *** +c *** at levels above the lowest level *** +c +c *** First find the net saturated updraft and downdraft mass fluxes *** +c *** through each level *** +c + do 1500 i=2,nl+1 +c + num1=0 + do 1265 ij=1,ncum + if(i.le.inb(ij))num1=num1+1 + 1265 continue + if(num1.le.0)go to 1500 +c + call zilch(amp1,ncum) + call zilch(ad,ncum) +c + do 1280 k=i+1,nl+1 + do 1270 ij=1,ncum + if((i.ge.nk(ij)).and.(i.le.inb(ij)) + & .and.(k.le.(inb(ij)+1)))then + amp1(ij)=amp1(ij)+m(ij,k) + endif + 1270 continue + 1280 continue +c + do 1310 k=1,i + do 1300 j=i+1,nl+1 + do 1290 ij=1,ncum + if((j.le.(inb(ij)+1)).and.(i.le.inb(ij)))then + amp1(ij)=amp1(ij)+ment(ij,k,j) + endif + 1290 continue + 1300 continue + 1310 continue + do 1340 k=1,i-1 + do 1330 j=i,nl+1 + do 1320 ij=1,ncum + if((i.le.inb(ij)).and.(j.le.inb(ij)))then + ad(ij)=ad(ij)+ment(ij,j,k) + endif + 1320 continue + 1330 continue + 1340 continue +c + do 1350 ij=1,ncum + if(i.le.inb(ij))then + dpinv=0.01/(ph(ij,i)-ph(ij,i+1)) + cpinv=1.0/cpn(ij,i) +c + ft(ij,i)=ft(ij,i) + & +g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij,i) + & +(gz(ij,i+1)-gz(ij,i))*cpinv) + & -ad(ij)*(t(ij,i)-t(ij,i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv)) + & -sigd*lvcp(ij,i)*evap(ij,i) + ft(ij,i)=ft(ij,i)+g*dpinv*ment(ij,i,i)*(hp(ij,i)-h(ij,i)+ + & t(ij,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv + ft(ij,i)=ft(ij,i)+sigd*wt(ij,i+1)*(cl-cpd)*water(ij,i+1)* + & (t(ij,i+1)-t(ij,i))*dpinv*cpinv + fq(ij,i)=fq(ij,i)+g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij,i))- + & ad(ij)*(q(ij,i)-q(ij,i-1))) + fu(ij,i)=fu(ij,i)+g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij,i))- + & ad(ij)*(u(ij,i)-u(ij,i-1))) + fv(ij,i)=fv(ij,i)+g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij,i))- + & ad(ij)*(v(ij,i)-v(ij,i-1))) + endif + 1350 continue + do 1370 k=1,i-1 + do 1360 ij=1,ncum + if(i.le.inb(ij))then + awat=elij(ij,k,i)-(1.-ep(ij,i))*clw(ij,i) + awat=max(awat,0.0) + fq(ij,i)=fq(ij,i) + & +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-awat-q(ij,i)) + fu(ij,i)=fu(ij,i) + & +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i)) + fv(ij,i)=fv(ij,i) + & +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i)) +c (saturated updrafts resulting from mixing) ! cld + qcond(ij,i)=qcond(ij,i)+(elij(ij,k,i)-awat) ! cld + nqcond(ij,i)=nqcond(ij,i)+1. ! cld + endif + 1360 continue + 1370 continue + do 1390 k=i,nl+1 + do 1380 ij=1,ncum + if((i.le.inb(ij)).and.(k.le.inb(ij)))then + fq(ij,i)=fq(ij,i) + & +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-q(ij,i)) + fu(ij,i)=fu(ij,i) + & +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i)) + fv(ij,i)=fv(ij,i) + & +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i)) + endif + 1380 continue + 1390 continue + do 1400 ij=1,ncum + if(i.le.inb(ij))then + fq(ij,i)=fq(ij,i) + & +sigd*evap(ij,i)+g*(mp(ij,i+1)* + & (qp(ij,i+1)-q(ij,i)) + & -mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv + fu(ij,i)=fu(ij,i) + & +g*(mp(ij,i+1)*(up(ij,i+1)-u(ij,i))-mp(ij,i)* + & (up(ij,i)-u(ij,i-1)))*dpinv + fv(ij,i)=fv(ij,i) + & +g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij,i))-mp(ij,i)* + & (vp(ij,i)-v(ij,i-1)))*dpinv +C (saturated downdrafts resulting from mixing) ! cld + do k=i+1,inb(ij) ! cld + qcond(ij,i)=qcond(ij,i)+elij(ij,k,i) ! cld + nqcond(ij,i)=nqcond(ij,i)+1. ! cld + enddo ! cld +C (particular case: no detraining level is found) ! cld + if (nent(ij,i).eq.0) then ! cld + qcond(ij,i)=qcond(ij,i)+(1.-ep(ij,i))*clw(ij,i) ! cld + nqcond(ij,i)=nqcond(ij,i)+1. ! cld + endif ! cld + if (nqcond(ij,i).ne.0.) then ! cld + qcond(ij,i)=qcond(ij,i)/nqcond(ij,i) ! cld + endif ! cld + endif + 1400 continue + 1500 continue +c +c *** Adjust tendencies at top of convection layer to reflect *** +c *** actual position of the level zero cape *** +c + do 503 ij=1,ncum + fqold=fq(ij,inb(ij)) + fq(ij,inb(ij))=fq(ij,inb(ij))*(1.-frac(ij)) + fq(ij,inb(ij)-1)=fq(ij,inb(ij)-1) + & +frac(ij)*fqold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*lv(ij,inb(ij)) + & /lv(ij,inb(ij)-1) + ftold=ft(ij,inb(ij)) + ft(ij,inb(ij))=ft(ij,inb(ij))*(1.-frac(ij)) + ft(ij,inb(ij)-1)=ft(ij,inb(ij)-1) + & +frac(ij)*ftold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*cpn(ij,inb(ij)) + & /cpn(ij,inb(ij)-1) + fuold=fu(ij,inb(ij)) + fu(ij,inb(ij))=fu(ij,inb(ij))*(1.-frac(ij)) + fu(ij,inb(ij)-1)=fu(ij,inb(ij)-1) + & +frac(ij)*fuold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij)))) + fvold=fv(ij,inb(ij)) + fv(ij,inb(ij))=fv(ij,inb(ij))*(1.-frac(ij)) + fv(ij,inb(ij)-1)=fv(ij,inb(ij)-1) + & +frac(ij)*fvold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij)))) + 503 continue +c +c *** Very slightly adjust tendencies to force exact *** +c *** enthalpy, momentum and tracer conservation *** +c + do 682 ij=1,ncum + ents(ij)=0.0 + uav(ij)=0.0 + vav(ij)=0.0 + do 681 i=1,inb(ij) + ents(ij)=ents(ij) + & +(cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)-ph(ij,i+1)) + uav(ij)=uav(ij)+fu(ij,i)*(ph(ij,i)-ph(ij,i+1)) + vav(ij)=vav(ij)+fv(ij,i)*(ph(ij,i)-ph(ij,i+1)) + 681 continue + 682 continue + do 683 ij=1,ncum + ents(ij)=ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1)) + uav(ij)=uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1)) + vav(ij)=vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1)) + 683 continue + do 642 ij=1,ncum + do 641 i=1,inb(ij) + ft(ij,i)=ft(ij,i)-ents(ij)/cpn(ij,i) + fu(ij,i)=(1.-cu)*(fu(ij,i)-uav(ij)) + fv(ij,i)=(1.-cu)*(fv(ij,i)-vav(ij)) + 641 continue + 642 continue +c + do 1810 k=1,nl+1 + do 1800 i=1,ncum + if((q(i,k)+delt*fq(i,k)).lt.0.0)iflag(i)=10 + 1800 continue + 1810 continue +c +c + do 1900 i=1,ncum + if(iflag(i).gt.2)then + precip(i)=0.0 + cbmf(i)=0.0 + endif + 1900 continue + do 1920 k=1,nl + do 1910 i=1,ncum + if(iflag(i).gt.2)then + ft(i,k)=0.0 + fq(i,k)=0.0 + fu(i,k)=0.0 + fv(i,k)=0.0 + qcondc(i,k)=0.0 ! cld + endif + 1910 continue + 1920 continue + + do k=1,nl+1 + do i=1,ncum + Ma(i,k) = 0. + enddo + enddo + do k=nl,1,-1 + do i=1,ncum + Ma(i,k) = Ma(i,k+1)+m(i,k) + enddo + enddo + +c +c *** diagnose the in-cloud mixing ratio *** ! cld +c *** of condensed water *** ! cld +c ! cld + DO ij=1,ncum ! cld + do i=1,nd ! cld + mac(ij,i)=0.0 ! cld + wa(ij,i)=0.0 ! cld + siga(ij,i)=0.0 ! cld + enddo ! cld + do i=nk(ij),inb(ij) ! cld + do k=i+1,inb(ij)+1 ! cld + mac(ij,i)=mac(ij,i)+m(ij,k) ! cld + enddo ! cld + enddo ! cld + do i=icb(ij),inb(ij)-1 ! cld + ax(ij,i)=0. ! cld + do j=icb(ij),i ! cld + ax(ij,i)=ax(ij,i)+rrd*(tvp(ij,j)-tv(ij,j)) ! cld + : *(ph(ij,j)-ph(ij,j+1))/p(ij,j) ! cld + enddo ! cld + if (ax(ij,i).gt.0.0) then ! cld + wa(ij,i)=sqrt(2.*ax(ij,i)) ! cld + endif ! cld + enddo ! cld + do i=1,nl ! cld + if (wa(ij,i).gt.0.0) ! cld + : siga(ij,i)=mac(ij,i)/wa(ij,i) ! cld + : *rrd*tvp(ij,i)/p(ij,i)/100./delta ! cld + siga(ij,i) = min(siga(ij,i),1.0) ! cld + qcondc(ij,i)=siga(ij,i)*clw(ij,i)*(1.-ep(ij,i)) ! cld + : + (1.-siga(ij,i))*qcond(ij,i) ! cld + enddo ! cld + ENDDO ! cld + + return + end + + SUBROUTINE cv_uncompress(nloc,len,ncum,nd,idcum + : ,iflag + : ,precip,cbmf + : ,ft,fq,fu,fv + : ,Ma,qcondc + : ,iflag1 + : ,precip1,cbmf1 + : ,ft1,fq1,fu1,fv1 + : ,Ma1,qcondc1 + : ) + implicit none + +#include "cvparam.h" + +c inputs: + integer len, ncum, nd, nloc + integer idcum(nloc) + integer iflag(nloc) + real precip(nloc), cbmf(nloc) + real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd) + real Ma(nloc,nd) + real qcondc(nloc,nd) !cld + +c outputs: + integer iflag1(len) + real precip1(len), cbmf1(len) + real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd) + real Ma1(len,nd) + real qcondc1(len,nd) !cld + +c local variables: + integer i,k + + do 2000 i=1,ncum + precip1(idcum(i))=precip(i) + cbmf1(idcum(i))=cbmf(i) + iflag1(idcum(i))=iflag(i) + 2000 continue + + do 2020 k=1,nl + do 2010 i=1,ncum + ft1(idcum(i),k)=ft(i,k) + fq1(idcum(i),k)=fq(i,k) + fu1(idcum(i),k)=fu(i,k) + fv1(idcum(i),k)=fv(i,k) + Ma1(idcum(i),k)=Ma(i,k) + qcondc1(idcum(i),k)=qcondc(i,k) + 2010 continue + 2020 continue + + return + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cva_driver.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cva_driver.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cva_driver.F (revision 1280) @@ -0,0 +1,939 @@ + SUBROUTINE cva_driver(len,nd,ndp1,ntra,nloc, + & iflag_con,iflag_mix, + & iflag_clos,delt, + & t1,q1,qs1,t1_wake,q1_wake,qs1_wake,s1_wake, + & u1,v1,tra1, + & p1,ph1, + & ALE1,ALP1, + & sig1feed1,sig2feed1,wght1, + o iflag1,ft1,fq1,fu1,fv1,ftra1, + & precip1,kbas1,ktop1,cbmf1, + & sig1,w01, !input/output + & ptop21,sigd, + & Ma1,mip1,Vprecip1,upwd1,dnwd1,dnwd01, + & qcondc1,wd1, + & cape1,cin1,tvp1, + & ftd1,fqd1, + & Plim11,Plim21,asupmax1,supmax01,asupmaxmin1 + & ,lalim_conv) +*************************************************************** +* * +* CV_DRIVER * +* * +* * +* written by : Sandrine Bony-Lena , 17/05/2003, 11.19.41 * +* modified by : * +*************************************************************** +*************************************************************** +C + USE dimphy + implicit none +C +C.............................START PROLOGUE............................ +C +C PARAMETERS: +C Name Type Usage Description +C ---------- ---------- ------- ---------------------------- +C +C len Integer Input first (i) dimension +C nd Integer Input vertical (k) dimension +C ndp1 Integer Input nd + 1 +C ntra Integer Input number of tracors +C iflag_con Integer Input version of convect (3/4) +C iflag_mix Integer Input version of mixing (0/1/2) +C iflag_clos Integer Input version of closure (0/1) +C delt Real Input time step +C t1 Real Input temperature (sat draught envt) +C q1 Real Input specific hum (sat draught envt) +C qs1 Real Input sat specific hum (sat draught envt) +C t1_wake Real Input temperature (unsat draught envt) +C q1_wake Real Input specific hum(unsat draught envt) +C qs1_wake Real Input sat specific hum(unsat draughts envt) +C s1_wake Real Input fractionnal area covered by wakes +C u1 Real Input u-wind +C v1 Real Input v-wind +C tra1 Real Input tracors +C p1 Real Input full level pressure +C ph1 Real Input half level pressure +C ALE1 Real Input Available lifting Energy +C ALP1 Real Input Available lifting Power +C sig1feed1 Real Input sigma coord at lower bound of feeding layer +C sig2feed1 Real Input sigma coord at upper bound of feeding layer +C wght1 Real Input weight density determining the feeding mixture +C iflag1 Integer Output flag for Emanuel conditions +C ft1 Real Output temp tend +C fq1 Real Output spec hum tend +C fu1 Real Output u-wind tend +C fv1 Real Output v-wind tend +C ftra1 Real Output tracor tend +C precip1 Real Output precipitation +C kbas1 Integer Output cloud base level +C ktop1 Integer Output cloud top level +C cbmf1 Real Output cloud base mass flux +C sig1 Real In/Out section adiabatic updraft +C w01 Real In/Out vertical velocity within adiab updraft +C ptop21 Real In/Out top of entraining zone +C Ma1 Real Output mass flux adiabatic updraft +C mip1 Real Output mass flux shed by the adiabatic updraft +C Vprecip1 Real Output vertical profile of precipitations +C upwd1 Real Output total upward mass flux (adiab+mixed) +C dnwd1 Real Output saturated downward mass flux (mixed) +C dnwd01 Real Output unsaturated downward mass flux +C qcondc1 Real Output in-cld mixing ratio of condensed water +C wd1 Real Output downdraft velocity scale for sfc fluxes +C cape1 Real Output CAPE +C cin1 Real Output CIN +C tvp1 Real Output adiab lifted parcell virt temp +C ftd1 Real Output precip temp tend +C fqt1 Real Output precip spec hum tend +C Plim11 Real Output +C Plim21 Real Output +C asupmax1 Real Output +C supmax01 Real Output +C asupmaxmin1 Real Output +C S. Bony, Mar 2002: +C * Several modules corresponding to different physical processes +C * Several versions of convect may be used: +C - iflag_con=3: version lmd (previously named convect3) +C - iflag_con=4: version 4.3b (vect. version, previously convect1/2) +C + tard: - iflag_con=5: version lmd with ice (previously named convectg) +C S. Bony, Oct 2002: +C * Vectorization of convect3 (ie version lmd) +C +C..............................END PROLOGUE............................. +c +c +#include "dimensions.h" +ccccc#include "dimphy.h" +c +c Input + integer len + integer nd + integer ndp1 + integer ntra + integer iflag_con + integer iflag_mix + integer iflag_clos + real delt + real t1(len,nd) + real q1(len,nd) + real qs1(len,nd) + real t1_wake(len,nd) + real q1_wake(len,nd) + real qs1_wake(len,nd) + real s1_wake(len) + real u1(len,nd) + real v1(len,nd) + real tra1(len,nd,ntra) + real p1(len,nd) + real ph1(len,ndp1) + real ALE1(len) + real ALP1(len) + real sig1feed1 ! pressure at lower bound of feeding layer + real sig2feed1 ! pressure at upper bound of feeding layer + real wght1(nd) ! weight density determining the feeding mixture +c +c Output + integer iflag1(len) + real ft1(len,nd) + real fq1(len,nd) + real fu1(len,nd) + real fv1(len,nd) + real ftra1(len,nd,ntra) + real precip1(len) + integer kbas1(len) + integer ktop1(len) + real cbmf1(len) +! real cbmflast(len) + real sig1(len,klev) !input/output + real w01(len,klev) !input/output + real ptop21(len) + real Ma1(len,nd) + real mip1(len,nd) + real Vprecip1(len,nd) + real upwd1(len,nd) + real dnwd1(len,nd) + real dnwd01(len,nd) + real qcondc1(len,nd) ! cld + real wd1(len) ! gust + real cape1(len) + real cin1(len) + real tvp1(len,nd) +c + real ftd1(len,nd) + real fqd1(len,nd) + real Plim11(len) + real Plim21(len) + real asupmax1(len,nd) + real supmax01(len) + real asupmaxmin1(len) + integer lalim_conv(len) +!------------------------------------------------------------------- +! --- ARGUMENTS +!------------------------------------------------------------------- +! --- On input: +! +! t: Array of absolute temperature (K) of dimension ND, with first +! index corresponding to lowest model level. Note that this array +! will be altered by the subroutine if dry convective adjustment +! occurs and if IPBL is not equal to 0. +! +! q: Array of specific humidity (gm/gm) of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! qs: Array of saturation specific humidity of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! t_wake: Array of absolute temperature (K), seen by unsaturated draughts, +! of dimension ND, with first index corresponding to lowest model level. +! +! q_wake: Array of specific humidity (gm/gm), seen by unsaturated draughts, +! of dimension ND, with first index corresponding to lowest model level. +! Must be defined at same grid levels as T. +! +!qs_wake: Array of saturation specific humidity, seen by unsaturated draughts, +! of dimension ND, with first index corresponding to lowest model level. +! Must be defined at same grid levels as T. +! +!s_wake: Array of fractionnal area occupied by the wakes. +! +! u: Array of zonal wind velocity (m/s) of dimension ND, witth first +! index corresponding with the lowest model level. Defined at +! same levels as T. Note that this array will be altered if +! dry convective adjustment occurs and if IPBL is not equal to 0. +! +! v: Same as u but for meridional velocity. +! +! tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA), +! where NTRA is the number of different tracers. If no +! convective tracer transport is needed, define a dummy +! input array of dimension (ND,1). Tracers are defined at +! same vertical levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! p: Array of pressure (mb) of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. +! +! ph: Array of pressure (mb) of dimension ND+1, with first index +! corresponding to lowest level. These pressures are defined at +! levels intermediate between those of P, T, Q and QS. The first +! value of PH should be greater than (i.e. at a lower level than) +! the first value of the array P. +! +! ALE: Available lifting Energy +! +! ALP: Available lifting Power +! +! nl: The maximum number of levels to which convection can penetrate, plus 1. +! NL MUST be less than or equal to ND-1. +! +! delt: The model time step (sec) between calls to CONVECT +! +!---------------------------------------------------------------------------- +! --- On Output: +! +! iflag: An output integer whose value denotes the following: +! VALUE INTERPRETATION +! ----- -------------- +! 0 Moist convection occurs. +! 1 Moist convection occurs, but a CFL condition +! on the subsidence warming is violated. This +! does not cause the scheme to terminate. +! 2 Moist convection, but no precip because ep(inb) lt 0.0001 +! 3 No moist convection because new cbmf is 0 and old cbmf is 0. +! 4 No moist convection; atmosphere is not +! unstable +! 6 No moist convection because ihmin le minorig. +! 7 No moist convection because unreasonable +! parcel level temperature or specific humidity. +! 8 No moist convection: lifted condensation +! level is above the 200 mb level. +! 9 No moist convection: cloud base is higher +! then the level NL-1. +! +! ft: Array of temperature tendency (K/s) of dimension ND, defined at same +! grid levels as T, Q, QS and P. +! +! fq: Array of specific humidity tendencies ((gm/gm)/s) of dimension ND, +! defined at same grid levels as T, Q, QS and P. +! +! fu: Array of forcing of zonal velocity (m/s^2) of dimension ND, +! defined at same grid levels as T. +! +! fv: Same as FU, but for forcing of meridional velocity. +! +! ftra: Array of forcing of tracer content, in tracer mixing ratio per +! second, defined at same levels as T. Dimensioned (ND,NTRA). +! +! precip: Scalar convective precipitation rate (mm/day). +! +! wd: A convective downdraft velocity scale. For use in surface +! flux parameterizations. See convect.ps file for details. +! +! tprime: A convective downdraft temperature perturbation scale (K). +! For use in surface flux parameterizations. See convect.ps +! file for details. +! +! qprime: A convective downdraft specific humidity +! perturbation scale (gm/gm). +! For use in surface flux parameterizations. See convect.ps +! file for details. +! +! cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST +! BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT +! ITS NEXT CALL. That is, the value of CBMF must be "remembered" +! by the calling program between calls to CONVECT. +! +! det: Array of detrainment mass flux of dimension ND. +! +! ftd: Array of temperature tendency due to precipitations (K/s) of dimension ND, +! defined at same grid levels as T, Q, QS and P. +! +! fqd: Array of specific humidity tendencies due to precipitations ((gm/gm)/s) +! of dimension ND, defined at same grid levels as T, Q, QS and P. +! +!------------------------------------------------------------------- +c +c Local arrays +c + + integer i,k,n,il,j + integer nword1,nword2,nword3,nword4 + integer icbmax + integer nk1(klon) + integer icb1(klon) + integer icbs1(klon) + + logical ok_inhib ! True => possible inhibition of convection by dryness + logical, save :: debut=.true. +c$OMP THREADPRIVATE(debut) + + real plcl1(klon) + real tnk1(klon) + real thnk1(klon) + real qnk1(klon) + real gznk1(klon) + real pnk1(klon) + real qsnk1(klon) + real unk1(klon) + real vnk1(klon) + real cpnk1(klon) + real hnk1(klon) + real pbase1(klon) + real buoybase1(klon) + + real lv1(klon,klev) ,lv1_wake(klon,klev) + real cpn1(klon,klev),cpn1_wake(klon,klev) + real tv1(klon,klev) ,tv1_wake(klon,klev) + real gz1(klon,klev) ,gz1_wake(klon,klev) + real hm1(klon,klev) ,hm1_wake(klon,klev) + real h1(klon,klev) ,h1_wake(klon,klev) + real tp1(klon,klev) + real clw1(klon,klev) + real th1(klon,klev) ,th1_wake(klon,klev) +c + real bid(klon,klev) ! dummy array +c + integer ncum +c + integer j1feed(klon) + integer j2feed(klon) + real p1feed1(len) ! pressure at lower bound of feeding layer + real p2feed1(len) ! pressure at upper bound of feeding layer + real wghti1(len,nd) ! weights of the feeding layers +c +c (local) compressed fields: +c + integer nloc +c parameter (nloc=klon) ! pour l'instant + + integer idcum(nloc) + integer iflag(nloc),nk(nloc),icb(nloc) + integer nent(nloc,klev) + integer icbs(nloc) + integer inb(nloc), inbis(nloc) + + real cbmf(nloc),plcl(nloc) + real t(nloc,klev),q(nloc,klev),qs(nloc,klev) + real t_wake(nloc,klev),q_wake(nloc,klev),qs_wake(nloc,klev) + real s_wake(nloc) + real u(nloc,klev),v(nloc,klev) + real gz(nloc,klev),h(nloc,klev) ,hm(nloc,klev) + real h_wake(nloc,klev),hm_wake(nloc,klev) + real lv(nloc,klev) ,cpn(nloc,klev) + real lv_wake(nloc,klev),cpn_wake(nloc,klev) + real p(nloc,klev),ph(nloc,klev+1),tv(nloc,klev) ,tp(nloc,klev) + real tv_wake(nloc,klev) + real clw(nloc,klev) + real dph(nloc,klev) + real pbase(nloc), buoybase(nloc), th(nloc,klev) + real th_wake(nloc,klev) + real tvp(nloc,klev) + real sig(nloc,klev), w0(nloc,klev), ptop2(nloc) + real hp(nloc,klev), ep(nloc,klev), sigp(nloc,klev) + real frac(nloc), buoy(nloc,klev) + real cape(nloc) + real cin(nloc) + real m(nloc,klev) + real ment(nloc,klev,klev), sij(nloc,klev,klev) + real qent(nloc,klev,klev) + real hent(nloc,klev,klev) + real uent(nloc,klev,klev), vent(nloc,klev,klev) + real ments(nloc,klev,klev), qents(nloc,klev,klev) + real elij(nloc,klev,klev) + real supmax(nloc,klev) + real ale(nloc),alp(nloc),coef_clos(nloc) + real sigd(nloc) +! real mp(nloc,klev), qp(nloc,klev), up(nloc,klev), vp(nloc,klev) +! real wt(nloc,klev), water(nloc,klev), evap(nloc,klev) +! real b(nloc,klev), sigd(nloc) +! save mp,qp,up,vp,wt,water,evap,b + real, save, allocatable :: mp(:,:),qp(:,:),up(:,:),vp(:,:) + real, save, allocatable :: wt(:,:),water(:,:),evap(:,:), b(:,:) +c$OMP THREADPRIVATE(mp,qp,up,vp,wt,water,evap,b) + real ft(nloc,klev), fq(nloc,klev) + real ftd(nloc,klev), fqd(nloc,klev) + real fu(nloc,klev), fv(nloc,klev) + real upwd(nloc,klev), dnwd(nloc,klev), dnwd0(nloc,klev) + real Ma(nloc,klev), mip(nloc,klev), tls(nloc,klev) + real tps(nloc,klev), qprime(nloc), tprime(nloc) + real precip(nloc) + real Vprecip(nloc,klev) + real tra(nloc,klev,ntra), trap(nloc,klev,ntra) + real ftra(nloc,klev,ntra), traent(nloc,klev,klev,ntra) + real qcondc(nloc,klev) ! cld + real wd(nloc) ! gust + real Plim1(nloc),Plim2(nloc) + real asupmax(nloc,klev) + real supmax0(nloc) + real asupmaxmin(nloc) +c + real tnk(nloc),qnk(nloc),gznk(nloc) + real wghti(nloc,nd) + real hnk(nloc),unk(nloc),vnk(nloc) + logical, save :: first=.true. +c$OMP THREADPRIVATE(first) + +c +! print *, 't1, t1_wake ',(k,t1(1,k),t1_wake(1,k),k=1,klev) +! print *, 'q1, q1_wake ',(k,q1(1,k),q1_wake(1,k),k=1,klev) + +!------------------------------------------------------------------- +! --- SET CONSTANTS AND PARAMETERS +!------------------------------------------------------------------- + + if (first) then + allocate(mp(nloc,klev), qp(nloc,klev), up(nloc,klev)) + allocate(vp(nloc,klev), wt(nloc,klev), water(nloc,klev)) + allocate(evap(nloc,klev), b(nloc,klev)) + first=.false. + endif +c -- set simulation flags: +c (common cvflag) + + CALL cv_flag + +c -- set thermodynamical constants: +c (common cvthermo) + + CALL cv_thermo(iflag_con) + +c -- set convect parameters +c +c includes microphysical parameters and parameters that +c control the rate of approach to quasi-equilibrium) +c (common cvparam) + + if (iflag_con.eq.3) then + CALL cv3_param(nd,delt) + + endif + + if (iflag_con.eq.4) then + CALL cv_param(nd) + endif + +!--------------------------------------------------------------------- +! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS +!--------------------------------------------------------------------- + nword1=len + nword2=len*nd + nword3=len*nd*ntra + nword4=len*nd*nd + +! call izilch(iflag1 ,nword1) +! call zilch(iflag1 ,nword1) + do i=1,len + iflag1(i)=0 + ktop1(i)=0 + kbas1(i)=0 + enddo + call zilch(ft1 ,nword2) + call zilch(fq1 ,nword2) + call zilch(fu1 ,nword2) + call zilch(fv1 ,nword2) + call zilch(ftra1 ,nword3) + call zilch(precip1 ,nword1) +! call izilch(kbas1 ,nword1) +! call zilch(kbas1 ,nword1) +! call izilch(ktop1 ,nword1) +! call zilch(ktop1 ,nword1) + call zilch(cbmf1 ,nword1) + call zilch(ptop21 ,nword1) + call zilch(Ma1 ,nword2) + call zilch(mip1 ,nword2) + call zilch(Vprecip1,nword2) + call zilch(upwd1 ,nword2) + call zilch(dnwd1 ,nword2) + call zilch(dnwd01 ,nword2) + call zilch(qcondc1 ,nword2) +!test +! call zilch(qcondc ,nword2) + call zilch(wd1 ,nword1) + call zilch(cape1 ,nword1) + call zilch(cin1 ,nword1) + call zilch(tvp1 ,nword2) + call zilch(ftd1 ,nword2) + call zilch(fqd1 ,nword2) + call zilch(Plim11 ,nword1) + call zilch(Plim21 ,nword1) + call zilch(asupmax1,nword2) + call zilch(supmax01,nword1) + call zilch(asupmaxmin1,nword1) +c + DO il = 1,len + cin1(il) = -100000. + cape1(il) = -1. + ENDDO +c + if (iflag_con.eq.3) then + do il=1,len + sig1(il,nd)=sig1(il,nd)+1. + sig1(il,nd)=amin1(sig1(il,nd),12.1) + enddo + endif + +!--------------------------------------------------------------------- +! --- INITIALIZE LOCAL ARRAYS AND PARAMETERS +!--------------------------------------------------------------------- +! + do il = 1,nloc + coef_clos(il)=1. + enddo + +!-------------------------------------------------------------------- +! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY +!-------------------------------------------------------------------- + + if (iflag_con.eq.3) then + + if (debut) THEN + print*,'Emanuel version 3 nouvelle' + endif +! print*,'t1, q1 ',t1,q1 + CALL cv3_prelim(len,nd,ndp1,t1,q1,p1,ph1 ! nd->na + o ,lv1,cpn1,tv1,gz1,h1,hm1,th1) + +c + CALL cv3_prelim(len,nd,ndp1,t1_wake,q1_wake,p1,ph1 ! nd->na + o ,lv1_wake,cpn1_wake,tv1_wake,gz1_wake + o ,h1_wake,bid,th1_wake) + + endif +c + if (iflag_con.eq.4) then + print*,'Emanuel version 4 ' + CALL cv_prelim(len,nd,ndp1,t1,q1,p1,ph1 + o ,lv1,cpn1,tv1,gz1,h1,hm1) + endif + +!-------------------------------------------------------------------- +! --- CONVECTIVE FEED +!-------------------------------------------------------------------- +! +! compute feeding layer potential temperature and mixing ratio : +! +! get bounds of feeding layer +! +c test niveaux couche alimentation KE + if(sig1feed1.eq.sig2feed1) then + print*,'impossible de choisir sig1feed=sig2feed' + print*,'changer la valeur de sig2feed dans physiq.def' + stop + endif +c + do i=1,len + p1feed1(i)=sig1feed1*ph1(i,1) + p2feed1(i)=sig2feed1*ph1(i,1) +ctest maf +c p1feed1(i)=ph1(i,1) +c p2feed1(i)=ph1(i,2) +c p2feed1(i)=ph1(i,3) +ctestCR: on prend la couche alim des thermiques +c p2feed1(i)=ph1(i,lalim_conv(i)+1) +c print*,'lentr=',lentr(i),ph1(i,lentr(i)+1),ph1(i,2) + end do +! + if (iflag_con.eq.3) then + endif + do i=1,len +! print*,'avant cv3_feed plim',p1feed1(i),p2feed1(i) + enddo + if (iflag_con.eq.3) then + +c print*, 'IFLAG1 avant cv3_feed' +c print*,'len,nd',len,nd +c write(*,'(64i1)') iflag1(2:klon-1) + + CALL cv3_feed(len,nd,t1,q1,u1,v1,p1,ph1,hm1,gz1 ! nd->na + i ,p1feed1,p2feed1,wght1 + o ,wghti1,tnk1,thnk1,qnk1,qsnk1,unk1,vnk1 + o ,cpnk1,hnk1,nk1,icb1,icbmax,iflag1,gznk1,plcl1) + endif + +c print*, 'IFLAG1 apres cv3_feed' +c print*,'len,nd',len,nd +c write(*,'(64i1)') iflag1(2:klon-1) + + if (iflag_con.eq.4) then + CALL cv_feed(len,nd,t1,q1,qs1,p1,hm1,gz1 + o ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1) + endif +c +! print *, 'cv3_feed-> iflag1, plcl1 ',iflag1(1),plcl1(1) +c +!-------------------------------------------------------------------- +! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part +! (up through ICB for convect4, up through ICB+1 for convect3) +! Calculates the lifted parcel virtual temperature at nk, the +! actual temperature, and the adiabatic liquid water content. +!-------------------------------------------------------------------- + + if (iflag_con.eq.3) then + + CALL cv3_undilute1(len,nd,t1,qs1,gz1,plcl1,p1,icb1,tnk1,qnk1 ! nd->na + o ,gznk1,tp1,tvp1,clw1,icbs1) + endif + + + if (iflag_con.eq.4) then + CALL cv_undilute1(len,nd,t1,q1,qs1,gz1,p1,nk1,icb1,icbmax + : ,tp1,tvp1,clw1) + endif +c +!------------------------------------------------------------------- +! --- TRIGGERING +!------------------------------------------------------------------- +c +! print *,' avant triggering, iflag_con ',iflag_con +c + if (iflag_con.eq.3) then + + CALL cv3_trigger(len,nd,icb1,plcl1,p1,th1,tv1,tvp1,thnk1 ! nd->na + o ,pbase1,buoybase1,iflag1,sig1,w01) + + +c print*, 'IFLAG1 apres cv3_triger' +c print*,'len,nd',len,nd +c write(*,'(64i1)') iflag1(2:klon-1) + +c call dump2d(iim,jjm-1,sig1(2) + endif + + if (iflag_con.eq.4) then + CALL cv_trigger(len,nd,icb1,cbmf1,tv1,tvp1,iflag1) + endif +c +c +!===================================================================== +! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY +!===================================================================== + + ncum=0 + do 400 i=1,len + if(iflag1(i).eq.0)then + ncum=ncum+1 + idcum(ncum)=i + endif + 400 continue +c +! print*,'klon, ncum = ',len,ncum +c + IF (ncum.gt.0) THEN + +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! --- COMPRESS THE FIELDS +! (-> vectorization over convective gridpoints) +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + if (iflag_con.eq.3) then +! print*,'ncum tv1 ',ncum,tv1 +! print*,'tvp1 ',tvp1 + CALL cv3a_compress( len,nloc,ncum,nd,ntra + : ,iflag1,nk1,icb1,icbs1 + : ,plcl1,tnk1,qnk1,gznk1,hnk1,unk1,vnk1 + : ,wghti1,pbase1,buoybase1 + : ,t1,q1,qs1,t1_wake,q1_wake,qs1_wake,s1_wake + : ,u1,v1,gz1,th1,th1_wake + : ,tra1 + : ,h1 ,lv1 ,cpn1 ,p1,ph1,tv1 ,tp1,tvp1,clw1 + : ,h1_wake,lv1_wake,cpn1_wake ,tv1_wake + : ,sig1,w01,ptop21 + : ,Ale1,Alp1 + o ,iflag,nk,icb,icbs + o ,plcl,tnk,qnk,gznk,hnk,unk,vnk + o ,wghti,pbase,buoybase + o ,t,q,qs,t_wake,q_wake,qs_wake,s_wake + o ,u,v,gz,th,th_wake + o ,tra + o ,h ,lv ,cpn ,p,ph,tv ,tp,tvp,clw + o ,h_wake,lv_wake,cpn_wake ,tv_wake + o ,sig,w0,ptop2 + o ,Ale,Alp ) + +! print*,'tv ',tv +! print*,'tvp ',tvp + + endif + + if (iflag_con.eq.4) then + CALL cv_compress( len,nloc,ncum,nd + : ,iflag1,nk1,icb1 + : ,cbmf1,plcl1,tnk1,qnk1,gznk1 + : ,t1,q1,qs1,u1,v1,gz1 + : ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 + o ,iflag,nk,icb + o ,cbmf,plcl,tnk,qnk,gznk + o ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw + o ,dph ) + endif + +!------------------------------------------------------------------- +! --- UNDILUTE (ADIABATIC) UPDRAFT / second part : +! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +! --- & +! --- COMPUTE THE PRECIPITATION EFFICIENCIES AND THE +! --- FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD +! --- & +! --- FIND THE LEVEL OF NEUTRAL BUOYANCY +!------------------------------------------------------------------- + + if (iflag_con.eq.3) then + CALL cv3_undilute2(nloc,ncum,nd,icb,icbs,nk !na->nd + : ,tnk,qnk,gznk,hnk,t,q,qs,gz + : ,p,h,tv,lv,pbase,buoybase,plcl + o ,inb,tp,tvp,clw,hp,ep,sigp,buoy) + + endif + + if (iflag_con.eq.4) then + CALL cv_undilute2(nloc,ncum,nd,icb,nk + : ,tnk,qnk,gznk,t,q,qs,gz + : ,p,dph,h,tv,lv + o ,inb,inbis,tp,tvp,clw,hp,ep,sigp,frac) + endif +c +!------------------------------------------------------------------- +! --- MIXING(1) (if iflag_mix .ge. 1) +!------------------------------------------------------------------- + IF (iflag_con .eq. 3) THEN + IF (iflag_mix .ge. 1 ) THEN + CALL zilch(supmax,nloc*klev) + CALL cv3p_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb ! na->nd + : ,ph,t,q,qs,u,v,tra,h,lv,qnk + : ,unk,vnk,hp,tv,tvp,ep,clw,sig + : ,ment,qent,hent,uent,vent,nent + : ,sij,elij,supmax,ments,qents,traent) +! print*, 'cv3p_mixing-> supmax ', (supmax(1,k), k=1,nd) + + ELSE + CALL zilch(supmax,nloc*klev) + ENDIF + ENDIF +!------------------------------------------------------------------- +! --- CLOSURE +!------------------------------------------------------------------- + +c + if (iflag_con.eq.3) then + IF (iflag_clos .eq. 0) THEN + CALL cv3_closure(nloc,ncum,nd,icb,inb ! na->nd + : ,pbase,p,ph,tv,buoy + o ,sig,w0,cape,m,iflag) + ENDIF +c + ok_inhib = iflag_mix .EQ. 2 +c + IF (iflag_clos .eq. 1) THEN + print *,' pas d appel cv3p_closure' +cc CALL cv3p_closure(nloc,ncum,nd,icb,inb ! na->nd +cc : ,pbase,plcl,p,ph,tv,tvp,buoy +cc : ,supmax +cc o ,sig,w0,ptop2,cape,cin,m) + ENDIF + IF (iflag_clos .eq. 2) THEN + CALL cv3p1_closure(nloc,ncum,nd,icb,inb ! na->nd + : ,pbase,plcl,p,ph,tv,tvp,buoy + : ,supmax,ok_inhib,Ale,Alp + o ,sig,w0,ptop2,cape,cin,m,iflag,coef_clos + : ,Plim1,Plim2,asupmax,supmax0 + : ,asupmaxmin,cbmf) + ENDIF + endif ! iflag_con.eq.3 + + if (iflag_con.eq.4) then + CALL cv_closure(nloc,ncum,nd,nk,icb + : ,tv,tvp,p,ph,dph,plcl,cpn + o ,iflag,cbmf) + endif +c +! print *,'cv_closure-> cape ',cape(1) +c +!------------------------------------------------------------------- +! --- MIXING(2) +!------------------------------------------------------------------- + + if (iflag_con.eq.3) then + IF (iflag_mix.eq.0) THEN + CALL cv3_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb ! na->nd + : ,ph,t,q,qs,u,v,tra,h,lv,qnk + : ,unk,vnk,hp,tv,tvp,ep,clw,m,sig + o ,ment,qent,uent,vent,nent,sij,elij,ments,qents,traent) + CALL zilch(hent,nloc*klev*klev) + ELSE + CALL cv3_mixscale(nloc,ncum,nd,ment,m) + if (debut) THEN + print *,' cv3_mixscale-> ' + endif !(debut) THEN + ENDIF + endif + + if (iflag_con.eq.4) then + CALL cv_mixing(nloc,ncum,nd,icb,nk,inb,inbis + : ,ph,t,q,qs,u,v,h,lv,qnk + : ,hp,tv,tvp,ep,clw,cbmf + o ,m,ment,qent,uent,vent,nent,sij,elij) + endif +c + if (debut) THEN + print *,' cv_mixing ->' + endif !(debut) THEN +c do i = 1,klev +c print*,'cv_mixing-> i,ment ',i,(ment(1,i,j),j=1,klev) +c enddo +c +!------------------------------------------------------------------- +! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS +!------------------------------------------------------------------- + if (iflag_con.eq.3) then + if (debut) THEN + print *,' cva_driver -> cv3_unsat ' + endif !(debut) THEN + + CALL cv3_unsat(nloc,ncum,nd,nd,ntra,icb,inb,iflag ! na->nd + : ,t_wake,q_wake,qs_wake,gz,u,v,tra,p,ph + : ,th_wake,tv_wake,lv_wake,cpn_wake + : ,ep,sigp,clw + : ,m,ment,elij,delt,plcl,coef_clos + o ,mp,qp,up,vp,trap,wt,water,evap,b,sigd) + endif + + if (iflag_con.eq.4) then + CALL cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph + : ,h,lv,ep,sigp,clw,m,ment,elij + o ,iflag,mp,qp,up,vp,wt,water,evap) + endif +c + if (debut) THEN + print *,'cv_unsat-> ' + debut=.FALSE. + endif !(debut) THEN +! +c print *,'cv_unsat-> mp ',mp +c print *,'cv_unsat-> water ',water +!------------------------------------------------------------------- +! --- YIELD +! (tendencies, precipitation, variables of interface with other +! processes, etc) +!------------------------------------------------------------------- + + if (iflag_con.eq.3) then + + CALL cv3_yield(nloc,ncum,nd,nd,ntra ! na->nd + : ,icb,inb,delt + : ,t,q,t_wake,q_wake,s_wake,u,v,tra + : ,gz,p,ph,h,hp,lv,cpn,th,th_wake + : ,ep,clw,m,tp,mp,qp,up,vp,trap + : ,wt,water,evap,b,sigd + : ,ment,qent,hent,iflag_mix,uent,vent + : ,nent,elij,traent,sig + : ,tv,tvp,wghti + : ,iflag,precip,Vprecip,ft,fq,fu,fv,ftra + : ,cbmf,upwd,dnwd,dnwd0,ma,mip + : ,tls,tps,qcondc,wd + : ,ftd,fqd) +! print *,' cv3_yield -> fqd(1) = ',fqd(1,1) + endif + + if (iflag_con.eq.4) then + CALL cv_yield(nloc,ncum,nd,nk,icb,inb,delt + : ,t,q,t_wake,q_wake,u,v,tra + : ,gz,p,ph,h,hp,lv,cpn,th + : ,ep,clw,frac,m,mp,qp,up,vp + : ,wt,water,evap + : ,ment,qent,uent,vent,nent,elij + : ,tv,tvp + o ,iflag,wd,qprime,tprime + o ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc) + endif + +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! --- UNCOMPRESS THE FIELDS +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + + if (iflag_con.eq.3) then + CALL cv3a_uncompress(nloc,len,ncum,nd,ntra,idcum + : ,iflag,icb,inb + : ,precip,sig,w0,ptop2 + : ,ft,fq,fu,fv,ftra + : ,Ma,mip,Vprecip,upwd,dnwd,dnwd0 + ; ,qcondc,wd,cape,cin + : ,tvp + : ,ftd,fqd + : ,Plim1,Plim2,asupmax,supmax0 + : ,asupmaxmin + o ,iflag1,kbas1,ktop1 + o ,precip1,sig1,w01,ptop21 + o ,ft1,fq1,fu1,fv1,ftra1 + o ,Ma1,mip1,Vprecip1,upwd1,dnwd1,dnwd01 + o ,qcondc1,wd1,cape1,cin1 + o ,tvp1 + o ,ftd1,fqd1 + o ,Plim11,Plim21,asupmax1,supmax01 + o ,asupmaxmin1) + endif + + if (iflag_con.eq.4) then + CALL cv_uncompress(nloc,len,ncum,nd,idcum + : ,iflag + : ,precip,cbmf + : ,ft,fq,fu,fv + : ,Ma,qcondc + o ,iflag1 + o ,precip1,cbmf1 + o ,ft1,fq1,fu1,fv1 + o ,Ma1,qcondc1 ) + endif + + ENDIF ! ncum>0 + +9999 continue + return + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cvflag.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cvflag.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cvflag.h (revision 1280) @@ -0,0 +1,7 @@ +! +! $Header$ +! + logical cvflag_grav + + COMMON /cvflag/ cvflag_grav +c$OMP THREADPRIVATE(/cvflag/) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cvltr.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cvltr.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cvltr.F90 (revision 1280) @@ -0,0 +1,164 @@ +! +! $Id $ +! +SUBROUTINE cvltr(pdtime,da, phi, mp,paprs,pplay,x,upd,dnd,dx) + USE dimphy + IMPLICIT NONE +!===================================================================== +! Objet : convection des traceurs / KE +! Auteurs: M-A Filiberti and J-Y Grandpeix +!===================================================================== + + include "YOMCST.h" + include "YOECUMF.h" + +! Entree + REAL,INTENT(IN) :: pdtime + REAL,DIMENSION(klon,klev),INTENT(IN) :: da + REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi + REAL,DIMENSION(klon,klev),INTENT(IN) :: mp + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs ! pression aux 1/2 couches (bas en haut) + REAL,DIMENSION(klon,klev),INTENT(IN) :: pplay ! pression pour le milieu de chaque couche + REAL,DIMENSION(klon,klev),INTENT(IN) :: x ! q de traceur (bas en haut) + REAL,DIMENSION(klon,klev),INTENT(IN) :: upd ! saturated updraft mass flux + REAL,DIMENSION(klon,klev),INTENT(IN) :: dnd ! saturated downdraft mass flux + +! Sortie + REAL,DIMENSION(klon,klev),INTENT(OUT) :: dx ! tendance de traceur (bas en haut) + +! Variables locales +! REAL,DIMENSION(klon,klev) :: zed + REAL,DIMENSION(klon,klev,klev) :: zmd + REAL,DIMENSION(klon,klev,klev) :: za + REAL,DIMENSION(klon,klev) :: zmfd,zmfa + REAL,DIMENSION(klon,klev) :: zmfp,zmfu + INTEGER :: i,k,j + REAL :: pdtimeRG + +! ========================================= +! calcul des tendances liees au downdraft +! ========================================= +!cdir collapse + DO j=1,klev + DO i=1,klon +! zed(i,j)=0. + zmfd(i,j)=0. + zmfa(i,j)=0. + zmfu(i,j)=0. + zmfp(i,j)=0. + END DO + END DO +!cdir collapse + DO k=1,klev + DO j=1,klev + DO i=1,klon + zmd(i,j,k)=0. + za (i,j,k)=0. + END DO + END DO + END DO +! entrainement +! DO k=1,klev-1 +! DO i=1,klon +! zed(i,k)=max(0.,mp(i,k)-mp(i,k+1)) +! END DO +! END DO + +! calcul de la matrice d echange +! matrice de distribution de la masse entrainee en k + + DO k=1,klev-1 + DO i=1,klon + zmd(i,k,k)=max(0.,mp(i,k)-mp(i,k+1)) + END DO + END DO + DO k=2,klev + DO j=k-1,1,-1 + DO i=1,klon + if(mp(i,j+1).ne.0) then + zmd(i,j,k)=zmd(i,j+1,k)*min(1.,mp(i,j)/mp(i,j+1)) + ENDif + END DO + END DO + END DO + DO k=1,klev + DO j=1,klev-1 + DO i=1,klon + za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k)) + END DO + END DO + END DO +! +! rajout du terme lie a l ascendance induite +! + DO j=2,klev + DO i=1,klon + za(i,j,j-1)=za(i,j,j-1)+mp(i,j) + END DO + END DO +! +! tendances +! + DO k=1,klev + DO j=1,klev + DO i=1,klon + zmfd(i,j)=zmfd(i,j)+za(i,j,k)*(x(i,k)-x(i,j)) + END DO + END DO + END DO +! +! ========================================= +! calcul des tendances liees aux flux satures +! ========================================= + DO j=1,klev + DO i=1,klon + zmfa(i,j)=da(i,j)*(x(i,1)-x(i,j)) + END DO + END DO + DO k=1,klev + DO j=1,klev + DO i=1,klon + zmfp(i,j)=zmfp(i,j)+phi(i,j,k)*(x(i,k)-x(i,j)) + END DO + END DO + END DO + DO j=1,klev-1 + DO i=1,klon + zmfu(i,j)=max(0.,upd(i,j+1)+dnd(i,j+1))*(x(i,j+1)-x(i,j)) + END DO + END DO + DO j=2,klev + DO i=1,klon + zmfu(i,j)=zmfu(i,j)+min(0.,upd(i,j)+dnd(i,j))*(x(i,j)-x(i,j-1)) + END DO + END DO + +! ========================================= +! calcul final des tendances +! ========================================= + DO k=1, klev + DO i=1, klon + dx(i,k)=paprs(i,k)-paprs(i,k+1) + ENDDO + ENDDO + pdtimeRG=pdtime*RG +!cdir collapse + DO k=1, klev + DO i=1, klon + dx(i,k)=(zmfd(i,k)+zmfu(i,k) & + +zmfa(i,k)+zmfp(i,k))*pdtimeRG/dx(i,k) + ! print*,'dx',k,dx(i,k) + ENDDO + ENDDO + +! test de conservation du traceur +! conserv=0. +! DO k=1, klev +! DO i=1, klon +! conserv=conserv+dx(i,k)* & +! (paprs(i,k)-paprs(i,k+1))/RG +! ENDDO +! ENDDO +! print *,'conserv',conserv + +END SUBROUTINE cvltr Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cvparam.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cvparam.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cvparam.h (revision 1280) @@ -0,0 +1,29 @@ +! +! $Header$ +! +c------------------------------------------------------------ +c Parameters for convectL: +c (includes - microphysical parameters, +c - parameters that control the rate of approach +c to quasi-equilibrium) +c - noff & minorig (previously in input of convect1) +c------------------------------------------------------------ + + integer noff, minorig, nl, nlp, nlm + real elcrit, tlcrit + real entp + real sigs, sigd + real omtrain, omtsnow, coeffr, coeffs + real dtmax + real cu + real betad + real alpha, damp + real delta + + COMMON /cvparam/ noff, minorig, nl, nlp, nlm + : ,elcrit, tlcrit + : ,entp, sigs, sigd + : ,omtrain, omtsnow, coeffr, coeffs + : ,dtmax, cu, betad, alpha, damp, delta + +c$OMP THREADPRIVATE(/cvparam/) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cvthermo.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cvthermo.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/cvthermo.h (revision 1280) @@ -0,0 +1,16 @@ +! +! $Header$ +! +c Thermodynamical constants for convectL: + + real cpd, cpv, cl, rrv, rrd, lv0, g, rowl, t0 + real clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl + real eps, epsi, epsim1 + real ginv, hrd + real grav + + COMMON /cvthermo/ cpd, cpv, cl, rrv, rrd, lv0, g, rowl, t0 + : ,clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl + : ,eps, epsi, epsim1, ginv, hrd, grav + +c$OMP THREADPRIVATE(/cvthermo/) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/diagphy.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/diagphy.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/diagphy.F (revision 1280) @@ -0,0 +1,415 @@ +! +! $Header$ +! + SUBROUTINE diagphy(airephy,tit,iprt + $ , tops, topl, sols, soll, sens + $ , evap, rain_fall, snow_fall, ts + $ , d_etp_tot, d_qt_tot, d_ec_tot + $ , fs_bound, fq_bound) +C====================================================================== +C +C Purpose: +C Compute the thermal flux and the watter mass flux at the atmosphere +c boundaries. Print them and also the atmospheric enthalpy change and +C the atmospheric mass change. +C +C Arguments: +C airephy-------input-R- grid area +C tit---------input-A15- Comment to be added in PRINT (CHARACTER*15) +C iprt--------input-I- PRINT level ( <=0 : no PRINT) +C tops(klon)--input-R- SW rad. at TOA (W/m2), positive up. +C topl(klon)--input-R- LW rad. at TOA (W/m2), positive down +C sols(klon)--input-R- Net SW flux above surface (W/m2), positive up +C (i.e. -1 * flux absorbed by the surface) +C soll(klon)--input-R- Net LW flux above surface (W/m2), positive up +C (i.e. flux emited - flux absorbed by the surface) +C sens(klon)--input-R- Sensible Flux at surface (W/m2), positive down +C evap(klon)--input-R- Evaporation + sublimation watter vapour mass flux +C (kg/m2/s), positive up +C rain_fall(klon) +C --input-R- Liquid watter mass flux (kg/m2/s), positive down +C snow_fall(klon) +C --input-R- Solid watter mass flux (kg/m2/s), positive down +C ts(klon)----input-R- Surface temperature (K) +C d_etp_tot---input-R- Heat flux equivalent to atmospheric enthalpy +C change (W/m2) +C d_qt_tot----input-R- Mass flux equivalent to atmospheric watter mass +C change (kg/m2/s) +C d_ec_tot----input-R- Flux equivalent to atmospheric cinetic energy +C change (W/m2) +C +C fs_bound---output-R- Thermal flux at the atmosphere boundaries (W/m2) +C fq_bound---output-R- Watter mass flux at the atmosphere boundaries (kg/m2/s) +C +C J.L. Dufresne, July 2002 +C Version prise sur ~rlmd833/LMDZOR_201102/modipsl/modeles/LMDZ.3.3/libf/phylmd +C le 25 Novembre 2002. +C====================================================================== +C + use dimphy + implicit none + +#include "dimensions.h" +ccccc#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +C +C Input variables + real airephy(klon) + CHARACTER*15 tit + INTEGER iprt + real tops(klon),topl(klon),sols(klon),soll(klon) + real sens(klon),evap(klon),rain_fall(klon),snow_fall(klon) + REAL ts(klon) + REAL d_etp_tot, d_qt_tot, d_ec_tot +c Output variables + REAL fs_bound, fq_bound +C +C Local variables + real stops,stopl,ssols,ssoll + real ssens,sfront,slat + real airetot, zcpvap, zcwat, zcice + REAL rain_fall_tot, snow_fall_tot, evap_tot +C + integer i +C + integer pas + save pas + data pas/0/ +c$OMP THREADPRIVATE(pas) +C + pas=pas+1 + stops=0. + stopl=0. + ssols=0. + ssoll=0. + ssens=0. + sfront = 0. + evap_tot = 0. + rain_fall_tot = 0. + snow_fall_tot = 0. + airetot=0. +C +C Pour les chaleur specifiques de la vapeur d'eau, de l'eau et de +C la glace, on travaille par difference a la chaleur specifique de l' +c air sec. En effet, comme on travaille a niveau de pression donne, +C toute variation de la masse d'un constituant est totalement +c compense par une variation de masse d'air. +C + zcpvap=RCPV-RCPD + zcwat=RCW-RCPD + zcice=RCS-RCPD +C + do i=1,klon + stops=stops+tops(i)*airephy(i) + stopl=stopl+topl(i)*airephy(i) + ssols=ssols+sols(i)*airephy(i) + ssoll=ssoll+soll(i)*airephy(i) + ssens=ssens+sens(i)*airephy(i) + sfront = sfront + $ + ( evap(i)*zcpvap-rain_fall(i)*zcwat-snow_fall(i)*zcice + $ ) *ts(i) *airephy(i) + evap_tot = evap_tot + evap(i)*airephy(i) + rain_fall_tot = rain_fall_tot + rain_fall(i)*airephy(i) + snow_fall_tot = snow_fall_tot + snow_fall(i)*airephy(i) + airetot=airetot+airephy(i) + enddo + stops=stops/airetot + stopl=stopl/airetot + ssols=ssols/airetot + ssoll=ssoll/airetot + ssens=ssens/airetot + sfront = sfront/airetot + evap_tot = evap_tot /airetot + rain_fall_tot = rain_fall_tot/airetot + snow_fall_tot = snow_fall_tot/airetot +C + slat = RLVTT * rain_fall_tot + RLSTT * snow_fall_tot +C Heat flux at atm. boundaries + fs_bound = stops-stopl - (ssols+ssoll)+ssens+sfront + $ + slat +C Watter flux at atm. boundaries + fq_bound = evap_tot - rain_fall_tot -snow_fall_tot +C + IF (iprt.ge.1) write(6,6666) + $ tit, pas, fs_bound, d_etp_tot, fq_bound, d_qt_tot +C + IF (iprt.ge.1) write(6,6668) + $ tit, pas, d_etp_tot+d_ec_tot-fs_bound, d_qt_tot-fq_bound +C + IF (iprt.ge.2) write(6,6667) + $ tit, pas, stops,stopl,ssols,ssoll,ssens,slat,evap_tot + $ ,rain_fall_tot+snow_fall_tot + + return + + 6666 format('Phys. Flux Budget ',a15,1i6,2f8.2,2(1pE13.5)) + 6667 format('Phys. Boundary Flux ',a15,1i6,6f8.2,2(1pE13.5)) + 6668 format('Phys. Total Budget ',a15,1i6,f8.2,2(1pE13.5)) + + end + +C====================================================================== + SUBROUTINE diagetpq(airephy,tit,iprt,idiag,idiag2,dtime + e ,t,q,ql,qs,u,v,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) +C====================================================================== +C +C Purpose: +C Calcul la difference d'enthalpie et de masse d'eau entre 2 appels, +C et calcul le flux de chaleur et le flux d'eau necessaire a ces +C changements. Ces valeurs sont moyennees sur la surface de tout +C le globe et sont exprime en W/2 et kg/s/m2 +C Outil pour diagnostiquer la conservation de l'energie +C et de la masse dans la physique. Suppose que les niveau de +c pression entre couche ne varie pas entre 2 appels. +C +C Plusieurs de ces diagnostics peuvent etre fait en parallele: les +c bilans sont sauvegardes dans des tableaux indices. On parlera +C "d'indice de diagnostic" +c +C +c====================================================================== +C Arguments: +C airephy-------input-R- grid area +C tit-----imput-A15- Comment added in PRINT (CHARACTER*15) +C iprt----input-I- PRINT level ( <=1 : no PRINT) +C idiag---input-I- indice dans lequel sera range les nouveaux +C bilans d' entalpie et de masse +C idiag2--input-I-les nouveaux bilans d'entalpie et de masse +C sont compare au bilan de d'enthalpie de masse de +C l'indice numero idiag2 +C Cas parriculier : si idiag2=0, pas de comparaison, on +c sort directement les bilans d'enthalpie et de masse +C dtime----input-R- time step (s) +c t--------input-R- temperature (K) +c q--------input-R- vapeur d'eau (kg/kg) +c ql-------input-R- liquid watter (kg/kg) +c qs-------input-R- solid watter (kg/kg) +c u--------input-R- vitesse u +c v--------input-R- vitesse v +c paprs----input-R- pression a intercouche (Pa) +c pplay----input-R- pression au milieu de couche (Pa) +c +C the following total value are computed by UNIT of earth surface +C +C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy +c change (J/m2) during one time step (dtime) for the whole +C atmosphere (air, watter vapour, liquid and solid) +C d_qt------output-R- total water mass flux (kg/m2/s) defined as the +C total watter (kg/m2) change during one time step (dtime), +C d_qw------output-R- same, for the watter vapour only (kg/m2/s) +C d_ql------output-R- same, for the liquid watter only (kg/m2/s) +C d_qs------output-R- same, for the solid watter only (kg/m2/s) +C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column +C +C other (COMMON...) +C RCPD, RCPV, .... +C +C J.L. Dufresne, July 2002 +c====================================================================== + + USE dimphy + IMPLICIT NONE +C +#include "dimensions.h" +cccccc#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +C +c Input variables + real airephy(klon) + CHARACTER*15 tit + INTEGER iprt,idiag, idiag2 + REAL dtime + REAL t(klon,klev), q(klon,klev), ql(klon,klev), qs(klon,klev) + REAL u(klon,klev), v(klon,klev) + REAL paprs(klon,klev+1), pplay(klon,klev) +c Output variables + REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec +C +C Local variables +c + REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + . , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot +c h_vcol_tot-- total enthalpy of vertical air column +C (air with watter vapour, liquid and solid) (J/m2) +c h_dair_tot-- total enthalpy of dry air (J/m2) +c h_qw_tot---- total enthalpy of watter vapour (J/m2) +c h_ql_tot---- total enthalpy of liquid watter (J/m2) +c h_qs_tot---- total enthalpy of solid watter (J/m2) +c qw_tot------ total mass of watter vapour (kg/m2) +c ql_tot------ total mass of liquid watter (kg/m2) +c qs_tot------ total mass of solid watter (kg/m2) +c ec_tot------ total cinetic energy (kg/m2) +C + REAL zairm(klon,klev) ! layer air mass (kg/m2) + REAL zqw_col(klon) + REAL zql_col(klon) + REAL zqs_col(klon) + REAL zec_col(klon) + REAL zh_dair_col(klon) + REAL zh_qw_col(klon), zh_ql_col(klon), zh_qs_col(klon) +C + REAL d_h_dair, d_h_qw, d_h_ql, d_h_qs +C + REAL airetot, zcpvap, zcwat, zcice +C + INTEGER i, k +C + INTEGER ndiag ! max number of diagnostic in parallel + PARAMETER (ndiag=10) + integer pas(ndiag) + save pas + data pas/ndiag*0/ +c$OMP THREADPRIVATE(pas) +C + REAL h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag) + $ , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag) + $ , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag) + SAVE h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre + $ , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre +c$OMP THREADPRIVATE(h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre) +c$OMP THREADPRIVATE(h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre) +c====================================================================== +C + DO k = 1, klev + DO i = 1, klon +C layer air mass + zairm(i,k) = (paprs(i,k)-paprs(i,k+1))/RG + ENDDO + END DO +C +C Reset variables + DO i = 1, klon + zqw_col(i)=0. + zql_col(i)=0. + zqs_col(i)=0. + zec_col(i) = 0. + zh_dair_col(i) = 0. + zh_qw_col(i) = 0. + zh_ql_col(i) = 0. + zh_qs_col(i) = 0. + ENDDO +C + zcpvap=RCPV + zcwat=RCW + zcice=RCS +C +C Compute vertical sum for each atmospheric column +C ================================================ + DO k = 1, klev + DO i = 1, klon +C Watter mass + zqw_col(i) = zqw_col(i) + q(i,k)*zairm(i,k) + zql_col(i) = zql_col(i) + ql(i,k)*zairm(i,k) + zqs_col(i) = zqs_col(i) + qs(i,k)*zairm(i,k) +C Cinetic Energy + zec_col(i) = zec_col(i) + $ +0.5*(u(i,k)**2+v(i,k)**2)*zairm(i,k) +C Air enthalpy + zh_dair_col(i) = zh_dair_col(i) + $ + RCPD*(1.-q(i,k)-ql(i,k)-qs(i,k))*zairm(i,k)*t(i,k) + zh_qw_col(i) = zh_qw_col(i) + $ + zcpvap*q(i,k)*zairm(i,k)*t(i,k) + zh_ql_col(i) = zh_ql_col(i) + $ + zcwat*ql(i,k)*zairm(i,k)*t(i,k) + $ - RLVTT*ql(i,k)*zairm(i,k) + zh_qs_col(i) = zh_qs_col(i) + $ + zcice*qs(i,k)*zairm(i,k)*t(i,k) + $ - RLSTT*qs(i,k)*zairm(i,k) + + END DO + ENDDO +C +C Mean over the planete surface +C ============================= + qw_tot = 0. + ql_tot = 0. + qs_tot = 0. + ec_tot = 0. + h_vcol_tot = 0. + h_dair_tot = 0. + h_qw_tot = 0. + h_ql_tot = 0. + h_qs_tot = 0. + airetot=0. +C + do i=1,klon + qw_tot = qw_tot + zqw_col(i)*airephy(i) + ql_tot = ql_tot + zql_col(i)*airephy(i) + qs_tot = qs_tot + zqs_col(i)*airephy(i) + ec_tot = ec_tot + zec_col(i)*airephy(i) + h_dair_tot = h_dair_tot + zh_dair_col(i)*airephy(i) + h_qw_tot = h_qw_tot + zh_qw_col(i)*airephy(i) + h_ql_tot = h_ql_tot + zh_ql_col(i)*airephy(i) + h_qs_tot = h_qs_tot + zh_qs_col(i)*airephy(i) + airetot=airetot+airephy(i) + END DO +C + qw_tot = qw_tot/airetot + ql_tot = ql_tot/airetot + qs_tot = qs_tot/airetot + ec_tot = ec_tot/airetot + h_dair_tot = h_dair_tot/airetot + h_qw_tot = h_qw_tot/airetot + h_ql_tot = h_ql_tot/airetot + h_qs_tot = h_qs_tot/airetot +C + h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot +C +C Compute the change of the atmospheric state compare to the one +C stored in "idiag2", and convert it in flux. THis computation +C is performed IF idiag2 /= 0 and IF it is not the first CALL +c for "idiag" +C =================================== +C + IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN + d_h_vcol = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime + d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime + d_h_qw = (h_qw_tot - h_qw_pre(idiag2) )/dtime + d_h_ql = (h_ql_tot - h_ql_pre(idiag2) )/dtime + d_h_qs = (h_qs_tot - h_qs_pre(idiag2) )/dtime + d_qw = (qw_tot - qw_pre(idiag2) )/dtime + d_ql = (ql_tot - ql_pre(idiag2) )/dtime + d_qs = (qs_tot - qs_pre(idiag2) )/dtime + d_ec = (ec_tot - ec_pre(idiag2) )/dtime + d_qt = d_qw + d_ql + d_qs + ELSE + d_h_vcol = 0. + d_h_dair = 0. + d_h_qw = 0. + d_h_ql = 0. + d_h_qs = 0. + d_qw = 0. + d_ql = 0. + d_qs = 0. + d_ec = 0. + d_qt = 0. + ENDIF +C + IF (iprt.ge.2) THEN + WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs + 9000 format('Phys. Watter Mass Budget (kg/m2/s)',A15 + $ ,1i6,10(1pE14.6)) + WRITE(6,9001) tit,pas(idiag), d_h_vcol + 9001 format('Phys. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2)) + WRITE(6,9002) tit,pas(idiag), d_ec + 9002 format('Phys. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2)) + END IF +C +C Store the new atmospheric state in "idiag" +C + pas(idiag)=pas(idiag)+1 + h_vcol_pre(idiag) = h_vcol_tot + h_dair_pre(idiag) = h_dair_tot + h_qw_pre(idiag) = h_qw_tot + h_ql_pre(idiag) = h_ql_tot + h_qs_pre(idiag) = h_qs_tot + qw_pre(idiag) = qw_tot + ql_pre(idiag) = ql_tot + qs_pre(idiag) = qs_tot + ec_pre (idiag) = ec_tot +C + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/dimphy.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/dimphy.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/dimphy.F90 (revision 1280) @@ -0,0 +1,40 @@ +MODULE dimphy + + INTEGER,SAVE :: klon + INTEGER,SAVE :: kdlon + INTEGER,SAVE :: kfdia + INTEGER,SAVE :: kidia + INTEGER,SAVE :: klev + INTEGER,SAVE :: klevp1 + INTEGER,SAVE :: klevm1 + INTEGER,SAVE :: kflev + +!$OMP THREADPRIVATE(klon,kfdia,kidia,kdlon) + REAL,save,allocatable,dimension(:) :: zmasq +!$OMP THREADPRIVATE(zmasq) + +CONTAINS + + SUBROUTINE Init_dimphy(klon0,klev0) + IMPLICIT NONE + + INTEGER, INTENT(in) :: klon0 + INTEGER, INTENT(in) :: klev0 + + klon=klon0 + + kdlon=klon + kidia=1 + kfdia=klon +!$OMP MASTER + klev=klev0 + klevp1=klev+1 + klevm1=klev-1 + kflev=klev +!$OMP END MASTER + ALLOCATE(zmasq(klon)) + + END SUBROUTINE Init_dimphy + + +END MODULE dimphy Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/dimsoil.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/dimsoil.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/dimsoil.h (revision 1280) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER nsoilmx + PARAMETER (nsoilmx=11) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ecribin.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ecribin.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ecribin.F (revision 1280) @@ -0,0 +1,104 @@ +! +! $Header$ +! + SUBROUTINE ecribins(unit,pz) + USE dimphy + IMPLICIT none +c----------------------------------------------------------------------- +#include "dimensions.h" +cccc#include "dimphy.h" +#include "paramet.h" +#include "comgeom.h" +#include "comvert.h" +c +c arguments: +c ---------- + INTEGER unit + REAL pz(klon) +c +c local: +c ------ + INTEGER i,j, ig + REAL zz(iim +1,jjm+1) +c----------------------------------------------------------------------- +c passage a la grille dynamique: +c ------------------------------ + DO i=1,iim +1 + zz(i,1)=pz(1) + zz(i,jjm+1)=pz(klon) + ENDDO +c traitement des point normaux + DO j=2,jjm + ig=2+(j-2)*iim + CALL SCOPY(iim,pz(ig),1,zz(1,j),1) + zz(iim+1,j)=zz(1,j) + ENDDO +c----------------------------------------------------------------------- +#ifdef VPP + CALL ecriture(unit,zz,(iim+1)*(jjm+1)) +#else + WRITE(unit) zz +#endif +c + + RETURN + END + SUBROUTINE ecribina(unit,pz) + USE dimphy + IMPLICIT none +c----------------------------------------------------------------------- +#include "dimensions.h" +cccc#include "dimphy.h" +#include "paramet.h" +#include "comgeom.h" +#include "comvert.h" +c +c arguments: +c ---------- + INTEGER unit + REAL pz(klon,klev) +c +c local: +c ------ + INTEGER i,j,ilay,ig + REAL zz(iim+1,jjm+1,llm) +c----------------------------------------------------------------------- +c passage a la grille dynamique: +c ------------------------------ + DO ilay=1,llm +c traitement des poles + DO i=1,iim +1 + zz(i,1,ilay)=pz(1,ilay) + zz(i,jjm+1,ilay)=pz(klon,ilay) + ENDDO +c traitement des point normaux + DO j=2,jjm + ig=2+(j-2)*iim + CALL SCOPY(iim,pz(ig,ilay),1,zz(1,j,ilay),1) + zz(iim+1,j,ilay)=zz(1,j,ilay) + ENDDO + ENDDO +c----------------------------------------------------------------------- + DO ilay = 1, llm +#ifdef VPP + CALL ecriture(unit, zz(1,1,ilay), (iim+1)*(jjm+1)) +#else + WRITE(unit) ((zz(i,j,ilay),i=1,iim +1),j=1,jjm+1) +#endif + ENDDO +c + RETURN + END +#ifdef VPP +@OPTIONS NODOUBLE + SUBROUTINE ecriture(nunit, r8, n) + INTEGER nunit, n, i + REAL(KIND=8) r8(n) + REAL r4(n) + DO i = 1, n + r4(i) = r8(i) + ENDDO + WRITE(nunit)r4 + RETURN + END +#endif Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ecrireg.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ecrireg.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ecrireg.F (revision 1280) @@ -0,0 +1,121 @@ +! +! $Header$ +! + SUBROUTINE ecriregs(unit,pz) + use dimphy + IMPLICIT none +c----------------------------------------------------------------------- +#include "dimensions.h" +cccc#include "dimphy.h" +#include "paramet.h" +#include "comgeom.h" +#include "comvert.h" +#include "regdim.h" +c +c arguments: +c ---------- + INTEGER unit + REAL pz(klon) +c +c local: +c ------ + INTEGER i,j, ig + REAL zz(iim,jjm+1) + INTEGER nleng + PARAMETER (nleng=(i2_fin-i2_deb+1+i1_fin-i1_deb+1) + . *(j_fin-j_deb+1)) + REAL zzz(nleng) +c +c----------------------------------------------------------------------- +c passage a la grille dynamique: +c ------------------------------ + DO i=1,iim + zz(i,1)=pz(1) + zz(i,jjm+1)=pz(klon) + ENDDO +c +c traitement des point normaux + DO j=2,jjm + ig=2+(j-2)*iim + CALL SCOPY(iim,pz(ig),1,zz(1,j),1) + ENDDO +c----------------------------------------------------------------------- + ig = 0 + DO j = j_deb, j_fin + DO i=i1_deb,i1_fin + ig = ig + 1 + zzz(ig) = zz(i,j) + ENDDO + DO i=i2_deb,i2_fin + ig = ig + 1 + zzz(ig) = zz(i,j) + ENDDO + ENDDO +#ifdef VPP + CALL ecriture(unit,zzz,nleng) +#else + WRITE(unit) zzz +#endif + RETURN + END + SUBROUTINE ecrirega(unit,pz) + USE dimphy + IMPLICIT none +c----------------------------------------------------------------------- +#include "dimensions.h" +cccc#include "dimphy.h" +#include "paramet.h" +#include "comgeom.h" +#include "comvert.h" +#include "regdim.h" +c +c arguments: +c ---------- + INTEGER unit + REAL pz(klon,klev) +c +c local: +c ------ + INTEGER i,j,ilay,ig + REAL zz(iim,jjm+1,llm) + INTEGER nleng + PARAMETER (nleng=(i2_fin-i2_deb+1+i1_fin-i1_deb+1) + . *(j_fin-j_deb+1)) + REAL zzz(nleng) +c----------------------------------------------------------------------- +c passage a la grille dynamique: +c ------------------------------ + DO ilay=1,llm +c traitement des poles + DO i=1,iim + zz(i,1,ilay)=pz(1,ilay) + zz(i,jjm+1,ilay)=pz(klon,ilay) + ENDDO +c traitement des point normaux + DO j=2,jjm + ig=2+(j-2)*iim + CALL SCOPY(iim,pz(ig,ilay),1,zz(1,j,ilay),1) + ENDDO + ENDDO +c----------------------------------------------------------------------- + DO ilay = 1, llm + ig = 0 + DO j = j_deb, j_fin + DO i=i1_deb,i1_fin + ig = ig + 1 + zzz(ig) = zz(i,j,ilay) + ENDDO + DO i=i2_deb,i2_fin + ig = ig + 1 + zzz(ig) = zz(i,j,ilay) + ENDDO + ENDDO +#ifdef VPP + CALL ecriture(unit,zzz,nleng) +#else + WRITE(unit) zzz +#endif + ENDDO + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/fisrtilp.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/fisrtilp.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/fisrtilp.F (revision 1280) @@ -0,0 +1,569 @@ +! +! $Header$ +! +c + SUBROUTINE fisrtilp(dtime,paprs,pplay,t,q,ptconv,ratqs, + s d_t, d_q, d_ql, rneb, radliq, rain, snow, + s pfrac_impa, pfrac_nucl, pfrac_1nucl, + s frac_impa, frac_nucl, + s prfl, psfl, rhcl) + +c + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) +c Date: le 20 mars 1995 +c Objet: condensation et precipitation stratiforme. +c schema de nuage +c====================================================================== +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "tracstoke.h" +#include "fisrtilp.h" +c +c Arguments: +c + REAL dtime ! intervalle du temps (s) + REAL paprs(klon,klev+1) ! pression a inter-couche + REAL pplay(klon,klev) ! pression au milieu de couche + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (kg/kg) + REAL d_t(klon,klev) ! incrementation de la temperature (K) + REAL d_q(klon,klev) ! incrementation de la vapeur d'eau + REAL d_ql(klon,klev) ! incrementation de l'eau liquide + REAL rneb(klon,klev) ! fraction nuageuse + REAL radliq(klon,klev) ! eau liquide utilisee dans rayonnements + REAL rhcl(klon,klev) ! humidite relative en ciel clair + REAL rain(klon) ! pluies (mm/s) + REAL snow(klon) ! neige (mm/s) + REAL prfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s) + REAL psfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s) +cAA +c Coeffients de fraction lessivee : pour OFF-LINE +c + REAL pfrac_nucl(klon,klev) + REAL pfrac_1nucl(klon,klev) + REAL pfrac_impa(klon,klev) +c +c Fraction d'aerosols lessivee par impaction et par nucleation +c POur ON-LINE +c + REAL frac_impa(klon,klev) + REAL frac_nucl(klon,klev) + real zct ,zcl +cAA +c +c Options du programme: +c + REAL seuil_neb ! un nuage existe vraiment au-dela + PARAMETER (seuil_neb=0.001) + + INTEGER ninter ! sous-intervals pour la precipitation + INTEGER ncoreczq + PARAMETER (ninter=5) + LOGICAL evap_prec ! evaporation de la pluie + PARAMETER (evap_prec=.TRUE.) + REAL ratqs(klon,klev) ! determine la largeur de distribution de vapeur + logical ptconv(klon,klev) ! determine la largeur de distribution de vapeur + + real zpdf_sig(klon),zpdf_k(klon),zpdf_delta(klon) + real Zpdf_a(klon),zpdf_b(klon),zpdf_e1(klon),zpdf_e2(klon) + real erf +c + LOGICAL cpartiel ! condensation partielle + PARAMETER (cpartiel=.TRUE.) + REAL t_coup + PARAMETER (t_coup=234.0) +c +c Variables locales: +c + INTEGER i, k, n, kk + REAL zqs(klon), zdqs(klon), zdelta, zcor, zcvm5 + REAL zrfl(klon), zrfln(klon), zqev, zqevt + REAL zoliq(klon), zcond(klon), zq(klon), zqn(klon), zdelq + REAL ztglace, zt(klon) + INTEGER nexpo ! exponentiel pour glace/eau + REAL zdz(klon),zrho(klon),ztot , zrhol(klon) + REAL zchau ,zfroi ,zfice(klon),zneb(klon) +c + LOGICAL appel1er + SAVE appel1er +c$OMP THREADPRIVATE(appel1er) +c +c--------------------------------------------------------------- +c +cAA Variables traceurs: +cAA Provisoire !!! Parametres alpha du lessivage +cAA A priori on a 4 scavenging # possibles +c + REAL a_tr_sca(4) + save a_tr_sca +c$OMP THREADPRIVATE(a_tr_sca) +c +c Variables intermediaires +c + REAL zalpha_tr + REAL zfrac_lessi + REAL zprec_cond(klon) +cAA + REAL zmair, zcpair, zcpeau +C Pour la conversion eau-neige + REAL zlh_solid(klon), zm_solid +cIM +cym INTEGER klevm1 +c--------------------------------------------------------------- +c +c Fonctions en ligne: +c + REAL fallvs,fallvc ! vitesse de chute pour crystaux de glace + REAL zzz +#include "YOETHF.h" +#include "FCTTRE.h" + fallvc (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_con + fallvs (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_lsc +c + DATA appel1er /.TRUE./ +cym + zdelq=0.0 + + IF (appel1er) THEN +c + PRINT*, 'fisrtilp, ninter:', ninter + PRINT*, 'fisrtilp, evap_prec:', evap_prec + PRINT*, 'fisrtilp, cpartiel:', cpartiel + IF (ABS(dtime/FLOAT(ninter)-360.0).GT.0.001) THEN + PRINT*, 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime + PRINT*, 'Je prefere un sous-intervalle de 6 minutes' +c CALL abort + ENDIF + appel1er = .FALSE. +c +cAA initialiation provisoire + a_tr_sca(1) = -0.5 + a_tr_sca(2) = -0.5 + a_tr_sca(3) = -0.5 + a_tr_sca(4) = -0.5 +c +cAA Initialisation a 1 des coefs des fractions lessivees +c +!cdir collapse + DO k = 1, klev + DO i = 1, klon + pfrac_nucl(i,k)=1. + pfrac_1nucl(i,k)=1. + pfrac_impa(i,k)=1. + ENDDO + ENDDO + + ENDIF ! test sur appel1er +c +cMAf Initialisation a 0 de zoliq +c DO i = 1, klon +c zoliq(i)=0. +c ENDDO +c Determiner les nuages froids par leur temperature +c nexpo regle la raideur de la transition eau liquide / eau glace. +c + ztglace = RTT - 15.0 + nexpo = 6 +ccc nexpo = 1 +c +c Initialiser les sorties: +c +!cdir collapse + DO k = 1, klev+1 + DO i = 1, klon + prfl(i,k) = 0.0 + psfl(i,k) = 0.0 + ENDDO + ENDDO + +!cdir collapse + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + d_ql(i,k) = 0.0 + rneb(i,k) = 0.0 + radliq(i,k) = 0.0 + frac_nucl(i,k) = 1. + frac_impa(i,k) = 1. + ENDDO + ENDDO + DO i = 1, klon + rain(i) = 0.0 + snow(i) = 0.0 + zoliq(i)=0. +c ENDDO +c +c Initialiser le flux de precipitation a zero +c +c DO i = 1, klon + zrfl(i) = 0.0 + zneb(i) = seuil_neb + ENDDO +c +c +cAA Pour plus de securite + + zalpha_tr = 0. + zfrac_lessi = 0. + +cAA---------------------------------------------------------- +c + ncoreczq=0 +c Boucle verticale (du haut vers le bas) +c +cIM : klevm1 +cym klevm1=klev-1 + DO 9999 k = klev, 1, -1 +c +cAA---------------------------------------------------------- +c + DO i = 1, klon + zt(i)=t(i,k) + zq(i)=q(i,k) + ENDDO +c +c Calculer la varition de temp. de l'air du a la chaleur sensible +C transporter par la pluie. +C Il resterait a rajouter cet effet de la chaleur sensible sur les +C flux de surface, du a la diff. de temp. entre le 1er niveau et la +C surface. +C + IF(k.LE.klevm1) THEN + DO i = 1, klon +cIM + zmair=(paprs(i,k)-paprs(i,k+1))/RG + zcpair=RCPD*(1.0+RVTMP2*zq(i)) + zcpeau=RCPD*RVTMP2 + zt(i) = ( (t(i,k+1)+d_t(i,k+1))*zrfl(i)*dtime*zcpeau + $ + zmair*zcpair*zt(i) ) + $ / (zmair*zcpair + zrfl(i)*dtime*zcpeau) +C C WRITE (6,*) 'cppluie ', zt(i)-(t(i,k+1)+d_t(i,k+1)) + ENDDO + ENDIF +c +c +c Calculer l'evaporation de la precipitation +c + + + IF (evap_prec) THEN + DO i = 1, klon + IF (zrfl(i) .GT.0.) THEN + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-zt(i))) + zqs(i)= R2ES*FOEEW(zt(i),zdelta)/pplay(i,k) + zqs(i)=MIN(0.5,zqs(i)) + zcor=1./(1.-RETV*zqs(i)) + zqs(i)=zqs(i)*zcor + ELSE + IF (zt(i) .LT. t_coup) THEN + zqs(i) = qsats(zt(i)) / pplay(i,k) + ELSE + zqs(i) = qsatl(zt(i)) / pplay(i,k) + ENDIF + ENDIF + zqev = MAX (0.0, (zqs(i)-zq(i))*zneb(i) ) + zqevt = coef_eva * (1.0-zq(i)/zqs(i)) * SQRT(zrfl(i)) + . * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG + zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) + . * RG*dtime/(paprs(i,k)-paprs(i,k+1)) + zqev = MIN (zqev, zqevt) + zrfln(i) = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1)) + . /RG/dtime + +c pour la glace, on r�vapore toute la pr�ip dans la couche du dessous +c la glace venant de la couche du dessus est simplement dans la couche +c du dessous. + + IF (zt(i) .LT. t_coup.and.reevap_ice) zrfln(i)=0. + + zq(i) = zq(i) - (zrfln(i)-zrfl(i)) + . * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime + zt(i) = zt(i) + (zrfln(i)-zrfl(i)) + . * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime + . * RLVTT/RCPD/(1.0+RVTMP2*zq(i)) + zrfl(i) = zrfln(i) + ENDIF + ENDDO + ENDIF +c +c Calculer Qs et L/Cp*dQs/dT: +c + IF (thermcep) THEN + DO i = 1, klon + zdelta = MAX(0.,SIGN(1.,RTT-zt(i))) + zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i)) + zqs(i) = R2ES*FOEEW(zt(i),zdelta)/pplay(i,k) + zqs(i) = MIN(0.5,zqs(i)) + zcor = 1./(1.-RETV*zqs(i)) + zqs(i) = zqs(i)*zcor + zdqs(i) = FOEDE(zt(i),zdelta,zcvm5,zqs(i),zcor) + ENDDO + ELSE + DO i = 1, klon + IF (zt(i).LT.t_coup) THEN + zqs(i) = qsats(zt(i))/pplay(i,k) + zdqs(i) = dqsats(zt(i),zqs(i)) + ELSE + zqs(i) = qsatl(zt(i))/pplay(i,k) + zdqs(i) = dqsatl(zt(i),zqs(i)) + ENDIF + ENDDO + ENDIF +c +c Determiner la condensation partielle et calculer la quantite +c de l'eau condensee: +c + IF (cpartiel) THEN + +c print*,'Dans partiel k=',k +c +c Calcul de l'eau condensee et de la fraction nuageuse et de l'eau +c nuageuse a partir des PDF de Sandrine Bony. +c rneb : fraction nuageuse +c zqn : eau totale dans le nuage +c zcond : eau condensee moyenne dans la maille. +c on prend en compte le r�hauffement qui diminue la partie condensee +c +c Version avec les raqts + + if (iflag_pdf.eq.0) then + + do i=1,klon + zdelq = min(ratqs(i,k),0.99) * zq(i) + rneb(i,k) = (zq(i)+zdelq-zqs(i)) / (2.0*zdelq) + zqn(i) = (zq(i)+zdelq+zqs(i))/2.0 + enddo + + else +c +c Version avec les nouvelles PDFs. + do i=1,klon + if(zq(i).lt.1.e-15) then + ncoreczq=ncoreczq+1 + zq(i)=1.e-15 + endif + enddo + do i=1,klon + zpdf_sig(i)=ratqs(i,k)*zq(i) + zpdf_k(i)=-sqrt(log(1.+(zpdf_sig(i)/zq(i))**2)) + zpdf_delta(i)=log(zq(i)/zqs(i)) + zpdf_a(i)=zpdf_delta(i)/(zpdf_k(i)*sqrt(2.)) + zpdf_b(i)=zpdf_k(i)/(2.*sqrt(2.)) + zpdf_e1(i)=zpdf_a(i)-zpdf_b(i) + zpdf_e1(i)=sign(min(abs(zpdf_e1(i)),5.),zpdf_e1(i)) + zpdf_e1(i)=1.-erf(zpdf_e1(i)) + zpdf_e2(i)=zpdf_a(i)+zpdf_b(i) + zpdf_e2(i)=sign(min(abs(zpdf_e2(i)),5.),zpdf_e2(i)) + zpdf_e2(i)=1.-erf(zpdf_e2(i)) + if (zpdf_e1(i).lt.1.e-10) then + rneb(i,k)=0. + zqn(i)=zqs(i) + else + rneb(i,k)=0.5*zpdf_e1(i) + zqn(i)=zq(i)*zpdf_e2(i)/zpdf_e1(i) + endif + + enddo + + endif ! iflag_pdf + + DO i=1,klon + IF (rneb(i,k) .LE. 0.0) THEN + zqn(i) = 0.0 + rneb(i,k) = 0.0 + zcond(i) = 0.0 + rhcl(i,k)=zq(i)/zqs(i) + ELSE IF (rneb(i,k) .GE. 1.0) THEN + zqn(i) = zq(i) + rneb(i,k) = 1.0 + zcond(i) = MAX(0.0,zqn(i)-zqs(i)) + rhcl(i,k)=1.0 + ELSE + zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k) + rhcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i) + ENDIF + ENDDO +! do i=1,klon +! IF (rneb(i,k) .LE. 0.0) zqn(i) = 0.0 +! IF (rneb(i,k) .GE. 1.0) zqn(i) = zq(i) +! rneb(i,k) = MAX(0.0,MIN(1.0,rneb(i,k))) +!c zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)/(1.+zdqs(i)) +!c On ne divise pas par 1+zdqs pour forcer a avoir l'eau predite par +!c la convection. +!c ATTENTION !!! Il va falloir verifier tout ca. +! zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k) +!c print*,'ZDQS ',zdqs(i) +!c--Olivier +! rhcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i) +! IF (rneb(i,k) .LE. 0.0) rhcl(i,k)=zq(i)/zqs(i) +! IF (rneb(i,k) .GE. 1.0) rhcl(i,k)=1.0 +!c--fin +! ENDDO + ELSE + DO i = 1, klon + IF (zq(i).GT.zqs(i)) THEN + rneb(i,k) = 1.0 + ELSE + rneb(i,k) = 0.0 + ENDIF + zcond(i) = MAX(0.0,zq(i)-zqs(i))/(1.+zdqs(i)) + ENDDO + ENDIF +c + DO i = 1, klon + zq(i) = zq(i) - zcond(i) +c zt(i) = zt(i) + zcond(i) * RLVTT/RCPD + zt(i) = zt(i) + zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*zq(i)) + ENDDO +c +c Partager l'eau condensee en precipitation et eau liquide nuageuse +c + DO i = 1, klon + IF (rneb(i,k).GT.0.0) THEN + zoliq(i) = zcond(i) + zrho(i) = pplay(i,k) / zt(i) / RD + zdz(i) = (paprs(i,k)-paprs(i,k+1)) / (zrho(i)*RG) + zfice(i) = 1.0 - (zt(i)-ztglace) / (273.13-ztglace) + zfice(i) = MIN(MAX(zfice(i),0.0),1.0) + zfice(i) = zfice(i)**nexpo + zneb(i) = MAX(rneb(i,k), seuil_neb) + radliq(i,k) = zoliq(i)/FLOAT(ninter+1) + ENDIF + ENDDO +c + DO n = 1, ninter + DO i = 1, klon + IF (rneb(i,k).GT.0.0) THEN + zrhol(i) = zrho(i) * zoliq(i) / zneb(i) + + IF (zneb(i).EQ.seuil_neb) THEN + ztot = 0.0 + ELSE +c quantite d'eau a eliminer: zchau +c meme chose pour la glace: zfroi + if (ptconv(i,k)) then + zcl =cld_lc_con + zct =1./cld_tau_con + zfroi = dtime/FLOAT(ninter)/zdz(i)*zoliq(i) + . *fallvc(zrhol(i)) * zfice(i) + else + zcl =cld_lc_lsc + zct =1./cld_tau_lsc + zfroi = dtime/FLOAT(ninter)/zdz(i)*zoliq(i) + . *fallvs(zrhol(i)) * zfice(i) + endif + zchau = zct *dtime/FLOAT(ninter) * zoliq(i) + . *(1.0-EXP(-(zoliq(i)/zneb(i)/zcl )**2)) *(1.-zfice(i)) + ztot = zchau + zfroi + ztot = MAX(ztot ,0.0) + ENDIF + ztot = MIN(ztot,zoliq(i)) + zoliq(i) = MAX(zoliq(i)-ztot , 0.0) + radliq(i,k) = radliq(i,k) + zoliq(i)/FLOAT(ninter+1) + ENDIF + ENDDO + ENDDO +c + DO i = 1, klon + IF (rneb(i,k).GT.0.0) THEN + d_ql(i,k) = zoliq(i) + zrfl(i) = zrfl(i)+ MAX(zcond(i)-zoliq(i),0.0) + . * (paprs(i,k)-paprs(i,k+1))/(RG*dtime) + ENDIF + IF (zt(i).LT.RTT) THEN + psfl(i,k)=zrfl(i) + ELSE + prfl(i,k)=zrfl(i) + ENDIF + ENDDO +c +c Calculer les tendances de q et de t: +c + DO i = 1, klon + d_q(i,k) = zq(i) - q(i,k) + d_t(i,k) = zt(i) - t(i,k) + ENDDO +c +cAA--------------- Calcul du lessivage stratiforme ------------- + + DO i = 1,klon +c + zprec_cond(i) = MAX(zcond(i)-zoliq(i),0.0) + . * (paprs(i,k)-paprs(i,k+1))/RG + IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN +cAA lessivage nucleation LMD5 dans la couche elle-meme + if (t(i,k) .GE. ztglace) THEN + zalpha_tr = a_tr_sca(3) + else + zalpha_tr = a_tr_sca(4) + endif + zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i)) + pfrac_nucl(i,k)=pfrac_nucl(i,k)*(1.-zneb(i)*zfrac_lessi) + frac_nucl(i,k)= 1.-zneb(i)*zfrac_lessi +c +c nucleation avec un facteur -1 au lieu de -0.5 + zfrac_lessi = 1. - EXP(-zprec_cond(i)/zneb(i)) + pfrac_1nucl(i,k)=pfrac_1nucl(i,k)*(1.-zneb(i)*zfrac_lessi) + ENDIF +c + ENDDO ! boucle sur i +c +cAA Lessivage par impaction dans les couches en-dessous + DO kk = k-1, 1, -1 + DO i = 1, klon + IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN + if (t(i,kk) .GE. ztglace) THEN + zalpha_tr = a_tr_sca(1) + else + zalpha_tr = a_tr_sca(2) + endif + zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i)) + pfrac_impa(i,kk)=pfrac_impa(i,kk)*(1.-zneb(i)*zfrac_lessi) + frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi + ENDIF + ENDDO + ENDDO +c +cAA---------------------------------------------------------- +c FIN DE BOUCLE SUR K + 9999 CONTINUE +c +cAA----------------------------------------------------------- +c +c Pluie ou neige au sol selon la temperature de la 1ere couche +c + DO i = 1, klon + IF ((t(i,1)+d_t(i,1)) .LT. RTT) THEN + snow(i) = zrfl(i) + zlh_solid(i) = RLSTT-RLVTT + ELSE + rain(i) = zrfl(i) + zlh_solid(i) = 0. + ENDIF + ENDDO +C +C For energy conservation : when snow is present, the solification +c latent heat is considered. + DO k = 1, klev + DO i = 1, klon + zcpair=RCPD*(1.0+RVTMP2*(q(i,k)+d_q(i,k))) + zmair=(paprs(i,k)-paprs(i,k+1))/RG + zm_solid = (prfl(i,k)-prfl(i,k+1)+psfl(i,k)-psfl(i,k+1))*dtime + d_t(i,k) = d_t(i,k) + zlh_solid(i) *zm_solid / (zcpair*zmair) + END DO + END DO +c + + if (ncoreczq>0) then + print*,'WARNING : ZQ dans fisrtilp ',ncoreczq,' val < 1.e-15.' + endif + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/fisrtilp.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/fisrtilp.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/fisrtilp.h (revision 1280) @@ -0,0 +1,28 @@ +! +! $Header$ +! +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! + REAL cld_lc_lsc,cld_lc_con + REAL cld_tau_lsc,cld_tau_con + REAL ffallv_lsc,ffallv_con + REAL coef_eva + LOGICAL reevap_ice + INTEGER iflag_pdf + + common/comfisrtilp/ & + & cld_lc_lsc & + & ,cld_lc_con & + & ,cld_tau_lsc & + & ,cld_tau_con & + & ,ffallv_lsc & + & ,ffallv_con & + & ,coef_eva & + & ,reevap_ice & + & ,iflag_pdf + +!$OMP THREADPRIVATE(/comfisrtilp/) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/fisrtilp_tr.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/fisrtilp_tr.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/fisrtilp_tr.F (revision 1280) @@ -0,0 +1,435 @@ +! +! $Header$ +! +c + SUBROUTINE fisrtilp_tr(dtime,paprs,pplay,t,q,ratqs, + s d_t, d_q, d_ql, rneb, radliq, rain, snow, + s pfrac_impa, pfrac_nucl, pfrac_1nucl, + s frac_impa, frac_nucl, + s prfl, psfl, + s RHcl) ! relative humidity in clear sky (needed for aer optical properties; aeropt.F) + +c + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) +c Date: le 20 mars 1995 +c Objet: condensation et precipitation stratiforme. +c schema de nuage +c====================================================================== +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "tracstoke.h" +c +c Arguments: +c + REAL dtime ! intervalle du temps (s) + REAL paprs(klon,klev+1) ! pression a inter-couche + REAL pplay(klon,klev) ! pression au milieu de couche + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (kg/kg) + REAL d_t(klon,klev) ! incrementation de la temperature (K) + REAL d_q(klon,klev) ! incrementation de la vapeur d'eau + REAL d_ql(klon,klev) ! incrementation de l'eau liquide + REAL rneb(klon,klev) ! fraction nuageuse + REAL radliq(klon,klev) ! eau liquide utilisee dans rayonnements + REAL rain(klon) ! pluies (mm/s) + REAL snow(klon) ! neige (mm/s) + REAL prfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s) + REAL psfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s) + +Cjq For aerosol opt properties needed (see aeropt.F) + REAL RHcl(klon,klev) + +cAA +c Coeffients de fraction lessivee : pour OFF-LINE +c + REAL pfrac_nucl(klon,klev) + REAL pfrac_1nucl(klon,klev) + REAL pfrac_impa(klon,klev) +c +c Fraction d'aerosols lessivee par impaction et par nucleation +c POur ON-LINE +c + REAL frac_impa(klon,klev) + REAL frac_nucl(klon,klev) +cAA +c +c Options du programme: +c + REAL seuil_neb ! un nuage existe vraiment au-dela + PARAMETER (seuil_neb=0.001) + REAL ct ! inverse du temps pour qu'un nuage precipite + PARAMETER (ct=1./1800.) + REAL cl ! seuil de precipitation + PARAMETER (cl=2.6e-4) +ccc PARAMETER (cl=2.3e-4) +ccc PARAMETER (cl=2.0e-4) + INTEGER ninter ! sous-intervals pour la precipitation + PARAMETER (ninter=5) + LOGICAL evap_prec ! evaporation de la pluie + PARAMETER (evap_prec=.TRUE.) + REAL coef_eva + PARAMETER (coef_eva=2.0E-05) + LOGICAL calcrat ! calculer ratqs au lieu de fixer sa valeur + REAL ratqs(klon,klev) ! determine la largeur de distribution de vapeur + PARAMETER (calcrat=.TRUE.) + REAL zx_min, rat_max + PARAMETER (zx_min=1.0, rat_max=0.01) + REAL zx_max, rat_min + PARAMETER (zx_max=0.1, rat_min=0.3) + REAL zx +c + LOGICAL cpartiel ! condensation partielle + PARAMETER (cpartiel=.TRUE.) + REAL t_coup + PARAMETER (t_coup=234.0) +c +c Variables locales: +c + INTEGER i, k, n, kk + REAL zqs(klon), zdqs(klon), zdelta, zcor, zcvm5 + REAL zrfl(klon), zrfln(klon), zqev, zqevt + REAL zoliq(klon), zcond(klon), zq(klon), zqn(klon), zdelq + REAL ztglace, zt(klon) + INTEGER nexpo ! exponentiel pour glace/eau + REAL zdz(klon),zrho(klon),ztot(klon), zrhol(klon) + REAL zchau(klon),zfroi(klon),zfice(klon),zneb(klon) +c + LOGICAL appel1er + SAVE appel1er +c$OMP THREADPRIVATE(appel1er) +c +c--------------------------------------------------------------- +c +cAA Variables traceurs: +cAA Provisoire !!! Parametres alpha du lessivage +cAA A priori on a 4 scavenging # possibles +c + REAL a_tr_sca(4) + save a_tr_sca +c$OMP THREADPRIVATE(a_tr_sca) +c +c Variables intermediaires +c + REAL zalpha_tr + REAL zfrac_lessi + REAL zprec_cond(klon) +cAA +c--------------------------------------------------------------- +c +c Fonctions en ligne: +c + REAL fallv ! vitesse de chute pour crystaux de glace + REAL zzz +#include "YOETHF.h" +#include "FCTTRE.h" + fallv (zzz) = 3.29/2.0 * ((zzz)**0.16) +ccc fallv (zzz) = 3.29/3.0 * ((zzz)**0.16) +ccc fallv (zzz) = 3.29 * ((zzz)**0.16) +c + DATA appel1er /.TRUE./ +c + IF (appel1er) THEN +c + PRINT*, 'fisrtilp, calcrat:', calcrat + PRINT*, 'fisrtilp, ninter:', ninter + PRINT*, 'fisrtilp, evap_prec:', evap_prec + PRINT*, 'fisrtilp, cpartiel:', cpartiel + IF (ABS(dtime/FLOAT(ninter)-360.0).GT.0.001) THEN + PRINT*, 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime + PRINT*, 'Je prefere un sous-intervalle de 6 minutes' + CALL abort + ENDIF + appel1er = .FALSE. +c +cAA initialiation provisoire + a_tr_sca(1) = -0.5 + a_tr_sca(2) = -0.5 + a_tr_sca(3) = -0.5 + a_tr_sca(4) = -0.5 +c +cAA Initialisation a 1 des coefs des fractions lessivees +c + DO k = 1, klev + DO i = 1, klon + pfrac_nucl(i,k)=1. + pfrac_1nucl(i,k)=1. + pfrac_impa(i,k)=1. + ENDDO + ENDDO + + ENDIF ! test sur appel1er +c +cMAf Initialisation a 0 de zoliq + DO i = 1, klon + zoliq(i)=0. + ENDDO +c Determiner les nuages froids par leur temperature +c + ztglace = RTT - 15.0 + nexpo = 6 +ccc nexpo = 1 +c +c Initialiser les sorties: +c + DO k = 1, klev+1 + DO i = 1, klon + prfl(i,k) = 0.0 + psfl(i,k) = 0.0 + ENDDO + ENDDO + + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + d_ql(i,k) = 0.0 + rneb(i,k) = 0.0 + radliq(i,k) = 0.0 + frac_nucl(i,k) = 1. + frac_impa(i,k) = 1. + ENDDO + ENDDO + DO i = 1, klon + rain(i) = 0.0 + snow(i) = 0.0 + ENDDO +c +c Initialiser le flux de precipitation a zero +c + DO i = 1, klon + zrfl(i) = 0.0 + zneb(i) = seuil_neb + ENDDO +c +c +cAA Pour plus de securite + + zalpha_tr = 0. + zfrac_lessi = 0. + +cAA---------------------------------------------------------- +c +c Boucle verticale (du haut vers le bas) +c + DO 9999 k = klev, 1, -1 +c +cAA---------------------------------------------------------- +c + DO i = 1, klon + zt(i)=t(i,k) + zq(i)=q(i,k) + ENDDO +c +c Calculer l'evaporation de la precipitation +c + IF (evap_prec) THEN + DO i = 1, klon + IF (zrfl(i) .GT.0.) THEN + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-zt(i))) + zqs(i)= R2ES*FOEEW(zt(i),zdelta)/pplay(i,k) + zqs(i)=MIN(0.5,zqs(i)) + zcor=1./(1.-RETV*zqs(i)) + zqs(i)=zqs(i)*zcor + ELSE + IF (zt(i) .LT. t_coup) THEN + zqs(i) = qsats(zt(i)) / pplay(i,k) + ELSE + zqs(i) = qsatl(zt(i)) / pplay(i,k) + ENDIF + ENDIF + zqev = MAX (0.0, (zqs(i)-zq(i))*zneb(i) ) + zqevt = coef_eva * (1.0-zq(i)/zqs(i)) * SQRT(zrfl(i)) + . * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG + zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) + . * RG*dtime/(paprs(i,k)-paprs(i,k+1)) + zqev = MIN (zqev, zqevt) + zrfln(i) = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1)) + . /RG/dtime + zq(i) = zq(i) - (zrfln(i)-zrfl(i)) + . * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime + zt(i) = zt(i) + (zrfln(i)-zrfl(i)) + . * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime + . * RLVTT/RCPD/(1.0+RVTMP2*zq(i)) + zrfl(i) = zrfln(i) + ENDIF + ENDDO + ENDIF +c +c Calculer Qs et L/Cp*dQs/dT: +c + IF (thermcep) THEN + DO i = 1, klon + zdelta = MAX(0.,SIGN(1.,RTT-zt(i))) + zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i)) + zqs(i) = R2ES*FOEEW(zt(i),zdelta)/pplay(i,k) + zqs(i) = MIN(0.5,zqs(i)) + zcor = 1./(1.-RETV*zqs(i)) + zqs(i) = zqs(i)*zcor + zdqs(i) = FOEDE(zt(i),zdelta,zcvm5,zqs(i),zcor) + ENDDO + ELSE + DO i = 1, klon + IF (zt(i).LT.t_coup) THEN + zqs(i) = qsats(zt(i))/pplay(i,k) + zdqs(i) = dqsats(zt(i),zqs(i)) + ELSE + zqs(i) = qsatl(zt(i))/pplay(i,k) + zdqs(i) = dqsatl(zt(i),zqs(i)) + ENDIF + ENDDO + ENDIF +c +c Determiner la condensation partielle et calculer la quantite +c de l'eau condensee: +c + IF (cpartiel) THEN + DO i = 1, klon +c + zdelq = ratqs(i,k) * zq(i) + rneb(i,k) = (zq(i)+zdelq-zqs(i)) / (2.0*zdelq) + zqn(i) = (zq(i)+zdelq+zqs(i))/2.0 + IF (rneb(i,k) .LE. 0.0) zqn(i) = 0.0 + IF (rneb(i,k) .GE. 1.0) zqn(i) = zq(i) + rneb(i,k) = MAX(0.0,MIN(1.0,rneb(i,k))) + zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)/(1.+zdqs(i)) + +c--Olivier + RHcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i) + IF (rneb(i,k) .LE. 0.0) RHcl(i,k)=zq(i)/zqs(i) + IF (rneb(i,k) .GE. 1.0) RHcl(i,k)=1.0 +c--fin + + ENDDO + ELSE + DO i = 1, klon + IF (zq(i).GT.zqs(i)) THEN + rneb(i,k) = 1.0 + ELSE + rneb(i,k) = 0.0 + ENDIF + zcond(i) = MAX(0.0,zq(i)-zqs(i))/(1.+zdqs(i)) + ENDDO + ENDIF +c + DO i = 1, klon + zq(i) = zq(i) - zcond(i) + zt(i) = zt(i) + zcond(i) * RLVTT/RCPD + ENDDO +c +c Partager l'eau condensee en precipitation et eau liquide nuageuse +c + DO i = 1, klon + IF (rneb(i,k).GT.0.0) THEN + zoliq(i) = zcond(i) + zrho(i) = pplay(i,k) / zt(i) / RD + zdz(i) = (paprs(i,k)-paprs(i,k+1)) / (zrho(i)*RG) + zfice(i) = 1.0 - (zt(i)-ztglace) / (273.13-ztglace) + zfice(i) = MIN(MAX(zfice(i),0.0),1.0) + zfice(i) = zfice(i)**nexpo + zneb(i) = MAX(rneb(i,k), seuil_neb) + radliq(i,k) = zoliq(i)/FLOAT(ninter+1) + ENDIF + ENDDO +c + DO n = 1, ninter + DO i = 1, klon + IF (rneb(i,k).GT.0.0) THEN + zchau(i) = ct*dtime/FLOAT(ninter) * zoliq(i) + . * (1.0-EXP(-(zoliq(i)/zneb(i)/cl)**2)) *(1.-zfice(i)) + zrhol(i) = zrho(i) * zoliq(i) / zneb(i) + zfroi(i) = dtime/FLOAT(ninter)/zdz(i)*zoliq(i) + . *fallv(zrhol(i)) * zfice(i) + ztot(i) = zchau(i) + zfroi(i) + IF (zneb(i).EQ.seuil_neb) ztot(i) = 0.0 + ztot(i) = MIN(MAX(ztot(i),0.0),zoliq(i)) + zoliq(i) = MAX(zoliq(i)-ztot(i), 0.0) + radliq(i,k) = radliq(i,k) + zoliq(i)/FLOAT(ninter+1) + ENDIF + ENDDO + ENDDO +c + DO i = 1, klon + IF (rneb(i,k).GT.0.0) THEN + d_ql(i,k) = zoliq(i) + zrfl(i) = zrfl(i)+ MAX(zcond(i)-zoliq(i),0.0) + . * (paprs(i,k)-paprs(i,k+1))/(RG*dtime) + ENDIF + IF (zt(i).LT.RTT) THEN + psfl(i,k)=zrfl(i) + ELSE + prfl(i,k)=zrfl(i) + ENDIF + ENDDO +c +c Calculer les tendances de q et de t: +c + DO i = 1, klon + d_q(i,k) = zq(i) - q(i,k) + d_t(i,k) = zt(i) - t(i,k) + ENDDO +c +cAA--------------- Calcul du lessivage stratiforme ------------- + + DO i = 1,klon +c + zprec_cond(i) = MAX(zcond(i)-zoliq(i),0.0) + . * (paprs(i,k)-paprs(i,k+1))/RG + IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN +cAA lessivage nucleation LMD5 dans la couche elle-meme + if (t(i,k) .GE. ztglace) THEN + zalpha_tr = a_tr_sca(3) + else + zalpha_tr = a_tr_sca(4) + endif + zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i)) + pfrac_nucl(i,k)=pfrac_nucl(i,k)*(1.-zneb(i)*zfrac_lessi) + frac_nucl(i,k)= 1.-zneb(i)*zfrac_lessi +c +c nucleation avec un facteur -1 au lieu de -0.5 + zfrac_lessi = 1. - EXP(-zprec_cond(i)/zneb(i)) + pfrac_1nucl(i,k)=pfrac_1nucl(i,k)*(1.-zneb(i)*zfrac_lessi) + ENDIF +c + ENDDO ! boucle sur i +c +cAA Lessivage par impaction dans les couches en-dessous + DO kk = k-1, 1, -1 + DO i = 1, klon + IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN + if (t(i,kk) .GE. ztglace) THEN + zalpha_tr = a_tr_sca(1) + else + zalpha_tr = a_tr_sca(2) + endif + zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i)) + pfrac_impa(i,kk)=pfrac_impa(i,kk)*(1.-zneb(i)*zfrac_lessi) + frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi + ENDIF + ENDDO + ENDDO +c +cAA---------------------------------------------------------- +c FIN DE BOUCLE SUR K + 9999 CONTINUE +c +cAA----------------------------------------------------------- +c +c Pluie ou neige au sol selon la temperature de la 1ere couche +c + DO i = 1, klon + IF ((t(i,1)+d_t(i,1)) .LT. RTT) THEN + snow(i) = zrfl(i) + ELSE + rain(i) = zrfl(i) + ENDIF + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/flxtr.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/flxtr.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/flxtr.F (revision 1280) @@ -0,0 +1,207 @@ +! +! $Header$ +! + SUBROUTINE flxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d, + . pt,pplay,paprs,kcbot,kctop,kdtop,x,dx) + USE dimphy + IMPLICIT NONE +c===================================================================== +c Objet : Melange convectif de traceurs a partir des flux de masse +c Date : 13/12/1996 -- 13/01/97 +c Auteur: O. Boucher (LOA) sur inspiration de Z. X. Li (LMD), +c Brinkop et Sausen (1996) et Boucher et al. (1996). +c ATTENTION : meme si cette routine se veut la plus generale possible, +c elle a herite de certaines notations et conventions du +c schema de Tiedtke (1993). +c --En particulier, les couches sont numerotees de haut en bas !!! +c Ceci est valable pour les flux, kcbot, kctop et kdtop +c mais pas pour les entrees x, pplay, paprs !!!! +c --Un schema amont est choisi pour calculer les flux pour s'assurer +c de la positivite des valeurs de traceurs, cela implique des eqs +c differentes pour les flux de traceurs montants et descendants. +c --pmfu est positif, pmfd est negatif +c --Tous les flux d'entrainements et de detrainements sont positifs +c contrairement au schema de Tiedtke d'ou les changements de signe!!!! +c===================================================================== +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOECUMF.h" +c + REAL pdtime +c--les flux sont definis au 1/2 niveaux +c--pmfu(klev+1) et pmfd(klev+1) sont implicitement nuls + REAL pmfu(klon,klev) ! flux de masse dans le panache montant + REAL pmfd(klon,klev) ! flux de masse dans le panache descendant + REAL pen_u(klon,klev) ! flux entraine dans le panache montant + REAL pde_u(klon,klev) ! flux detraine dans le panache montant + REAL pen_d(klon,klev) ! flux entraine dans le panache descendant + REAL pde_d(klon,klev) ! flux detraine dans le panache descendant +c--idem mais en variables locales + REAL zpen_u(klon,klev) + REAL zpde_u(klon,klev) + REAL zpen_d(klon,klev) + REAL zpde_d(klon,klev) +c + REAL pplay(klon,klev) ! pression aux couches (bas en haut) + REAL pap(klon,klev) ! pression aux couches (haut en bas) + REAL pt(klon,klev) ! temperature aux couches (bas en haut) + REAL zt(klon,klev) ! temperature aux couches (haut en bas) + REAL paprs(klon,klev+1) ! pression aux 1/2 couches (bas en haut) + REAL paph(klon,klev+1) ! pression aux 1/2 couches (haut en bas) + INTEGER kcbot(klon) ! niveau de base de la convection + INTEGER kctop(klon) ! niveau du sommet de la convection +1 + INTEGER kdtop(klon) ! niveau de sommet du panache descendant + REAL x(klon,klev) ! q de traceur (bas en haut) + REAL zx(klon,klev) ! q de traceur (haut en bas) + REAL dx(klon,klev) ! tendance de traceur (bas en haut) +c +c--variables locales +c--les flux de x sont definis aux 1/2 niveaux +c--xu et xd sont definis aux niveaux complets + REAL xu(klon,klev) ! q de traceurs dans le panache montant + REAL xd(klon,klev) ! q de traceurs dans le panache descendant + REAL xe(klon,klev) ! q de traceurs dans l'environnement + REAL zmfux(klon,klev+1) ! flux de x dans le panache montant + REAL zmfdx(klon,klev+1) ! flux de x dans le panache descendant + REAL zmfex(klon,klev+1) ! flux de x dans l'environnement + INTEGER i, k + REAL zmfmin + PARAMETER (zmfmin=1.E-10) +c +c On remet les taux d'entrainement et de detrainement dans le panache +c descendant a des valeurs positives. +c On ajuste les valeurs de pen_u, pen_d pde_u et pde_d pour que la +c conservation de la masse soit realisee a chaque niveau dans les 2 +c panaches. + DO k=1, klev + DO i=1, klon + zpen_u(i,k)= pen_u(i,k) + zpde_u(i,k)= pde_u(i,k) + ENDDO + ENDDO +c + DO k=1, klev-1 + DO i=1, klon + zpen_d(i,k)=-pen_d(i,k+1) + zpde_d(i,k)=-pde_d(i,k+1) + ENDDO + ENDDO +c + DO i=1, klon + zpen_d(i,klev) = 0.0 + zpde_d(i,klev) = -pmfd(i,klev) +c Correction 03 11 97 +c zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)-pmfd(i,kdtop(i)) + IF (kdtop(i).EQ.klev+1) THEN + zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1) + ELSE + zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)-pmfd(i,kdtop(i)) + ENDIF + + zpde_u(i,kctop(i)-2) = pmfu(i,kctop(i)-1) + zpen_u(i,klev) = pmfu(i,klev) + ENDDO +c + DO i=1, klon + DO k=kcbot(i), klev-1 + zpen_u(i,k) = pmfu(i,k) - pmfu(i,k+1) + ENDDO + ENDDO +c +c conversion des sens de notations bas-haut et haut-bas +c + DO k=1, klev+1 + DO i=1, klon + paph(i,klev+2-k)=paprs(i,k) + ENDDO + ENDDO +c + DO i=1, klon + DO k=1, klev + pap(i,klev+1-k)=pplay(i,k) + zt(i,klev+1-k) =pt(i,k) + zx(i,klev+1-k) =x(i,k) + ENDDO + ENDDO +c +c--initialisations des flux de traceurs aux extremites de la colonne +c + DO i=1, klon + zmfux(i,klev+1) = 0.0 + zmfdx(i,1) = 0.0 + zmfex(i,1) = 0.0 + ENDDO +c +c--calcul des flux dans le panache montant +c + DO k=klev, 1, -1 + DO i=1, klon + IF (k.GE.kcbot(i)) THEN + xu(i,k)=zx(i,k) + zmfux(i,k)=pmfu(i,k)*xu(i,k) + ELSE + zmfux(i,k)= (zmfux(i,k+1) + zpen_u(i,k)*zx(i,k) ) / + . (1.+zpde_u(i,k)/MAX(zmfmin,pmfu(i,k))) + xu(i,k)=zmfux(i,k)/MAX(zmfmin,pmfu(i,k)) + ENDIF + ENDDO + ENDDO +c +c--calcul des flux dans le panache descendant +c + DO k=1, klev-1 + DO i=1, klon + IF (k.LE.kdtop(i)-1) THEN + xd(i,k)=( zx(i,k)+xu(i,k) ) / 2. + zmfdx(i,k+1)=pmfd(i,k+1)*xd(i,k) + ELSE + zmfdx(i,k+1)= (zmfdx(i,k) - zpen_d(i,k)*zx(i,k) ) / + . (1.-zpde_d(i,k)/MIN(-zmfmin,pmfd(i,k+1))) + xd(i,k)=zmfdx(i,k+1)/MIN(-zmfmin,pmfd(i,k+1)) + ENDIF + ENDDO + ENDDO + DO i=1, klon + zmfdx(i,klev+1) = 0.0 + xd(i,klev) = (zpen_d(i,klev)*zx(i,klev) - zmfdx(i,klev)) / + . MAX(zmfmin,zpde_d(i,klev)) + ENDDO +c +c--introduction du flux de retour dans l'environnement +c + DO k=1, klev-1 + DO i=1, klon + IF (k.LE.kctop(i)-3) THEN + xe(i,k)= zx(i,k) + zmfex(i,k+1)=-(pmfu(i,k+1)+pmfd(i,k+1))*xe(i,k) + ELSE + zmfex(i,k+1)= (zmfex(i,k) - + . (zpde_u(i,k)*xu(i,k)+zpde_d(i,k)*xd(i,k))) / + . (1.-(zpen_d(i,k)+zpen_u(i,k))/ + . MIN(-zmfmin,-pmfu(i,k+1)-pmfd(i,k+1)) ) + xe(i,k)=zmfex(i,k+1)/MIN(-zmfmin,-pmfu(i,k+1)-pmfd(i,k+1)) + ENDIF + ENDDO + ENDDO + DO i=1, klon + zmfex(i,klev+1) = 0.0 + xe(i,klev) = (zpde_u(i,klev)*xu(i,klev) + + . zpde_d(i,klev)*xd(i,klev) -zmfex(i,klev)) / + . MAX(zmfmin,zpen_u(i,klev)+zpen_d(i,klev)) + ENDDO +c +c--calcul final des tendances +c + DO k=1 , klev + DO i=1, klon + dx(i,klev+1-k) = RG/(paph(i,k+1)-paph(i,k))*pdtime* + . ( zmfux(i,k+1) - zmfux(i,k) + + . zmfdx(i,k+1) - zmfdx(i,k) + + . zmfex(i,k+1) - zmfex(i,k) ) + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/fonte_neige_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/fonte_neige_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/fonte_neige_mod.F90 (revision 1280) @@ -0,0 +1,343 @@ +! +! $Header$ +! +MODULE fonte_neige_mod +! +! This module will treat the process of snow, melting, accumulating, calving, in +! case of simplified soil model. +! +!**************************************************************************************** + USE dimphy, ONLY : klon + + IMPLICIT NONE + SAVE + +! run_off_ter and run_off_lic are the runoff at the compressed grid knon for +! land and land-ice respectively +! Note: run_off_lic is used in mod_landice and therfore not private + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE :: run_off_ter + !$OMP THREADPRIVATE(run_off_ter) + REAL, ALLOCATABLE, DIMENSION(:) :: run_off_lic + !$OMP THREADPRIVATE(run_off_lic) + +! run_off_lic_0 is the runoff at land-ice a time-step earlier, on the global 1D array grid + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE :: run_off_lic_0 + !$OMP THREADPRIVATE(run_off_lic_0) + + REAL, PRIVATE :: tau_calv + !$OMP THREADPRIVATE(tau_calv) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE :: ffonte_global + !$OMP THREADPRIVATE(ffonte_global) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE :: fqfonte_global + !$OMP THREADPRIVATE(fqfonte_global) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE :: fqcalving_global + !$OMP THREADPRIVATE(fqcalving_global) + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE fonte_neige_init(restart_runoff) + +! This subroutine allocates and initialize variables in the module. +! The variable run_off_lic_0 is initialized to the field read from +! restart file. The other variables are initialized to zero. +! + INCLUDE "indicesol.h" +!**************************************************************************************** +! Input argument + REAL, DIMENSION(klon), INTENT(IN) :: restart_runoff + +! Local variables + INTEGER :: error + CHARACTER (len = 80) :: abort_message + CHARACTER (len = 20) :: modname = 'fonte_neige_init' + + +!**************************************************************************************** +! Allocate run-off at landice and initilize with field read from restart +! +!**************************************************************************************** + + ALLOCATE(run_off_lic_0(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation run_off_lic' + CALL abort_gcm(modname,abort_message,1) + ENDIF + run_off_lic_0(:) = restart_runoff(:) + +!**************************************************************************************** +! Allocate other variables and initilize to zero +! +!**************************************************************************************** + ALLOCATE(run_off_ter(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation run_off_ter' + CALL abort_gcm(modname,abort_message,1) + ENDIF + run_off_ter(:) = 0. + + ALLOCATE(run_off_lic(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation run_off_lic' + CALL abort_gcm(modname,abort_message,1) + ENDIF + run_off_lic(:) = 0. + + ALLOCATE(ffonte_global(klon,nbsrf)) + IF (error /= 0) THEN + abort_message='Pb allocation ffonte_global' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ffonte_global(:,:) = 0.0 + + ALLOCATE(fqfonte_global(klon,nbsrf)) + IF (error /= 0) THEN + abort_message='Pb allocation fqfonte_global' + CALL abort_gcm(modname,abort_message,1) + ENDIF + fqfonte_global(:,:) = 0.0 + + ALLOCATE(fqcalving_global(klon,nbsrf)) + IF (error /= 0) THEN + abort_message='Pb allocation fqcalving_global' + CALL abort_gcm(modname,abort_message,1) + ENDIF + fqcalving_global(:,:) = 0.0 + +!**************************************************************************************** +! Read tau_calv +! +!**************************************************************************************** + CALL conf_interface(tau_calv) + + + END SUBROUTINE fonte_neige_init +! +!**************************************************************************************** +! + SUBROUTINE fonte_neige( knon, nisurf, knindex, dtime, & + tsurf, precip_rain, precip_snow, & + snow, qsol, tsurf_new, evap) + +! Routine de traitement de la fonte de la neige dans le cas du traitement +! de sol simplifie! +! LF 03/2001 +! input: +! knon nombre de points a traiter +! nisurf surface a traiter +! knindex index des mailles valables pour surface a traiter +! dtime +! tsurf temperature de surface +! precip_rain precipitations liquides +! precip_snow precipitations solides +! +! input/output: +! snow champs hauteur de neige +! qsol hauteur d'eau contenu dans le sol +! tsurf_new temperature au sol +! evap +! + INCLUDE "indicesol.h" + INCLUDE "dimensions.h" + INCLUDE "YOETHF.h" + INCLUDE "YOMCST.h" + INCLUDE "FCTTRE.h" + INCLUDE "clesphys.h" + +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + INTEGER, INTENT(IN) :: nisurf + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL , INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: tsurf + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain + REAL, DIMENSION(klon), INTENT(IN) :: precip_snow + +! Input/Output variables +!**************************************************************************************** + + REAL, DIMENSION(klon), INTENT(INOUT) :: snow + REAL, DIMENSION(klon), INTENT(INOUT) :: qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(INOUT) :: evap + +! Local variables +!**************************************************************************************** + + INTEGER :: i, j + REAL :: fq_fonte + REAL :: coeff_rel + REAL, PARAMETER :: snow_max=3000. + REAL, PARAMETER :: max_eau_sol = 150.0 +!! PB temporaire en attendant mieux pour le modele de neige +! REAL, parameter :: chasno = RLMLT/(2.3867E+06*0.15) + REAL, PARAMETER :: chasno = 3.334E+05/(2.3867E+06*0.15) +!IM cf JLD/ GKtest + REAL, PARAMETER :: chaice = 3.334E+05/(2.3867E+06*0.15) +! fin GKtest + REAL, DIMENSION(klon) :: ffonte + REAL, DIMENSION(klon) :: fqcalving, fqfonte + REAL, DIMENSION(klon) :: d_ts + REAL, DIMENSION(klon) :: bil_eau_s, snow_evap + + LOGICAL :: neige_fond + +!**************************************************************************************** +! Start calculation +! - Initialization +! +!**************************************************************************************** + coeff_rel = dtime/(tau_calv * rday) + + bil_eau_s(:) = 0. + +!**************************************************************************************** +! - Increment snow due to precipitation and evaporation +! - Calculate the water balance due to precipitation and evaporation (bil_eau_s) +! +!**************************************************************************************** + WHERE (precip_snow > 0.) + snow = snow + (precip_snow * dtime) + END WHERE + + snow_evap = 0. + WHERE (evap > 0. ) + snow_evap = MIN (snow / dtime, evap) + snow = snow - snow_evap * dtime + snow = MAX(0.0, snow) + END WHERE + + bil_eau_s(:) = (precip_rain(:) * dtime) - (evap(:) - snow_evap(:)) * dtime + + +!**************************************************************************************** +! - Calculate melting snow +! - Calculate calving and decrement snow, if there are to much snow +! - Update temperature at surface +! +!**************************************************************************************** + + ffonte(:) = 0.0 + fqcalving(:) = 0.0 + fqfonte(:) = 0.0 + DO i = 1, knon + ! Y'a-t-il fonte de neige? + neige_fond = ((snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) & + .AND. tsurf_new(i) >= RTT) + IF (neige_fond) THEN + fq_fonte = MIN( MAX((tsurf_new(i)-RTT )/chasno,0.0),snow(i)) + ffonte(i) = fq_fonte * RLMLT/dtime + fqfonte(i) = fq_fonte/dtime + snow(i) = MAX(0., snow(i) - fq_fonte) + bil_eau_s(i) = bil_eau_s(i) + fq_fonte + tsurf_new(i) = tsurf_new(i) - fq_fonte * chasno + +!IM cf JLD OK +!IM cf JLD/ GKtest fonte aussi pour la glace + IF (nisurf == is_sic .OR. nisurf == is_lic ) THEN + fq_fonte = MAX((tsurf_new(i)-RTT )/chaice,0.0) + ffonte(i) = ffonte(i) + fq_fonte * RLMLT/dtime + IF ( ok_lic_melt ) THEN + fqfonte(i) = fqfonte(i) + fq_fonte/dtime + bil_eau_s(i) = bil_eau_s(i) + fq_fonte + ENDIF + tsurf_new(i) = RTT + ENDIF + d_ts(i) = tsurf_new(i) - tsurf(i) + ENDIF + + ! s'il y a une hauteur trop importante de neige, elle s'coule + fqcalving(i) = MAX(0., snow(i) - snow_max)/dtime + snow(i)=MIN(snow(i),snow_max) + END DO + + + IF (nisurf == is_ter) THEN + DO i = 1, knon + qsol(i) = qsol(i) + bil_eau_s(i) + run_off_ter(i) = run_off_ter(i) + MAX(qsol(i) - max_eau_sol, 0.0) + qsol(i) = MIN(qsol(i), max_eau_sol) + END DO + ELSE IF (nisurf == is_lic) THEN + DO i = 1, knon + j = knindex(i) + run_off_lic(i) = (coeff_rel * fqcalving(i)) + & + (1. - coeff_rel) * run_off_lic_0(j) + run_off_lic_0(j) = run_off_lic(i) + run_off_lic(i) = run_off_lic(i) + fqfonte(i)/dtime + END DO + ENDIF + +!**************************************************************************************** +! Save ffonte, fqfonte and fqcalving in global arrays for each +! sub-surface separately +! +!**************************************************************************************** + DO i = 1, knon + ffonte_global(knindex(i),nisurf) = ffonte(i) + fqfonte_global(knindex(i),nisurf) = fqfonte(i) + fqcalving_global(knindex(i),nisurf) = fqcalving(i) + ENDDO + + END SUBROUTINE fonte_neige +! +!**************************************************************************************** +! + SUBROUTINE fonte_neige_final(restart_runoff) +! +! This subroutine returns run_off_lic_0 for later writing to restart file. +! +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: restart_runoff + +!**************************************************************************************** +! Set the output variables + restart_runoff(:) = run_off_lic_0(:) + +! Deallocation of all varaibles in the module + DEALLOCATE(run_off_lic_0, run_off_ter, run_off_lic, ffonte_global, & + fqfonte_global, fqcalving_global) + + END SUBROUTINE fonte_neige_final +! +!**************************************************************************************** +! + SUBROUTINE fonte_neige_get_vars(pctsrf, fqcalving_out, & + fqfonte_out, ffonte_out) + +! Cumulate ffonte, fqfonte and fqcalving respectively for +! all type of surfaces according to their fraction. +! +! This routine is called from physiq.F before histwrite. + + INCLUDE "indicesol.h" +!**************************************************************************************** + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + + REAL, DIMENSION(klon), INTENT(OUT) :: fqcalving_out + REAL, DIMENSION(klon), INTENT(OUT) :: fqfonte_out + REAL, DIMENSION(klon), INTENT(OUT) :: ffonte_out + + INTEGER :: nisurf +!**************************************************************************************** + + ffonte_out(:) = 0.0 + fqfonte_out(:) = 0.0 + fqcalving_out(:) = 0.0 + + DO nisurf = 1, nbsrf + ffonte_out(:) = ffonte_out(:) + ffonte_global(:,nisurf)*pctsrf(:,nisurf) + fqfonte_out(:) = fqfonte_out(:) + fqfonte_global(:,nisurf)*pctsrf(:,nisurf) + fqcalving_out(:) = fqcalving_out(:) + fqcalving_global(:,nisurf)*pctsrf(:,nisurf) + ENDDO + + END SUBROUTINE fonte_neige_get_vars +! +!**************************************************************************************** +! +END MODULE fonte_neige_mod + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/geo2atm.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/geo2atm.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/geo2atm.F90 (revision 1280) @@ -0,0 +1,53 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/geo2atm.F90,v 1.1 2008-12-05 17:56:40 lsce Exp $ +! +SUBROUTINE geo2atm(im, jm, px, py, pz, plon, plat, pu, pv, pr) + USE dimphy + USE mod_phys_lmdz_para + + IMPLICIT NONE + INCLUDE 'dimensions.h' + INCLUDE 'YOMCST.h' + +! Change wind coordinates from cartesian geocentric to local spherical +! NB! Fonctionne probablement uniquement en MPI seul (sans OpenMP) +! + INTEGER, INTENT (IN) :: im, jm + REAL, DIMENSION (im,jm), INTENT(IN) :: px, py, pz + REAL, DIMENSION (im,jm), INTENT(IN) :: plon, plat + REAL, DIMENSION (im,jm), INTENT(OUT) :: pu, pv, pr + + REAL :: rad + + + rad = rpi / 180.0E0 + + pu(:,:) = & + - px(:,:) * SIN(rad * plon(:,:)) & + + py(:,:) * COS(rad * plon(:,:)) + + pv(:,:) = & + - px(:,:) * SIN(rad * plat(:,:)) * COS(rad * plon(:,:)) & + - py(:,:) * SIN(rad * plat(:,:)) * SIN(rad * plon(:,:)) & + + pz(:,:) * COS(rad * plat(:,:)) + + pr(:,:) = & + + px(:,:) * COS(rad * plat(:,:)) * COS(rad * plon(:,:)) & + + py(:,:) * COS(rad * plat(:,:)) * SIN(rad * plon(:,:)) & + + pz(:,:) * SIN(rad * plat(:,:)) + + ! Value at North Pole + IF (is_north_pole) THEN + pu(:, 1) = pu(1, 1) + pv(:, 1) = pv(1, 1) + pr(:, 1) = pr(1, 1) + ENDIF + + ! Value at South Pole + IF (is_south_pole) THEN + pu(:,jm) = pu(1,jm) + pv(:,jm) = pv(1,jm) + pr(:,jm) = pr(1,jm) + ENDIF + +END SUBROUTINE geo2atm Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/haut2bas.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/haut2bas.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/haut2bas.F (revision 1280) @@ -0,0 +1,19 @@ +! +! $Header$ +! + SUBROUTINE haut2bas(klon, klev, varB2H, varH2B) + IMPLICIT NONE +c + INTEGER klon, klev + REAL varB2H(klon, klev), varH2B(klon, klev) + INTEGER i, k, kinv +c + DO k=1,klev + kinv=klev-k+1 + DO i=1,klon + varH2B(i,k)=varB2H(i,kinv) + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/hbtm.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/hbtm.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/hbtm.F (revision 1280) @@ -0,0 +1,777 @@ +! +! $Header$ +! + + SUBROUTINE HBTM(knon, paprs, pplay, + . t2m,t10m,q2m,q10m,ustar, + . flux_t,flux_q,u,v,t,q, + . pblh,cape,EauLiq,ctei,pblT, + . therm,trmb1,trmb2,trmb3,plcl) + USE dimphy + IMPLICIT none + +c*************************************************************** +c* * +c* HBTM2 D'apres Holstag&Boville et Troen&Mahrt * +c* JAS 47 BLM * +c* Algorithme These Anne Mathieu * +c* Critere d'Entrainement Peter Duynkerke (JAS 50) * +c* written by : Anne MATHIEU & Alain LAHELLEC, 22/11/99 * +c* features : implem. exces Mathieu * +c*************************************************************** +c* mods : decembre 99 passage th a niveau plus bas. voir fixer * +c* la prise du th a z/Lambda = -.2 (max Ray) * +c* Autre algo : entrainement ~ Theta+v =cste mais comment=>The?* +c* on peut fixer q a .7qsat(cf non adiab)=>T2 et The2 * +c* voir aussi //KE pblh = niveau The_e ou l = env. * +c*************************************************************** +c* fin therm a la HBTM passage a forme Mathieu 12/09/2001 * +c*************************************************************** +c* +c +c +cAM Fev 2003 +c Adaptation a LMDZ version couplee +c +c Pour le moment on fait passer en argument les grdeurs de surface : +c flux, t,q2m, t,q10m, on va utiliser systematiquement les grdeurs a 2m ms +c on garde la possibilite de changer si besoin est (jusqu'a present la +c forme de HB avec le 1er niveau modele etait conservee) +c +c +c +c +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" + REAL RLvCp, REPS +c Arguments: +c + INTEGER knon ! nombre de points a calculer +cAM + REAL t2m(klon), t10m(klon) ! temperature a 2 et 10m + REAL q2m(klon), q10m(klon) ! q a 2 et 10m + REAL ustar(klon) + REAL paprs(klon,klev+1) ! pression a inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) + REAL flux_t(klon,klev), flux_q(klon,klev) ! Flux + REAL u(klon,klev) ! vitesse U (m/s) + REAL v(klon,klev) ! vitesse V (m/s) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! vapeur d'eau (kg/kg) +cAM REAL cd_h(klon) ! coefficient de friction au sol pour chaleur +cAM REAL cd_m(klon) ! coefficient de friction au sol pour vitesse +c + INTEGER isommet +cum PARAMETER (isommet=klev) ! limite max sommet pbl + REAL vk + PARAMETER (vk=0.35) ! Von Karman => passer a .41 ! cf U.Olgstrom + REAL ricr + PARAMETER (ricr=0.4) + REAL fak + PARAMETER (fak=8.5) ! b calcul du Prandtl et de dTetas + REAL fakn + PARAMETER (fakn=7.2) ! a + REAL onet + PARAMETER (onet=1.0/3.0) + REAL t_coup + PARAMETER(t_coup=273.15) + REAL zkmin + PARAMETER (zkmin=0.01) + REAL betam + PARAMETER (betam=15.0) ! pour Phim / h dans la S.L stable + REAL betah + PARAMETER (betah=15.0) + REAL betas + PARAMETER (betas=5.0) ! Phit dans la S.L. stable (mais 2 formes / z/OBL<>1 + REAL sffrac + PARAMETER (sffrac=0.1) ! S.L. = z/h < .1 + REAL binm + PARAMETER (binm=betam*sffrac) + REAL binh + PARAMETER (binh=betah*sffrac) + REAL ccon + PARAMETER (ccon=fak*sffrac*vk) +c + REAL q_star,t_star + REAL b1,b2,b212,b2sr ! Lambert correlations T' q' avec T* q* + PARAMETER (b1=70.,b2=20.) +c + REAL z(klon,klev) +cAM REAL pcfm(klon,klev), pcfh(klon,klev) +cAM + REAL zref + PARAMETER (zref=2.) ! Niveau de ref a 2m peut eventuellement +c etre choisi a 10m +cMA +c + INTEGER i, k, j + REAL zxt +cAM REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy +cAM REAL zx_alf1, zx_alf2 ! parametres pour extrapolation + REAL khfs(klon) ! surface kinematic heat flux [mK/s] + REAL kqfs(klon) ! sfc kinematic constituent flux [m/s] + REAL heatv(klon) ! surface virtual heat flux + REAL rhino(klon,klev) ! bulk Richardon no. mais en Theta_v + LOGICAL unstbl(klon) ! pts w/unstbl pbl (positive virtual ht flx) + LOGICAL stblev(klon) ! stable pbl with levels within pbl + LOGICAL unslev(klon) ! unstbl pbl with levels within pbl + LOGICAL unssrf(klon) ! unstb pbl w/lvls within srf pbl lyr + LOGICAL unsout(klon) ! unstb pbl w/lvls in outer pbl lyr + LOGICAL check(klon) ! True=>chk if Richardson no.>critcal + LOGICAL omegafl(klon) ! flag de prolongerment cape pour pt Omega + REAL pblh(klon) + REAL pblT(klon) + REAL plcl(klon) +cAM REAL cgh(klon,2:klev) ! counter-gradient term for heat [K/m] +cAM REAL cgq(klon,2:klev) ! counter-gradient term for constituents +cAM REAL cgs(klon,2:klev) ! counter-gradient star (cg/flux) + REAL obklen(klon) ! Monin-Obukhov lengh +cAM REAL ztvd, ztvu, + REAL zdu2 + REAL therm(klon) ! thermal virtual temperature excess + REAL trmb1(klon),trmb2(klon),trmb3(klon) +C Algorithme thermique + REAL s(klon,klev) ! [P/Po]^Kappa milieux couches + REAL Th_th(klon) ! potential temperature of thermal + REAL The_th(klon) ! equivalent potential temperature of thermal + REAL qT_th(klon) ! total water of thermal + REAL Tbef(klon) ! T thermique niveau precedent + REAL qsatbef(klon) + LOGICAL Zsat(klon) ! le thermique est sature + REAL Cape(klon) ! Cape du thermique + REAL Kape(klon) ! Cape locale + REAL EauLiq(klon) ! Eau liqu integr du thermique + REAL ctei(klon) ! Critere d'instab d'entrainmt des nuages de CL + REAL the1,the2,aa,bb,zthvd,zthvu,xintpos,qqsat +cIM 091204 BEG + REAL a1,a2,a3 +cIM 091204 END + REAL xhis,rnum,denom,th1,th2,thv1,thv2,ql2 + REAL dqsat_dt,qsat2,qT1,q2,t1,t2,xnull,delt_the + REAL delt_qt,delt_2,quadsat,spblh,reduc +c + REAL phiminv(klon) ! inverse phi function for momentum + REAL phihinv(klon) ! inverse phi function for heat + REAL wm(klon) ! turbulent velocity scale for momentum + REAL fak1(klon) ! k*ustar*pblh + REAL fak2(klon) ! k*wm*pblh + REAL fak3(klon) ! fakn*wstr/wm + REAL pblk(klon) ! level eddy diffusivity for momentum + REAL pr(klon) ! Prandtl number for eddy diffusivities + REAL zl(klon) ! zmzp / Obukhov length + REAL zh(klon) ! zmzp / pblh + REAL zzh(klon) ! (1-(zmzp/pblh))**2 + REAL wstr(klon) ! w*, convective velocity scale + REAL zm(klon) ! current level height + REAL zp(klon) ! current level height + one level up + REAL zcor, zdelta, zcvm5 +cAM REAL zxqs + REAL fac, pblmin, zmzp, term +c +#include "YOETHF.h" +#include "FCTTRE.h" + + + +! initialisations (Anne) + isommet=klev + th_th(:) = 0. + q_star = 0 + t_star = 0 + + + b212=sqrt(b1*b2) + b2sr=sqrt(b2) +c +C ============================================================ +C Fonctions thermo implicites +C ============================================================ +c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c Tetens : pression partielle de vap d'eau e_sat(T) +c ================================================= +C++ e_sat(T) = r2*exp( r3*(T-Tf)/(T-r4) ) id a r2*FOEWE +C++ avec : +C++ Tf = 273.16 K (Temp de fusion de la glace) +C++ r2 = 611.14 Pa +C++ r3 = 17.269 (liquide) 21.875 (solide) adim +C++ r4 = 35.86 7.66 Kelvin +C++ q_sat = eps*e_sat/(p-(1-eps)*e_sat) +C++ deriv� : +C++ ========= +C++ r3*(Tf-r4)*q_sat(T,p) +C++ d_qsat_dT = -------------------------------- +C++ (T-r4)^2*( 1-(1-eps)*e_sat(T)/p ) +c++ pour zcvm5=Lv, c'est FOEDE +c++ Rq :(1.-REPS)*esarg/Parg id a RETV*Qsat +C ------------------------------------------------------------------ +c +c Initialisation + RLvCp = RLVTT/RCPD + REPS = RD/RV + +c +c DO i = 1, klon +c pcfh(i,1) = cd_h(i) +c pcfm(i,1) = cd_m(i) +c ENDDO +c DO k = 2, klev +c DO i = 1, klon +c pcfh(i,k) = zkmin +c pcfm(i,k) = zkmin +c cgs(i,k) = 0.0 +c cgh(i,k) = 0.0 +c cgq(i,k) = 0.0 +c ENDDO +c ENDDO +c +c Calculer les hauteurs de chaque couche +c (geopotentielle Int_dp/ro = Int_[Rd.T.dp/p] z = geop/g) +c pourquoi ne pas utiliser Phi/RG ? + DO i = 1, knon + z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) + . * (paprs(i,1)-pplay(i,1)) / RG + s(i,1) = (pplay(i,1)/paprs(i,1))**RKappa + ENDDO +c s(k) = [pplay(k)/ps]^kappa +c + + + + + + + + + pplay <-> s(k) t dp=pplay(k-1)-pplay(k) +c +c ----------------- paprs <-> sig(k) +c +c + + + + + + + + + pplay <-> s(k-1) +c +c +c + + + + + + + + + pplay <-> s(1) t dp=paprs-pplay z(1) +c +c ----------------- paprs <-> sig(1) +c + DO k = 2, klev + DO i = 1, knon + z(i,k) = z(i,k-1) + . + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) + . * (pplay(i,k-1)-pplay(i,k)) / RG + s(i,k) = (pplay(i,k)/paprs(i,1))**RKappa + ENDDO + ENDDO +c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c +++ Determination des grandeurs de surface +++++++++++++++++++++ +c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + DO i = 1, knon +cAM IF (thermcep) THEN +cAM zdelta=MAX(0.,SIGN(1.,RTT-tsol(i))) +c zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta +c zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1)) +cAM zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1) +cAM zxqs=MIN(0.5,zxqs) +cAM zcor=1./(1.-retv*zxqs) +cAM zxqs=zxqs*zcor +cAM ELSE +cAM IF (tsol(i).LT.t_coup) THEN +cAM zxqs = qsats(tsol(i)) / paprs(i,1) +cAM ELSE +cAM zxqs = qsatl(tsol(i)) / paprs(i,1) +cAM ENDIF +cAM ENDIF +c niveau de reference bulk; mais ici, c,a pourrait etre le niveau de ref du thermique +cAM zx_alf1 = 1.0 +cAM zx_alf2 = 1.0 - zx_alf1 +cAM zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1))) +cAM . *(1.+RETV*q(i,1))*zx_alf1 +cAM . + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2))) +cAM . *(1.+RETV*q(i,2))*zx_alf2 +cAM zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2 +cAM zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2 +cAM zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2 +cAM +cAMAM zxu = u10m(i) +cAMAM zxv = v10m(i) +cAMAM zxmod = 1.0+SQRT(zxu**2+zxv**2) +cAM Niveau de ref choisi a 2m + zxt = t2m(i) + +c *************************************************** +c attention, il doit s'agir de +c ;Calcul de tcls virtuel et de w'theta'virtuel +c ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +c tcls=tcls*(1+.608*qcls) +c +c ;Pour avoir w'theta', +c ; il faut diviser par ro.Cp +c Cp=Cpd*(1+0.84*qcls) +c fcs=fcs/(ro_surf*Cp) +c ;On transforme w'theta' en w'thetav' +c Lv=(2.501-0.00237*(tcls-273.15))*1.E6 +c xle=xle/(ro_surf*Lv) +c fcsv=fcs+.608*xle*tcls +c *************************************************** +cAM khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i) +cAM kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i) +cAM +cdif khfs est deja w't'_v / heatv(i) = khfs(i) + RETV*zxt*kqfs(i) +cAM calcule de Ro = paprs(i,1)/Rd zxt +cAM convention >0 vers le bas ds lmdz + khfs(i) = - flux_t(i,1)*zxt*Rd / (RCPD*paprs(i,1)) + kqfs(i) = - flux_q(i,1)*zxt*Rd / (paprs(i,1)) +cAM verifier que khfs et kqfs sont bien de la forme w'l' + heatv(i) = khfs(i) + 0.608*zxt*kqfs(i) +c a comparer aussi aux sorties de clqh : flux_T/RoCp et flux_q/RoLv +cAM heatv(i) = khfs(i) +cAM ustar est en entree +cAM taux = zxu *zxmod*cd_m(i) +cAM tauy = zxv *zxmod*cd_m(i) +cAM ustar(i) = SQRT(taux**2+tauy**2) +cAM ustar(i) = MAX(SQRT(ustar(i)),0.01) +c Theta et qT du thermique sans exces (interpolin vers surf) +c chgt de niveau du thermique (jeudi 30/12/1999) +c (interpolation lineaire avant integration phi_h) +cAM qT_th(i) = zxqs*beta(i) + 4./z(i,1)*(q(i,1)-zxqs*beta(i)) +cAM qT_th(i) = max(qT_th(i),q(i,1)) + qT_th(i) = q2m(i) +cn The_th restera la Theta du thermique sans exces jusqu'a 2eme calcul +cn reste a regler convention P) pour Theta +c The_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i)) +c - + RLvCp*qT_th(i) +cAM Th_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i)) + Th_th(i) = t2m(i) + ENDDO +c + DO i = 1, knon + rhino(i,1) = 0.0 ! Global Richardson + check(i) = .TRUE. + pblh(i) = z(i,1) ! on initialise pblh a l'altitude du 1er niveau + plcl(i) = 6000. +c Lambda = -u*^3 / (alpha.g.kvon. + obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i)) + trmb1(i) = 0. + trmb2(i) = 0. + trmb3(i) = 0. + ENDDO + +C +c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C PBL height calculation: +C Search for level of pbl. Scan upward until the Richardson number between +C the first level and the current level exceeds the "critical" value. +C (bonne idee Nu de separer le Ric et l'exces de temp du thermique) +c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + fac = 100.0 + DO k = 2, isommet + DO i = 1, knon + IF (check(i)) THEN +! pourquoi / niveau 1 (au lieu du sol) et le terme en u*^2 ? +ctest zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2 + zdu2 = u(i,k)**2+v(i,k)**2 + zdu2 = max(zdu2,1.0e-20) +c Theta_v environnement + zthvd=t(i,k)/s(i,k)*(1.+RETV*q(i,k)) +c +c therm Theta_v sans exces (avec hypothese fausse de H&B, sinon, +c passer par Theta_e et virpot) +c zthvu=t(i,1)/s(i,1)*(1.+RETV*q(i,1)) +cAM zthvu = Th_th(i)*(1.+RETV*q(i,1)) + zthvu = Th_th(i)*(1.+RETV*qT_th(i)) +c Le Ri par Theta_v +cAM rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu) +cAM . /(zdu2*0.5*(zthvd+zthvu)) +cAM On a nveau de ref a 2m ??? + rhino(i,k) = (z(i,k)-zref)*RG*(zthvd-zthvu) + . /(zdu2*0.5*(zthvd+zthvu)) +c + IF (rhino(i,k).GE.ricr) THEN + pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) * + . (ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k)) +c test04 + pblh(i) = pblh(i) + 100. + pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) * + . (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1)) + check(i) = .FALSE. + ENDIF + ENDIF + ENDDO + ENDDO + +C +C Set pbl height to maximum value where computation exceeds number of +C layers allowed +C + DO i = 1, knon + if (check(i)) pblh(i) = z(i,isommet) + ENDDO +C +C Improve estimate of pbl height for the unstable points. +C Find unstable points (sensible heat flux is upward): +C + DO i = 1, knon + IF (heatv(i) .GT. 0.) THEN + unstbl(i) = .TRUE. + check(i) = .TRUE. + ELSE + unstbl(i) = .FALSE. + check(i) = .FALSE. + ENDIF + ENDDO +C +C For the unstable case, compute velocity scale and the +C convective temperature excess: +C + DO i = 1, knon + IF (check(i)) THEN + phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet +c *************************************************** +c Wm ? et W* ? c'est la formule pour z/h < .1 +c ;Calcul de w* ;; +c ;;;;;;;;;;;;;;;; +c w_star=((g/tcls)*fcsv*z(ind))^(1/3.) [ou prendre la premiere approx de h) +c ;; CALCUL DE wm ;; +c ;;;;;;;;;;;;;;;;;; +c ; Ici on considerera que l'on est dans la couche de surf jusqu'a 100m +c ; On prend svt couche de surface=0.1*h mais on ne connait pas h +c ;;;;;;;;;;;Dans la couche de surface +c if (z(ind) le 20) then begin +c Phim=(1.-15.*(z(ind)/L))^(-1/3.) +c wm=u_star/Phim +c ;;;;;;;;;;;En dehors de la couche de surface +c endif else if (z(ind) gt 20) then begin +c wm=(u_star^3+c1*w_star^3)^(1/3.) +c endif +c *************************************************** + wm(i)= ustar(i)*phiminv(i) +c====================================================================== +cvaleurs de Dominique Lambert de la campagne SEMAPHORE : +c = 100.T*^2; = 20.q*^2 a 10m +c = (1+1.2q).100.T* + 1.2Tv.sqrt(20*100).T*.q* + (.608*Tv)^2*20.q*^2; +c et dTetavS = sqrt() ainsi calculee. +c avec : T*=_s/w* et q*=/w* +c !!! on peut donc utiliser w* pour les fluctuations <-> Lambert +c(leur corellation pourrait dependre de beta par ex) +c if fcsv(i,j) gt 0 then begin +c dTetavs=b1*(1.+2.*.608*q_10(i,j))*(fcs(i,j)/wm(i,j))^2+$ +c (.608*Thetav_10(i,j))^2*b2*(xle(i,j)/wm(i,j))^2+$ +c 2.*.608*thetav_10(i,j)*sqrt(b1*b2)*(xle(i,j)/wm(i,j))*(fcs(i,j)/wm(i,j)) +c dqs=b2*(xle(i,j)/wm(i,j))^2 +c theta_s(i,j)=thetav_10(i,j)+sqrt(dTetavs) +c q_s(i,j)=q_10(i,j)+sqrt(dqs) +c endif else begin +c Theta_s(i,j)=thetav_10(i,j) +c q_s(i,j)=q_10(i,j) +c endelse +c====================================================================== +c +cHBTM therm(i) = heatv(i)*fak/wm(i) +c forme Mathieu : + q_star = kqfs(i)/wm(i) + t_star = khfs(i)/wm(i) +cIM 091204 BEG + IF(1.EQ.0) THEN + IF(t_star.LT.0..OR.q_star.LT.0.) THEN + print*,'i t_star q_star khfs kqfs wm',i,t_star,q_star, + $ khfs(i),kqfs(i),wm(i) + ENDIF + ENDIF +cIM 091204 END +cAM Nveau cde ref 2m => +cAM therm(i) = sqrt( b1*(1.+2.*RETV*q(i,1))*t_star**2 +cAM + + (RETV*T(i,1))**2*b2*q_star**2 +cAM + + 2.*RETV*T(i,1)*b212*q_star*t_star +cAM + ) +cIM 091204 BEG + a1=b1*(1.+2.*RETV*qT_th(i))*t_star**2 + a2=(RETV*Th_th(i))**2*b2*q_star*q_star + a3=2.*RETV*Th_th(i)*b212*q_star*t_star + aa=a1+a2+a3 + IF(1.EQ.0) THEN + IF (aa.LT.0.) THEN + print*,'i a1 a2 a3 aa',i,a1,a2,a3,aa + print*,'i qT_th Th_th t_star q_star RETV b1 b2 b212', + $ i,qT_th(i),Th_th(i),t_star,q_star,RETV,b1,b2,b212 + ENDIF + ENDIF +cIM 091204 END + therm(i) = sqrt( b1*(1.+2.*RETV*qT_th(i))*t_star**2 + + + (RETV*Th_th(i))**2*b2*q_star*q_star +cIM 101204 + + 2.*RETV*Th_th(i)*b212*q_star*t_star + + + max(0.,2.*RETV*Th_th(i)*b212*q_star*t_star) + + ) +c +c Theta et qT du thermique (forme H&B) avec exces +c (attention, on ajoute therm(i) qui est virtuelle ...) +c pourquoi pas sqrt(b1)*t_star ? +c dqs = b2sr*kqfs(i)/wm(i) + qT_th(i) = qT_th(i) + b2sr*q_star +cnew on differre le calcul de Theta_e +c The_th(i) = The_th(i) + therm(i) + RLvCp*qT_th(i) +c ou: The_th(i) = The_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i) + rhino(i,1) = 0.0 + ENDIF + ENDDO +C +c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C ++ Improve pblh estimate for unstable conditions using the +++++++ +C ++ convective temperature excess : +++++++ +c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C + DO k = 2, isommet + DO i = 1, knon + IF (check(i)) THEN +ctest zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2 + zdu2 = u(i,k)**2+v(i,k)**2 + zdu2 = max(zdu2,1.0e-20) +c Theta_v environnement + zthvd=t(i,k)/s(i,k)*(1.+RETV*q(i,k)) +c +c et therm Theta_v (avec hypothese de constance de H&B, +c zthvu=(t(i,1)+therm(i))/s(i,1)*(1.+RETV*q(i,1)) + zthvu = Th_th(i)*(1.+RETV*qT_th(i)) + therm(i) + +c +c Le Ri par Theta_v +cAM Niveau de ref 2m +cAM rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu) +cAM . /(zdu2*0.5*(zthvd+zthvu)) + rhino(i,k) = (z(i,k)-zref)*RG*(zthvd-zthvu) + . /(zdu2*0.5*(zthvd+zthvu)) +c +c + IF (rhino(i,k).GE.ricr) THEN + pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) * + . (ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k)) +c test04 + pblh(i) = pblh(i) + 100. + pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) * + . (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1)) + check(i) = .FALSE. +cIM 170305 BEG + IF(1.EQ.0) THEN +c debug print -120;34 -34- 58 et 0;26 wamp + if (i.eq.950.or.i.eq.192.or.i.eq.624.or.i.eq.118) then + print*,' i,Th_th,Therm,qT :',i,Th_th(i),therm(i),qT_th(i) + q_star = kqfs(i)/wm(i) + t_star = khfs(i)/wm(i) + print*,'q* t*, b1,b2,b212 ',q_star,t_star + - , b1*(1.+2.*RETV*qT_th(i))*t_star**2 + - , (RETV*Th_th(i))**2*b2*q_star**2 + - , 2.*RETV*Th_th(i)*b212*q_star*t_star + print*,'zdu2 ,100.*ustar(i)**2',zdu2 ,fac*ustar(i)**2 + endif + ENDIF !(1.EQ.0) THEN +cIM 170305 END +c q_star = kqfs(i)/wm(i) +c t_star = khfs(i)/wm(i) +c trmb1(i) = b1*(1.+2.*RETV*q(i,1))*t_star**2 +c trmb2(i) = (RETV*T(i,1))**2*b2*q_star**2 +c Omega now trmb3(i) = 2.*RETV*T(i,1)*b212*q_star*t_star + ENDIF + ENDIF + ENDDO + ENDDO +C +C Set pbl height to maximum value where computation exceeds number of +C layers allowed +C + DO i = 1, knon + if (check(i)) pblh(i) = z(i,isommet) + ENDDO +C +C PBL height must be greater than some minimum mechanical mixing depth +C Several investigators have proposed minimum mechanical mixing depth +C relationships as a function of the local friction velocity, u*. We +C make use of a linear relationship of the form h = c u* where c=700. +C The scaling arguments that give rise to this relationship most often +C represent the coefficient c as some constant over the local coriolis +C parameter. Here we make use of the experimental results of Koracin +C and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f +C where f was evaluated at 39.5 N and 52 N. Thus we use a typical mid +C latitude value for f so that c = 0.07/f = 700. +C + DO i = 1, knon + pblmin = 700.0*ustar(i) + pblh(i) = MAX(pblh(i),pblmin) +c par exemple : + pblT(i) = t(i,2) + (t(i,3)-t(i,2)) * + . (pblh(i)-z(i,2))/(z(i,3)-z(i,2)) + ENDDO + +C ******************************************************************** +C pblh is now available; do preparation for diffusivity calculation : +C ******************************************************************** + DO i = 1, knon + check(i) = .TRUE. + Zsat(i) = .FALSE. +c omegafl utilise pour prolongement CAPE + omegafl(i) = .FALSE. + Cape(i) = 0. + Kape(i) = 0. + EauLiq(i) = 0. + CTEI(i) = 0. + pblk(i) = 0.0 + fak1(i) = ustar(i)*pblh(i)*vk +C +C Do additional preparation for unstable cases only, set temperature +C and moisture perturbations depending on stability. +C *** Rq: les formule sont prises dans leur forme CS *** + IF (unstbl(i)) THEN +cAM Niveau de ref du thermique +cAM zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1))) +cAM . *(1.+RETV*q(i,1)) + zxt=(Th_th(i)-zref*0.5*RG/RCPD/(1.+RVTMP2*qT_th(i))) + . *(1.+RETV*qT_th(i)) + phiminv(i) = (1. - binm*pblh(i)/obklen(i))**onet + phihinv(i) = sqrt(1. - binh*pblh(i)/obklen(i)) + wm(i) = ustar(i)*phiminv(i) + fak2(i) = wm(i)*pblh(i)*vk + wstr(i) = (heatv(i)*RG*pblh(i)/zxt)**onet + fak3(i) = fakn*wstr(i)/wm(i) + ENDIF +c Computes Theta_e for thermal (all cases : to be modified) +c attention ajout therm(i) = virtuelle + The_th(i) = Th_th(i) + therm(i) + RLvCp*qT_th(i) +c ou: The_th(i) = Th_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i) + ENDDO + +C Main level loop to compute the diffusivities and +C counter-gradient terms: +C + DO 1000 k = 2, isommet +C +C Find levels within boundary layer: +C + DO i = 1, knon + unslev(i) = .FALSE. + stblev(i) = .FALSE. + zm(i) = z(i,k-1) + zp(i) = z(i,k) + IF (zkmin.EQ.0.0 .AND. zp(i).GT.pblh(i)) zp(i) = pblh(i) + IF (zm(i) .LT. pblh(i)) THEN + zmzp = 0.5*(zm(i) + zp(i)) +C debug +c if (i.EQ.1864) then +c print*,'i,pblh(1864),obklen(1864)',i,pblh(i),obklen(i) +c endif + + zh(i) = zmzp/pblh(i) + zl(i) = zmzp/obklen(i) + zzh(i) = 0. + IF (zh(i).LE.1.0) zzh(i) = (1. - zh(i))**2 +C +C stblev for points zm < plbh and stable and neutral +C unslev for points zm < plbh and unstable +C + IF (unstbl(i)) THEN + unslev(i) = .TRUE. + ELSE + stblev(i) = .TRUE. + ENDIF + ENDIF + ENDDO +c print*,'fin calcul niveaux' +C +C Stable and neutral points; set diffusivities; counter-gradient +C terms zero for stable case: +C + DO i = 1, knon + IF (stblev(i)) THEN + IF (zl(i).LE.1.) THEN + pblk(i) = fak1(i)*zh(i)*zzh(i)/(1. + betas*zl(i)) + ELSE + pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas + zl(i)) + ENDIF +c pcfm(i,k) = pblk(i) +c pcfh(i,k) = pcfm(i,k) + ENDIF + ENDDO +C +C unssrf, unstable within surface layer of pbl +C unsout, unstable within outer layer of pbl +C + DO i = 1, knon + unssrf(i) = .FALSE. + unsout(i) = .FALSE. + IF (unslev(i)) THEN + IF (zh(i).lt.sffrac) THEN + unssrf(i) = .TRUE. + ELSE + unsout(i) = .TRUE. + ENDIF + ENDIF + ENDDO +C +C Unstable for surface layer; counter-gradient terms zero +C + DO i = 1, knon + IF (unssrf(i)) THEN + term = (1. - betam*zl(i))**onet + pblk(i) = fak1(i)*zh(i)*zzh(i)*term + pr(i) = term/sqrt(1. - betah*zl(i)) + ENDIF + ENDDO +c print*,'fin counter-gradient terms zero' +C +C Unstable for outer layer; counter-gradient terms non-zero: +C + DO i = 1, knon + IF (unsout(i)) THEN + pblk(i) = fak2(i)*zh(i)*zzh(i) +c cgs(i,k) = fak3(i)/(pblh(i)*wm(i)) +c cgh(i,k) = khfs(i)*cgs(i,k) + pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak +c cgq(i,k) = kqfs(i)*cgs(i,k) + ENDIF + ENDDO +c print*,'fin counter-gradient terms non zero' +C +C For all unstable layers, compute diffusivities and ctrgrad ter m +C +c DO i = 1, knon +c IF (unslev(i)) THEN +c pcfm(i,k) = pblk(i) +c pcfh(i,k) = pblk(i)/pr(i) +c etc cf original +c ENDIF +c ENDDO +C +C For all layers, compute integral info and CTEI +C + DO i = 1, knon + if (check(i).or.omegafl(i)) then + if (.not.Zsat(i)) then +c Th2 = The_th(i) - RLvCp*qT_th(i) + Th2 = Th_th(i) + T2 = Th2*s(i,k) +c thermodyn functions + zdelta=MAX(0.,SIGN(1.,RTT-T2)) + qqsat= r2es * FOEEW(T2,zdelta)/pplay(i,k) + qqsat=MIN(0.5,qqsat) + zcor=1./(1.-retv*qqsat) + qqsat=qqsat*zcor +c + if (qqsat.lt.qT_th(i)) then +c on calcule lcl + if (k.eq.2) then + plcl(i) = z(i,k) + else + plcl(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) * + . (qT_th(i)-qsatbef(i))/(qsatbef(i)-qqsat) + endif + Zsat(i) = .true. + Tbef(i) = T2 + endif +c + qsatbef(i) = qqsat ! bug dans la version orig ??? + endif +camn ???? cette ligne a deja ete faite normalement ? + endif +c print*,'hbtm2 i,k=',i,k + ENDDO + 1000 continue ! end of level loop +cIM 170305 BEG + IF(1.EQ.0) THEN + print*,'hbtm2 ok' + ENDIF !(1.EQ.0) THEN +cIM 170305 END + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/hgardfou.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/hgardfou.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/hgardfou.F (revision 1280) @@ -0,0 +1,134 @@ +! +! $Id$ + SUBROUTINE hgardfou (t,tsol,text) + use dimphy + use phys_state_var_mod + IMPLICIT none +c====================================================================== +c Verifier la temperature +c====================================================================== +#include "dimensions.h" +#include "YOMCST.h" +#include "indicesol.h" + REAL t(klon,klev), tsol(klon,nbsrf) + CHARACTER*(*) text + character (len=20) :: modname = 'hgardfou' + character (len=80) :: abort_message +C + INTEGER i, k, nsrf + REAL zt(klon) + INTEGER jadrs(klon), jbad + LOGICAL ok +c + LOGICAL firstcall + SAVE firstcall + DATA firstcall /.TRUE./ +c$OMP THREADPRIVATE(firstcall) + + IF (firstcall) THEN + PRINT*, 'hgardfou garantit la temperature dans [100,370] K' + firstcall = .FALSE. +c DO i = 1, klon +c print*,'i=',i,'rlon=',rlon(i),'rlat=',rlat(i) +c ENDDO +c + ENDIF +c + ok = .TRUE. + DO k = 1, klev + DO i = 1, klon + zt(i) = t(i,k) + ENDDO +#ifdef CRAY + CALL WHENFGT(klon, zt, 1, 370.0, jadrs, jbad) +#else + jbad = 0 + DO i = 1, klon + IF (zt(i).GT.370.0) THEN + jbad = jbad + 1 + jadrs(jbad) = i + ENDIF + ENDDO +#endif + IF (jbad .GT. 0) THEN + ok = .FALSE. + DO i = 1, jbad + PRINT *,'i,k,temperature,lon,lat,pourc ter,oce,lic,sic =', + $ jadrs(i),k,zt(jadrs(i)),rlon(jadrs(i)),rlat(jadrs(i)), + $ (pctsrf(jadrs(i),nsrf),nsrf=1,nbsrf) + ENDDO + ENDIF +#ifdef CRAY + CALL WHENFLT(klon, zt, 1, 100.0, jadrs, jbad) +#else + jbad = 0 + DO i = 1, klon +! IF (zt(i).LT.100.0) THEN + IF (zt(i).LT.50.0) THEN + jbad = jbad + 1 + jadrs(jbad) = i + ENDIF + ENDDO +#endif + IF (jbad .GT. 0) THEN + ok = .FALSE. + DO i = 1, jbad + PRINT *,'i,k,temperature,lon,lat,pourc ter,oce,lic,sic =', + $ jadrs(i),k,zt(jadrs(i)),rlon(jadrs(i)),rlat(jadrs(i)), + $ (pctsrf(jadrs(i),nsrf),nsrf=1,nbsrf) + ENDDO + ENDIF + ENDDO +c + DO nsrf = 1, nbsrf + DO i = 1, klon + zt(i) = tsol(i,nsrf) + ENDDO +#ifdef CRAY + CALL WHENFGT(klon, zt, 1, 370.0, jadrs, jbad) +#else + jbad = 0 + DO i = 1, klon + IF (zt(i).GT.370.0) THEN + jbad = jbad + 1 + jadrs(jbad) = i + ENDIF + ENDDO +#endif + IF (jbad .GT. 0) THEN + ok = .FALSE. + DO i = 1, jbad + PRINT *,'i,nsrf,temperature,lon,lat,pourc ter,oce,lic,sic =' + $ ,jadrs(i),nsrf,zt(jadrs(i)),rlon(jadrs(i)),rlat(jadrs(i)) + $ ,pctsrf(jadrs(i),nsrf) + ENDDO + ENDIF +#ifdef CRAY + CALL WHENFLT(klon, zt, 1, 100.0, jadrs, jbad) +#else + jbad = 0 + DO i = 1, klon +! IF (zt(i).LT.100.0) THEN + IF (zt(i).LT.50.0) THEN + jbad = jbad + 1 + jadrs(jbad) = i + ENDIF + ENDDO +#endif + IF (jbad .GT. 0) THEN + ok = .FALSE. + DO i = 1, jbad + PRINT *,'i,nsrf,temperature,lon,lat,pourc ter,oce,lic,sic =' + $ ,jadrs(i),nsrf,zt(jadrs(i)),rlon(jadrs(i)),rlat(jadrs(i)) + $ ,pctsrf(jadrs(i),nsrf) + ENDDO + ENDIF + ENDDO +c + IF (.NOT. ok) THEN + abort_message= 'hgardfou s arrete '//text + CALL abort_gcm (modname,abort_message,1) + ENDIF + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/hines_gwd.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/hines_gwd.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/hines_gwd.F (revision 1280) @@ -0,0 +1,2080 @@ +! +! $Id$ +! + SUBROUTINE HINES_GWD(NLON,NLEV,DTIME,paphm1x, papm1x, + I rlat,tx,ux,vx, + O zustrhi,zvstrhi, + O d_t_hin, d_u_hin, d_v_hin) + +C ######################################################################## +C Parametrization of the momentum flux deposition due to a broad band +C spectrum of gravity waves, following Hines (1997a,b), as coded by +C McLANDRESS (1995). Modified by McFARLANE and MANZINI (1995-1997) +C MAECHAM model stand alone version +C ######################################################################## +C +C + USE dimphy + implicit none + +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOEGWD.h" +#include "YOMCST.h" + + INTEGER NAZMTH + PARAMETER(NAZMTH=8) + +C INPUT ARGUMENTS. +C ----- ---------- +C +C - 2D +C PAPHM1 : HALF LEVEL PRESSURE (T-DT) +C PAPM1 : FULL LEVEL PRESSURE (T-DT) +C PTM1 : TEMPERATURE (T-DT) +C PUM1 : ZONAL WIND (T-DT) +C PVM1 : MERIDIONAL WIND (T-DT) +C + +C REFERENCE. +C ---------- +C SEE MODEL DOCUMENTATION +C +C AUTHOR. +C ------- +C +C N. MCFARLANE DKRZ-HAMBURG MAY 1995 +C STAND ALONE E. MANZINI MPI-HAMBURG FEBRUARY 1997 +C +C BASED ON A COMBINATION OF THE OROGRAPHIC SCHEME BY N.MCFARLANE 1987 +C AND THE HINES SCHEME AS CODED BY C. MCLANDRESS 1995. +C +C +C +cym INTEGER KLEVM1 +C + REAL PAPHM1(klon,klev+1), PAPM1(klon,KLEV) + REAL PTM1(klon,KLEV), PUM1(klon,KLEV), PVM1(klon,KLEV) + REAL PRFLUX(klon) +C1 +C1 +C1 + REAL RLAT(klon),COSLAT(KLON) +C + REAL TH(klon,KLEV), + 2 UTENDGW(klon,KLEV), VTENDGW(klon,KLEV), + 3 PRESSG(klon), + 4 UHS(klon,KLEV), VHS(klon,KLEV), ZPR(klon) + +C * VERTICAL POSITIONING ARRAYS. + + REAL SGJ(klon,KLEV), SHJ(klon,KLEV), + 1 SHXKJ(klon,KLEV), DSGJ(klon,KLEV) + +C * LOGICAL SWITCHES TO CONTROL ROOF DRAG, ENVELOP GW DRAG AND +C * HINES' DOPPLER SPREADING EXTROWAVE GW DRAG. +C * LOZPR IS TRUE FOR ZPR ENHANCEMENT + + +C * WORK ARRAYS. + + REAL M_ALPHA(klon,KLEV,NAZMTH), V_ALPHA(klon,KLEV,NAZMTH), + 1 SIGMA_ALPHA(klon,KLEV,NAZMTH), + 1 SIGSQH_ALPHA(klon,KLEV,NAZMTH), + 2 DRAG_U(klon,KLEV), DRAG_V(klon,KLEV), FLUX_U(klon,KLEV), + 3 FLUX_V(klon,KLEV), HEAT(klon,KLEV), DIFFCO(klon,KLEV), + 4 BVFREQ(klon,KLEV), DENSITY(klon,KLEV), SIGMA_T(klon,KLEV), + 5 VISC_MOL(klon,KLEV), ALT(klon,KLEV), + 6 SIGSQMCW(klon,KLEV,NAZMTH), + 6 SIGMATM(klon,KLEV), + 7 AK_ALPHA(klon,NAZMTH), K_ALPHA(klon,NAZMTH), + 8 MMIN_ALPHA(klon,NAZMTH), I_ALPHA(klon,NAZMTH), + 9 RMSWIND(klon), BVFBOT(klon), DENSBOT(klon) + REAL SMOOTHR1(klon,KLEV), SMOOTHR2(klon,KLEV) + REAL SIGALPMC(klon,KLEV,NAZMTH) + REAL F2MOD(klon,KLEV) + +C * THES ARE THE INPUT PARAMETERS FOR HINES ROUTINE AND +C * ARE SPECIFIED IN ROUTINE HINES_SETUP. SINCE THIS IS CALLED +C * ONLY AT FIRST CALL TO THIS ROUTINE THESE VARIABLES MUST BE SAVED +C * FOR USE AT SUBSEQUENT CALLS. THIS CAN BE AVOIDED BY CALLING +C * HINES_SETUP IN MAIN PROGRAM AND PASSING THE PARAMETERS AS +C * SUBROUTINE ARGUEMENTS. +C + + REAL RMSCON + INTEGER NMESSG, IPRINT, ILRMS + INTEGER IFL +C + INTEGER NAZ,ICUTOFF,NSMAX,IHEATCAL + REAL SLOPE,F1,F2,F3,F5,F6,KSTAR(KLON),ALT_CUTOFF,SMCO +C +C PROVIDED AS INPUT +C + integer nlon,nlev + + real dtime + real paphm1x(nlon,nlev+1), papm1x(nlon,nlev) + real ux(nlon,nlev), vx(nlon,nlev), tx(nlon,nlev) +c +c VARIABLES FOR OUTPUT +c + + real d_t_hin(nlon,nlev),d_u_hin(nlon,nlev),d_v_hin(nlon,nlev) + real zustrhi(nlon),zvstrhi(nlon) + +C +C * LOGICAL SWITCHES TO CONTROL PRECIP ENHANCEMENT AND +C * HINES' DOPPLER SPREADING EXTROWAVE GW DRAG. +C * LOZPR IS TRUE FOR ZPR ENHANCEMENT +C + LOGICAL LOZPR, LORMS(klon) +C +C LOCAL PARAMETERS TO MAKE THINGS WORK (TEMPORARY VARIABLE) + + REAL RHOH2O,ZPCONS,RGOCP,ZLAT,DTTDSF,RATIO,HSCAL + INTEGER I,J,L,JL,JK,LE,LREF,LREFP,LEVBOT +C +C DATA PARAMETERS NEEDED, EXPLAINED LATER + + REAL V0,VMIN,DMPSCAL,TAUFAC,HMIN,APIBT,CPART,FCRIT + REAL PCRIT,PCONS + INTEGER IPLEV,IERROR + +C +C +C PRINT *,' IT IS STARTED HINES GOING ON...' +C +C +C +C +C* COMPUTATIONAL CONSTANTS. +C ------------- ---------- +C +C + d_t_hin(:,:)=0. + + RHOH2O=1000. + ZPCONS = (1000.*86400.)/RHOH2O +cym KLEVM1=KLEV-1 +C + + do jl=kidia,kfdia + PAPHM1(JL,1) = paphm1x(JL,klev+1) + do jk=1,klev + le=klev+1-jk + PAPHM1(JL,JK+1) = paphm1x(JL,le) + PAPM1(JL,JK) = papm1x(JL,le) + PTM1(JL,JK) = tx(JL,le) + PUM1(JL,JK) = ux(JL,le) + PVM1(JL,JK) = vx(JL,le) + enddo + enddo +C + 100 CONTINUE +C +C Define constants and arrays needed for the ccc/mam gwd scheme +C *Constants: + + RGOCP=RD/RCPD + LREFP=KLEV-1 + LREF=KLEV-2 +C1 +C1 *Arrays +C1 + DO 2101 JK=1,KLEV + DO 2102 JL=KIDIA,KFDIA + SHJ(JL,JK)=PAPM1(JL,JK)/PAPHM1(JL,klev+1) + SGJ(JL,JK)=PAPM1(JL,JK)/PAPHM1(JL,klev+1) + DSGJ(JL,JK)=(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))/PAPHM1(JL,klev+1) + SHXKJ(JL,JK)=(PAPM1(JL,JK)/PAPHM1(JL,klev+1))**RGOCP + TH(JL,JK)= PTM1(JL,JK) + 2102 CONTINUE + 2101 CONTINUE + +CC + DO 211 JL=KIDIA,KFDIA + PRESSG(JL)=PAPHM1(JL,klev+1) + 211 CONTINUE +C +C + DO 301 JL=KIDIA,KFDIA + PRFLUX(JL) = 0.0 + ZPR(JL)=ZPCONS*PRFLUX(JL) + ZLAT=(RLAT(JL)/180.)*RPI + COSLAT(Jl)=COS(ZLAT) + 301 CONTINUE +C +C + 400 CONTINUE +C +C +C +C +*/######################################################################### +*/ +*/ +C +C * AUG. 14/95 - C. MCLANDRESS. +C * SEP. 95 N. MCFARLANE. +C +C * THIS ROUTINE CALCULATES THE HORIZONTAL WIND TENDENCIES +C * DUE TO MCFARLANE'S OROGRAPHIC GW DRAG SCHEME, HINES' +C * DOPPLER SPREAD SCHEME FOR "EXTROWAVES" AND ADDS ON +C * ROOF DRAG. IT IS BASED ON THE ROUTINE GWDFLX8. +C +C * LREFP IS THE INDEX OF THE MODEL LEVEL BELOW THE REFERENCE LEVEL +C * I/O ARRAYS PASSED FROM MAIN. +C * (PRESSG = SURFACE PRESSURE) +C +C +C +C +C * CONSTANTS VALUES DEFINED IN DATA STATEMENT ARE : +C * VMIN = MIMINUM WIND IN THE DIRECTION OF REFERENCE LEVEL +C * WIND BEFORE WE CONSIDER BREAKING TO HAVE OCCURED. +C * DMPSCAL = DAMPING TIME FOR GW DRAG IN SECONDS. +C * TAUFAC = 1/(LENGTH SCALE). +C * HMIN = MIMINUM ENVELOPE HEIGHT REQUIRED TO PRODUCE GW DRAG. +C * V0 = VALUE OF WIND THAT APPROXIMATES ZERO. + + + DATA VMIN / 5.0 /, V0 / 1.E-10 /, + 1 TAUFAC/ 5.E-6 /, HMIN / 40000. /, + 3 DMPSCAL / 6.5E+6 /, APIBT / 1.5708 /, + 4 CPART / 0.7 /, FCRIT / 1. / + +C * HINES EXTROWAVE GWD CONSTANTS DEFINED IN DATA STATEMENT ARE: +C * RMSCON = ROOT MEAN SQUARE GRAVITY WAVE WIND AT LOWEST LEVEL (M/S). +C * NMESSG = UNIT NUMBER FOR PRINTED MESSAGES. +C * IPRINT = 1 TO DO PRINT OUT SOME HINES ARRAYS. +C * IFL = FIRST CALL FLAG TO HINES_SETUP ("SAVE" IT) +C * PCRIT = CRITICAL VALUE OF ZPR (MM/D) +C * IPLEV = LEVEL OF APPLICATION OF PRCIT +C * PCONS = FACTOR OF ZPR ENHANCEMENT +C + + DATA PCRIT / 5. /, PCONS / 4.75 / + + IPLEV = LREFP-1 +C + DATA RMSCON / 1.00 / + 1 IPRINT / 2 /, NMESSG / 6 / + DATA IFL / 0 / +C + LOZPR = .FALSE. +C +C----------------------------------------------------------------------- +C +C +C +C * SET ERROR FLAG + + IERROR = 0 + +C * SPECIFY VARIOUS PARAMETERS FOR HINES ROUTINE AT VERY FIRST CALL. +C * (NOTE THAT ARRAY K_ALPHA IS SPECIFIED SO MAKE SURE THAT +C * IT IS NOT OVERWRITTEN LATER ON). +C + CALL HINES_SETUP (NAZ,SLOPE,F1,F2,F3,F5,F6,KSTAR, + 1 ICUTOFF,ALT_CUTOFF,SMCO,NSMAX,IHEATCAL, + 2 K_ALPHA,IERROR,NMESSG,klon,NAZMTH,COSLAT) + IF (IERROR.NE.0) GO TO 999 +C +C * START GWD CALCULATIONS. + + LREF = LREFP-1 + +C + DO 105 J=1,NAZMTH + DO 105 L=1,KLEV + DO 105 I=kidia,klon + SIGSQMCW(I,L,J) = 0. + 105 CONTINUE +c + + +C * INITIALIZE NECESSARY ARRAYS. +C + DO 120 L=1,KLEV + DO 120 I=KIDIA,KFDIA + UTENDGW(I,L) = 0. + VTENDGW(I,L) = 0. + + UHS(I,L) = 0. + VHS(I,L) = 0. + + 120 CONTINUE +C +C * IF USING HINES SCHEME THEN CALCULATE B V FREQUENCY AT ALL POINTS +C * AND SMOOTH BVFREQ. + + DO 130 L=2,KLEV + DO 130 I=KIDIA,KFDIA + DTTDSF=(TH(I,L)/SHXKJ(I,L)-TH(I,L-1)/ + 1 SHXKJ(I,L-1))/(SHJ(I,L)-SHJ(I,L-1)) + DTTDSF=MIN(DTTDSF, -5./SGJ(I,L)) + BVFREQ(I,L)=SQRT(-DTTDSF*SGJ(I,L)*(SGJ(I,L)**RGOCP)/RD) + 1 *RG/PTM1(I,L) + 130 CONTINUE + DO 135 L=1,KLEV + DO 135 I=KIDIA,KFDIA + IF(L.EQ.1) THEN + BVFREQ(I,L) = BVFREQ(I,L+1) + ENDIF + IF(L.GT.1) THEN + RATIO=5.*LOG(SGJ(I,L)/SGJ(I,L-1)) + BVFREQ(I,L) = (BVFREQ(I,L-1) + RATIO*BVFREQ(I,L)) + 1 /(1.+RATIO) + ENDIF + 135 CONTINUE +C +C + 300 CONTINUE + +C * CALCULATE GW DRAG DUE TO HINES' EXTROWAVES +C * SET MOLECULAR VISCOSITY TO A VERY SMALL VALUE. +C * IF THE MODEL TOP IS GREATER THAN 100 KM THEN THE ACTUAL +C * VISCOSITY COEFFICIENT COULD BE SPECIFIED HERE. + + DO 310 L=1,KLEV + DO 310 I=KIDIA,KFDIA + VISC_MOL(I,L) = 1.5E-5 + DRAG_U(I,L) = 0. + DRAG_V(I,L) = 0. + FLUX_U(I,L) = 0. + FLUX_V(I,L) = 0. + HEAT(I,L) = 0. + DIFFCO(I,L) = 0. + 310 CONTINUE + +C * ALTITUDE AND DENSITY AT BOTTOM. + + DO 330 I=KIDIA,KFDIA + HSCAL = RD * PTM1(I,KLEV) / RG + DENSITY(I,KLEV) = SGJ(I,KLEV) * PRESSG(I) / (RG*HSCAL) + ALT(I,KLEV) = 0. + 330 CONTINUE + +C * ALTITUDE AND DENSITY AT REMAINING LEVELS. + + DO 340 L=KLEV-1,1,-1 + DO 340 I=KIDIA,KFDIA + HSCAL = RD * PTM1(I,L) / RG + ALT(I,L) = ALT(I,L+1) + HSCAL * DSGJ(I,L) / SGJ(I,L) + DENSITY(I,L) = SGJ(I,L) * PRESSG(I) / (RG*HSCAL) + 340 CONTINUE + +C +C * INITIALIZE SWITCHES FOR HINES GWD CALCULATION +C + ILRMS = 0 +C + DO 345 I=KIDIA,KFDIA + LORMS(I) = .FALSE. + 345 CONTINUE +C +C +C * DEFILE BOTTOM LAUNCH LEVEL +C + LEVBOT = IPLEV +C +C * BACKGROUND WIND MINUS VALUE AT BOTTOM LAUNCH LEVEL. +C + DO 351 L=1,LEVBOT + DO 351 I=KIDIA,KFDIA + UHS(I,L) = PUM1(I,L) - PUM1(I,LEVBOT) + VHS(I,L) = PVM1(I,L) - PVM1(I,LEVBOT) + 351 CONTINUE +C +C * SPECIFY ROOT MEAN SQUARE WIND AT BOTTOM LAUNCH LEVEL. +C + DO 355 I=KIDIA,KFDIA + RMSWIND(I) = RMSCON + 355 CONTINUE + + IF (LOZPR) THEN + DO 350 I=KIDIA,KFDIA + IF (ZPR(I) .GT. PCRIT) THEN + RMSWIND(I) = RMSCON + > +( (ZPR(I)-PCRIT)/ZPR(I) )*PCONS + ENDIF + 350 CONTINUE + ENDIF +C + DO 356 I=KIDIA,KFDIA + IF (RMSWIND(I) .GT. 0.0) THEN + ILRMS = ILRMS+1 + LORMS(I) = .TRUE. + ENDIF + 356 CONTINUE +C +C * CALCULATE GWD (NOTE THAT DIFFUSION COEFFICIENT AND +C * HEATING RATE ONLY CALCULATED IF IHEATCAL = 1). +C + IF ( ILRMS.GT.0 ) THEN +C + CALL HINES_EXTRO0 (DRAG_U,DRAG_V,HEAT,DIFFCO,FLUX_U,FLUX_V, + 1 UHS,VHS,BVFREQ,DENSITY,VISC_MOL,ALT, + 2 RMSWIND,K_ALPHA,M_ALPHA,V_ALPHA, + 3 SIGMA_ALPHA,SIGSQH_ALPHA,AK_ALPHA, + 4 MMIN_ALPHA,I_ALPHA,SIGMA_T,DENSBOT,BVFBOT, + 5 1,IHEATCAL,ICUTOFF,IPRINT,NSMAX, + 6 SMCO,ALT_CUTOFF,KSTAR,SLOPE, + 7 F1,F2,F3,F5,F6,NAZ,SIGSQMCW,SIGMATM, + 8 KIDIA,klon,1,LEVBOT,KLON,KLEV,NAZMTH, + 9 LORMS,SMOOTHR1,SMOOTHR2, + 9 SIGALPMC,F2MOD) + +C * ADD ON HINES' GWD TENDENCIES TO OROGRAPHIC TENDENCIES AND +C * APPLY HINES' GW DRAG ON (UROW,VROW) WORK ARRAYS. + + DO 360 L=1,KLEV + DO 360 I=KIDIA,KFDIA + UTENDGW(I,L) = UTENDGW(I,L) + DRAG_U(I,L) + VTENDGW(I,L) = VTENDGW(I,L) + DRAG_V(I,L) + 360 CONTINUE +C + +C * END OF HINES CALCULATIONS. +C + ENDIF +C + 500 CONTINUE + + +C----------------------------------------------------------------------- +C + do jl=kidia,kfdia + zustrhi(jl)=FLUX_U(jl,1) + zvstrhi(jl)=FLUX_v(jl,1) + do jk=1,klev + le=klev-jk+1 + d_u_hin(jl,JK) = UTENDGW(jl,le) * dtime + d_v_hin(jl,JK) = VTENDGW(jl,le) * dtime + enddo + enddo + +c PRINT *,'UTENDGW:',UTENDGW + +C PRINT *,' HINES HAS BEEN COMPLETED (LONG ISNT IT...)' + + RETURN + 999 CONTINUE + +C * IF ERROR DETECTED THEN ABORT. + + WRITE (NMESSG,6000) + WRITE (NMESSG,6010) IERROR + 6000 FORMAT (/' EXECUTION ABORTED IN GWDOREXV') + 6010 FORMAT (' ERROR FLAG =',I4) + +C + RETURN + END +*/ +*/ + + + SUBROUTINE HINES_EXTRO0 (DRAG_U,DRAG_V,HEAT,DIFFCO,FLUX_U,FLUX_V, + 1 VEL_U,VEL_V,BVFREQ,DENSITY,VISC_MOL,ALT, + 2 RMSWIND,K_ALPHA,M_ALPHA,V_ALPHA, + 3 SIGMA_ALPHA,SIGSQH_ALPHA,AK_ALPHA, + 4 MMIN_ALPHA,I_ALPHA,SIGMA_T,DENSB,BVFB, + 5 IORDER,IHEATCAL,ICUTOFF,IPRINT,NSMAX, + 6 SMCO,ALT_CUTOFF,KSTAR,SLOPE, + 7 F1,F2,F3,F5,F6,NAZ,SIGSQMCW,SIGMATM, + 8 IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH, + 9 LORMS,SMOOTHR1,SMOOTHR2, + 9 SIGALPMC,F2MOD) + + implicit none +C +C Main routine for Hines' "extrowave" gravity wave parameterization based +C on Hines' Doppler spread theory. This routine calculates zonal +C and meridional components of gravity wave drag, heating rates +C and diffusion coefficient on a longitude by altitude grid. +C No "mythical" lower boundary region calculation is made so it +C is assumed that lowest level winds are weak (i.e, approximately zero). +C +C Aug. 13/95 - C. McLandress +C SEPT. /95 - N.McFarlane +C +C Modifications: +C +C Output arguements: +C +C * DRAG_U = zonal component of gravity wave drag (m/s^2). +C * DRAG_V = meridional component of gravity wave drag (m/s^2). +C * HEAT = gravity wave heating (K/sec). +C * DIFFCO = diffusion coefficient (m^2/sec) +C * FLUX_U = zonal component of vertical momentum flux (Pascals) +C * FLUX_V = meridional component of vertical momentum flux (Pascals) +C +C Input arguements: +C +C * VEL_U = background zonal wind component (m/s). +C * VEL_V = background meridional wind component (m/s). +C * BVFREQ = background Brunt Vassala frequency (radians/sec). +C * DENSITY = background density (kg/m^3) +C * VISC_MOL = molecular viscosity (m^2/s) +C * ALT = altitude of momentum, density, buoyancy levels (m) +C * (NOTE: levels ordered so that ALT(I,1) > ALT(I,2), etc.) +C * RMSWIND = root mean square gravity wave wind at lowest level (m/s). +C * K_ALPHA = horizontal wavenumber of each azimuth (1/m). +C * IORDER = 1 means vertical levels are indexed from top down +C * (i.e., highest level indexed 1 and lowest level NLEVS); +C * .NE. 1 highest level is index NLEVS. +C * IHEATCAL = 1 to calculate heating rates and diffusion coefficient. +C * IPRINT = 1 to print out various arrays. +C * ICUTOFF = 1 to exponentially damp GWD, heating and diffusion +C * arrays above ALT_CUTOFF; otherwise arrays not modified. +C * ALT_CUTOFF = altitude in meters above which exponential decay applied. +C * SMCO = smoothing factor used to smooth cutoff vertical +C * wavenumbers and total rms winds in vertical direction +C * before calculating drag or heating +C * (SMCO >= 1 ==> 1:SMCO:1 stencil used). +C * NSMAX = number of times smoother applied ( >= 1), +C * = 0 means no smoothing performed. +C * KSTAR = typical gravity wave horizontal wavenumber (1/m). +C * SLOPE = slope of incident vertical wavenumber spectrum +C * (SLOPE must equal 1., 1.5 or 2.). +C * F1 to F6 = Hines's fudge factors (F4 not needed since used for +C * vertical flux of vertical momentum). +C * NAZ = actual number of horizontal azimuths used. +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * LEV1 = index of first level for drag calculation. +C * LEV2 = index of last level for drag calculation +C * (i.e., LEV1 < LEV2 <= NLEVS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical levels. +C * NAZMTH = azimuthal array dimension (NAZMTH >= NAZ). +C +C Work arrays. +C +C * M_ALPHA = cutoff vertical wavenumber (1/m). +C * V_ALPHA = wind component at each azimuth (m/s) and if IHEATCAL=1 +C * holds vertical derivative of cutoff wavenumber. +C * SIGMA_ALPHA = total rms wind in each azimuth (m/s). +C * SIGSQH_ALPHA = portion of wind variance from waves having wave +C * normals in the alpha azimuth (m/s). +C * SIGMA_T = total rms horizontal wind (m/s). +C * AK_ALPHA = spectral amplitude factor at each azimuth +C * (i.e.,{AjKj}) in m^4/s^2. +C * I_ALPHA = Hines' integral. +C * MMIN_ALPHA = minimum value of cutoff wavenumber. +C * DENSB = background density at bottom level. +C * BVFB = buoyancy frequency at bottom level and +C * work array for ICUTOFF = 1. +C +C * LORMS = .TRUE. for drag computation +C + INTEGER NAZ, NLONS, NLEVS, NAZMTH, IL1, IL2, LEV1, LEV2 + INTEGER ICUTOFF, NSMAX, IORDER, IHEATCAL, IPRINT + REAL KSTAR(NLONS), F1, F2, F3, F5, F6, SLOPE + REAL ALT_CUTOFF, SMCO + REAL DRAG_U(NLONS,NLEVS), DRAG_V(NLONS,NLEVS) + REAL HEAT(NLONS,NLEVS), DIFFCO(NLONS,NLEVS) + REAL FLUX_U(NLONS,NLEVS), FLUX_V(NLONS,NLEVS) + REAL VEL_U(NLONS,NLEVS), VEL_V(NLONS,NLEVS) + REAL BVFREQ(NLONS,NLEVS), DENSITY(NLONS,NLEVS) + REAL VISC_MOL(NLONS,NLEVS), ALT(NLONS,NLEVS) + REAL RMSWIND(NLONS), BVFB(NLONS), DENSB(NLONS) + REAL SIGMA_T(NLONS,NLEVS), SIGSQMCW(NLONS,NLEVS,NAZMTH) + REAL SIGMA_ALPHA(NLONS,NLEVS,NAZMTH), SIGMATM(NLONS,NLEVS) + REAL SIGSQH_ALPHA(NLONS,NLEVS,NAZMTH) + REAL M_ALPHA(NLONS,NLEVS,NAZMTH), V_ALPHA(NLONS,NLEVS,NAZMTH) + REAL AK_ALPHA(NLONS,NAZMTH), K_ALPHA(NLONS,NAZMTH) + REAL MMIN_ALPHA(NLONS,NAZMTH) , I_ALPHA(NLONS,NAZMTH) + REAL SMOOTHR1(NLONS,NLEVS), SMOOTHR2(NLONS,NLEVS) + REAL SIGALPMC(NLONS,NLEVS,NAZMTH) + REAL F2MOD(NLONS,NLEVS) +C + LOGICAL LORMS(NLONS) +C +C Internal variables. +C + INTEGER LEVBOT, LEVTOP, I, N, L, LEV1P, LEV2M + INTEGER ILPRT1, ILPRT2 +C----------------------------------------------------------------------- +C +C PRINT *,' IN HINES_EXTRO0' + LEV1P = LEV1 + 1 + LEV2M = LEV2 - 1 +C +C Index of lowest altitude level (bottom of drag calculation). +C + LEVBOT = LEV2 + LEVTOP = LEV1 + IF (IORDER.NE.1) THEN + write(6,1) + 1 format(2x,' error: IORDER NOT ONE! ') + END IF +C +C Buoyancy and density at bottom level. +C + DO 10 I = IL1,IL2 + BVFB(I) = BVFREQ(I,LEVBOT) + DENSB(I) = DENSITY(I,LEVBOT) + 10 CONTINUE +C +C initialize some variables +C + DO 20 N = 1,NAZ + DO 20 L=LEV1,LEV2 + DO 20 I=IL1,IL2 + M_ALPHA(I,L,N) = 0.0 + 20 CONTINUE + DO 21 L=LEV1,LEV2 + DO 21 I=IL1,IL2 + SIGMA_T(I,L) = 0.0 + 21 CONTINUE + DO 22 N = 1,NAZ + DO 22 I=IL1,IL2 + I_ALPHA(I,N) = 0.0 + 22 CONTINUE +C +C Compute azimuthal wind components from zonal and meridional winds. +C + CALL HINES_WIND ( V_ALPHA, + ^ VEL_U, VEL_V, NAZ, + ^ IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH ) +C +C Calculate cutoff vertical wavenumber and velocity variances. +C + CALL HINES_WAVNUM ( M_ALPHA, SIGMA_ALPHA, SIGSQH_ALPHA, SIGMA_T, + ^ AK_ALPHA, V_ALPHA, VISC_MOL, DENSITY, DENSB, + ^ BVFREQ, BVFB, RMSWIND, I_ALPHA, MMIN_ALPHA, + ^ KSTAR, SLOPE, F1, F2, F3, NAZ, LEVBOT, + ^ LEVTOP,IL1,IL2,NLONS,NLEVS,NAZMTH, SIGSQMCW, + ^ SIGMATM,LORMS,SIGALPMC,F2MOD) +C +C Smooth cutoff wavenumbers and total rms velocity in the vertical +C direction NSMAX times, using FLUX_U as temporary work array. +C + IF (NSMAX.GT.0) THEN + DO 80 N = 1,NAZ + DO 81 L=LEV1,LEV2 + DO 81 I=IL1,IL2 + SMOOTHR1(I,L) = M_ALPHA(I,L,N) + 81 CONTINUE + CALL VERT_SMOOTH (SMOOTHR1, + ^ SMOOTHR2, SMCO, NSMAX, + ^ IL1, IL2, LEV1, LEV2, NLONS, NLEVS ) + DO 83 L=LEV1,LEV2 + DO 83 I=IL1,IL2 + M_ALPHA(I,L,N) = SMOOTHR1(I,L) + 83 CONTINUE + 80 CONTINUE + CALL VERT_SMOOTH ( SIGMA_T, + ^ SMOOTHR2, SMCO, NSMAX, + ^ IL1, IL2, LEV1, LEV2, NLONS, NLEVS ) + END IF +C +C Calculate zonal and meridional components of the +C momentum flux and drag. +C + CALL HINES_FLUX ( FLUX_U, FLUX_V, DRAG_U, DRAG_V, + ^ ALT, DENSITY, DENSB, M_ALPHA, + ^ AK_ALPHA, K_ALPHA, SLOPE, NAZ, + ^ IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH, + ^ LORMS) +C +C Cutoff drag above ALT_CUTOFF, using BVFB as temporary work array. +C + IF (ICUTOFF.EQ.1) THEN + CALL HINES_EXP ( DRAG_U, + ^ BVFB, ALT, ALT_CUTOFF, IORDER, + ^ IL1, IL2, LEV1, LEV2, NLONS, NLEVS ) + CALL HINES_EXP ( DRAG_V, + ^ BVFB, ALT, ALT_CUTOFF, IORDER, + ^ IL1, IL2, LEV1, LEV2, NLONS, NLEVS ) + END IF +C +C Print out various arrays for diagnostic purposes. +C + IF (IPRINT.EQ.1) THEN + ILPRT1 = 15 + ILPRT2 = 16 + CALL HINES_PRINT ( FLUX_U, FLUX_V, DRAG_U, DRAG_V, ALT, + ^ SIGMA_T, SIGMA_ALPHA, V_ALPHA, M_ALPHA, + ^ 1, 1, 6, ILPRT1, ILPRT2, LEV1, LEV2, + ^ NAZ, NLONS, NLEVS, NAZMTH) + END IF +C +C If not calculating heating rate and diffusion coefficient then finished. +C + IF (IHEATCAL.NE.1) RETURN +C +C Calculate vertical derivative of cutoff wavenumber (store +C in array V_ALPHA) using centered differences at interior gridpoints +C and one-sided differences at first and last levels. +C + DO 130 N = 1,NAZ + DO 100 L = LEV1P,LEV2M + DO 90 I = IL1,IL2 + V_ALPHA(I,L,N) = ( M_ALPHA(I,L+1,N) - M_ALPHA(I,L-1,N) ) + ^ / ( ALT(I,L+1) - ALT(I,L-1) ) + 90 CONTINUE + 100 CONTINUE + DO 110 I = IL1,IL2 + V_ALPHA(I,LEV1,N) = ( M_ALPHA(I,LEV1P,N) - M_ALPHA(I,LEV1,N) ) + ^ / ( ALT(I,LEV1P) - ALT(I,LEV1) ) + 110 CONTINUE + DO 120 I = IL1,IL2 + V_ALPHA(I,LEV2,N) = ( M_ALPHA(I,LEV2,N) - M_ALPHA(I,LEV2M,N) ) + ^ / ( ALT(I,LEV2) - ALT(I,LEV2M) ) + 120 CONTINUE + 130 CONTINUE +C +C Heating rate and diffusion coefficient. +C + CALL HINES_HEAT ( HEAT, DIFFCO, + ^ M_ALPHA, V_ALPHA, AK_ALPHA, K_ALPHA, + ^ BVFREQ, DENSITY, DENSB, SIGMA_T, VISC_MOL, + ^ KSTAR, SLOPE, F2, F3, F5, F6, NAZ, + ^ IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH) +C +C Finished. +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_WAVNUM (M_ALPHA,SIGMA_ALPHA,SIGSQH_ALPHA,SIGMA_T, + 1 AK_ALPHA,V_ALPHA,VISC_MOL,DENSITY,DENSB, + 2 BVFREQ,BVFB,RMS_WIND,I_ALPHA,MMIN_ALPHA, + 3 KSTAR,SLOPE,F1,F2,F3,NAZ,LEVBOT,LEVTOP, + 4 IL1,IL2,NLONS,NLEVS,NAZMTH,SIGSQMCW, + 5 SIGMATM,LORMS,SIGALPMC,F2MOD) +C +C This routine calculates the cutoff vertical wavenumber and velocity +C variances on a longitude by altitude grid for the Hines' Doppler +C spread gravity wave drag parameterization scheme. +C NOTE: (1) only values of four or eight can be used for # azimuths (NAZ). +C (2) only values of 1.0, 1.5 or 2.0 can be used for slope (SLOPE). +C +C Aug. 10/95 - C. McLandress +C +C Output arguements: +C +C * M_ALPHA = cutoff wavenumber at each azimuth (1/m). +C * SIGMA_ALPHA = total rms wind in each azimuth (m/s). +C * SIGSQH_ALPHA = portion of wind variance from waves having wave +C * normals in the alpha azimuth (m/s). +C * SIGMA_T = total rms horizontal wind (m/s). +C * AK_ALPHA = spectral amplitude factor at each azimuth +C * (i.e.,{AjKj}) in m^4/s^2. +C +C Input arguements: +C +C * V_ALPHA = wind component at each azimuth (m/s). +C * VISC_MOL = molecular viscosity (m^2/s) +C * DENSITY = background density (kg/m^3). +C * DENSB = background density at model bottom (kg/m^3). +C * BVFREQ = background Brunt Vassala frequency (radians/sec). +C * BVFB = background Brunt Vassala frequency at model bottom. +C * RMS_WIND = root mean square gravity wave wind at lowest level (m/s). +C * KSTAR = typical gravity wave horizontal wavenumber (1/m). +C * SLOPE = slope of incident vertical wavenumber spectrum +C * (SLOPE = 1., 1.5 or 2.). +C * F1,F2,F3 = Hines's fudge factors. +C * NAZ = actual number of horizontal azimuths used (4 or 8). +C * LEVBOT = index of lowest vertical level. +C * LEVTOP = index of highest vertical level +C * (NOTE: if LEVTOP < LEVBOT then level index +C * increases from top down). +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical levels. +C * NAZMTH = azimuthal array dimension (NAZMTH >= NAZ). +C +C * LORMS = .TRUE. for drag computation +C +C Input work arrays: +C +C * I_ALPHA = Hines' integral at a single level. +C * MMIN_ALPHA = minimum value of cutoff wavenumber. +C + INTEGER NAZ, LEVBOT, LEVTOP, IL1, IL2, NLONS, NLEVS, NAZMTH + REAL SLOPE, KSTAR(NLONS), F1, F2, F3 + REAL M_ALPHA(NLONS,NLEVS,NAZMTH) + REAL SIGMA_ALPHA(NLONS,NLEVS,NAZMTH) + REAL SIGALPMC(NLONS,NLEVS,NAZMTH) + REAL SIGSQH_ALPHA(NLONS,NLEVS,NAZMTH) + REAL SIGSQMCW(NLONS,NLEVS,NAZMTH) + REAL SIGMA_T(NLONS,NLEVS) + REAL SIGMATM(NLONS,NLEVS) + REAL AK_ALPHA(NLONS,NAZMTH) + REAL V_ALPHA(NLONS,NLEVS,NAZMTH) + REAL VISC_MOL(NLONS,NLEVS) + REAL F2MOD(NLONS,NLEVS) + REAL DENSITY(NLONS,NLEVS), DENSB(NLONS) + REAL BVFREQ(NLONS,NLEVS), BVFB(NLONS), RMS_WIND(NLONS) + REAL I_ALPHA(NLONS,NAZMTH), MMIN_ALPHA(NLONS,NAZMTH) +C + LOGICAL LORMS(NLONS) +C +C Internal variables. +C + INTEGER I, L, N, LSTART, LEND, LINCR, LBELOW + REAL M_SUB_M_TURB, M_SUB_M_MOL, M_TRIAL + REAL VISC, VISC_MIN, AZFAC, SP1 + +cc REAL N_OVER_M(1000), SIGFAC(1000) + + REAL N_OVER_M(NLONS), SIGFAC(NLONS) + DATA VISC_MIN / 1.E-10 / +C----------------------------------------------------------------------- +C + +C PRINT *,'IN HINES_WAVNUM' + SP1 = SLOPE + 1. +C +C Indices of levels to process. +C + IF (LEVBOT.GT.LEVTOP) THEN + LSTART = LEVBOT - 1 + LEND = LEVTOP + LINCR = -1 + ELSE + write(6,1) + 1 format(2x,' error: IORDER NOT ONE! ') + END IF +C +C Use horizontal isotropy to calculate azimuthal variances at bottom level. +C + AZFAC = 1. / FLOAT(NAZ) + DO 20 N = 1,NAZ + DO 10 I = IL1,IL2 + SIGSQH_ALPHA(I,LEVBOT,N) = AZFAC * RMS_WIND(I)**2 + 10 CONTINUE + 20 CONTINUE +C +C Velocity variances at bottom level. +C + CALL HINES_SIGMA ( SIGMA_T, SIGMA_ALPHA, + ^ SIGSQH_ALPHA, NAZ, LEVBOT, + ^ IL1, IL2, NLONS, NLEVS, NAZMTH) +c + CALL HINES_SIGMA ( SIGMATM, SIGALPMC, + ^ SIGSQMCW, NAZ, LEVBOT, + ^ IL1, IL2, NLONS, NLEVS, NAZMTH) +C +C Calculate cutoff wavenumber and spectral amplitude factor +C at bottom level where it is assumed that background winds vanish +C and also initialize minimum value of cutoff wavnumber. +C + DO 40 N = 1,NAZ + DO 30 I = IL1,IL2 + IF (LORMS(I)) THEN + M_ALPHA(I,LEVBOT,N) = BVFB(I) / + ^ ( F1 * SIGMA_ALPHA(I,LEVBOT,N) + ^ + F2 * SIGMA_T(I,LEVBOT) ) + AK_ALPHA(I,N) = SIGSQH_ALPHA(I,LEVBOT,N) + ^ / ( M_ALPHA(I,LEVBOT,N)**SP1 / SP1 ) + MMIN_ALPHA(I,N) = M_ALPHA(I,LEVBOT,N) + ENDIF + 30 CONTINUE + 40 CONTINUE +C +C Calculate quantities from the bottom upwards, +C starting one level above bottom. +C + DO 150 L = LSTART,LEND,LINCR +C +C Level beneath present level. +C + LBELOW = L - LINCR +C +C Calculate N/m_M where m_M is maximum permissible value of the vertical +C wavenumber (i.e., m > m_M are obliterated) and N is buoyancy frequency. +C m_M is taken as the smaller of the instability-induced +C wavenumber (M_SUB_M_TURB) and that imposed by molecular viscosity +C (M_SUB_M_MOL). Since variance at this level is not yet known +C use value at level below. +C + DO 50 I = IL1,IL2 + IF (LORMS(I)) THEN +c + F2MFAC=SIGMATM(I,LBELOW)**2 + F2MOD(I,LBELOW) =1.+ 2.*F2MFAC + ^ / ( F2MFAC+SIGMA_T(I,LBELOW)**2 ) +c + VISC = AMAX1 ( VISC_MOL(I,L), VISC_MIN ) + M_SUB_M_TURB = BVFREQ(I,L) + ^ / ( F2 *F2MOD(I,LBELOW)*SIGMA_T(I,LBELOW)) + M_SUB_M_MOL = (BVFREQ(I,L)*KSTAR(I)/VISC)**0.33333333/F3 + IF (M_SUB_M_TURB .LT. M_SUB_M_MOL) THEN + N_OVER_M(I) = F2 *F2MOD(I,LBELOW)*SIGMA_T(I,LBELOW) + ELSE + N_OVER_M(I) = BVFREQ(I,L) / M_SUB_M_MOL + END IF + ENDIF + 50 CONTINUE +C +C Calculate cutoff wavenumber at this level. +C + DO 70 N = 1,NAZ + DO 60 I = IL1,IL2 + IF (LORMS(I)) THEN +C +C Calculate trial value (since variance at this level is not yet known +C use value at level below). If trial value is negative or if it exceeds +C minimum value (not permitted) then set it to minimum value. +C + M_TRIAL = BVFB(I) / ( F1 * ( SIGMA_ALPHA(I,LBELOW,N)+ + ^ SIGALPMC(I,LBELOW,N)) + N_OVER_M(I) + V_ALPHA(I,L,N) ) + IF (M_TRIAL.LE.0. .OR. M_TRIAL.GT.MMIN_ALPHA(I,N)) THEN + M_TRIAL = MMIN_ALPHA(I,N) + END IF + M_ALPHA(I,L,N) = M_TRIAL +C +C Reset minimum value of cutoff wavenumber if necessary. +C + IF (M_ALPHA(I,L,N) .LT. MMIN_ALPHA(I,N)) THEN + MMIN_ALPHA(I,N) = M_ALPHA(I,L,N) + END IF +C + ENDIF + 60 CONTINUE + 70 CONTINUE +C +C Calculate the Hines integral at this level. +C + CALL HINES_INTGRL ( I_ALPHA, + ^ V_ALPHA, M_ALPHA, BVFB, SLOPE, NAZ, + ^ L, IL1, IL2, NLONS, NLEVS, NAZMTH, + ^ LORMS ) + +C +C Calculate the velocity variances at this level. +C + DO 80 I = IL1,IL2 + SIGFAC(I) = DENSB(I) / DENSITY(I,L) + ^ * BVFREQ(I,L) / BVFB(I) + 80 CONTINUE + DO 100 N = 1,NAZ + DO 90 I = IL1,IL2 + SIGSQH_ALPHA(I,L,N) = SIGFAC(I) * AK_ALPHA(I,N) + ^ * I_ALPHA(I,N) + 90 CONTINUE + 100 CONTINUE + CALL HINES_SIGMA ( SIGMA_T, SIGMA_ALPHA, + ^ SIGSQH_ALPHA, NAZ, L, + ^ IL1, IL2, NLONS, NLEVS, NAZMTH ) +c + CALL HINES_SIGMA ( SIGMATM, SIGALPMC, + ^ SIGSQMCW, NAZ, L, + ^ IL1, IL2, NLONS, NLEVS, NAZMTH ) +C +C End of level loop. +C + 150 CONTINUE +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_WIND (V_ALPHA,VEL_U,VEL_V, + 1 NAZ,IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH) +C +C This routine calculates the azimuthal horizontal background wind components +C on a longitude by altitude grid for the case of 4 or 8 azimuths for +C the Hines' Doppler spread GWD parameterization scheme. +C +C Aug. 7/95 - C. McLandress +C +C Output arguement: +C +C * V_ALPHA = background wind component at each azimuth (m/s). +C * (note: first azimuth is in eastward direction +C * and rotate in counterclockwise direction.) +C +C Input arguements: +C +C * VEL_U = background zonal wind component (m/s). +C * VEL_V = background meridional wind component (m/s). +C * NAZ = actual number of horizontal azimuths used (must be 4 or 8). +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * LEV1 = first altitude level to use (LEV1 >=1). +C * LEV2 = last altitude level to use (LEV1 < LEV2 <= NLEVS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical levels. +C * NAZMTH = azimuthal array dimension (NAZMTH >= NAZ). +C +C Constants in DATA statements. +C +C * COS45 = cosine of 45 degrees. +C * UMIN = minimum allowable value for zonal or meridional +C * wind component (m/s). +C +C Subroutine arguements. +C + INTEGER NAZ, IL1, IL2, LEV1, LEV2 + INTEGER NLONS, NLEVS, NAZMTH + REAL V_ALPHA(NLONS,NLEVS,NAZMTH) + REAL VEL_U(NLONS,NLEVS), VEL_V(NLONS,NLEVS) +C +C Internal variables. +C + INTEGER I, L + REAL U, V, COS45, UMIN +C + DATA COS45 / 0.7071068 / + DATA UMIN / 0.001 / +C----------------------------------------------------------------------- +C +C Case with 4 azimuths. +C + +C PRINT *,'IN HINES_WIND' + IF (NAZ.EQ.4) THEN + DO 20 L = LEV1,LEV2 + DO 10 I = IL1,IL2 + U = VEL_U(I,L) + V = VEL_V(I,L) + IF (ABS(U) .LT. UMIN) U = UMIN + IF (ABS(V) .LT. UMIN) V = UMIN + V_ALPHA(I,L,1) = U + V_ALPHA(I,L,2) = V + V_ALPHA(I,L,3) = - U + V_ALPHA(I,L,4) = - V + 10 CONTINUE + 20 CONTINUE + END IF +C +C Case with 8 azimuths. +C + IF (NAZ.EQ.8) THEN + DO 40 L = LEV1,LEV2 + DO 30 I = IL1,IL2 + U = VEL_U(I,L) + V = VEL_V(I,L) + IF (ABS(U) .LT. UMIN) U = UMIN + IF (ABS(V) .LT. UMIN) V = UMIN + V_ALPHA(I,L,1) = U + V_ALPHA(I,L,2) = COS45 * ( V + U ) + V_ALPHA(I,L,3) = V + V_ALPHA(I,L,4) = COS45 * ( V - U ) + V_ALPHA(I,L,5) = - U + V_ALPHA(I,L,6) = - V_ALPHA(I,L,2) + V_ALPHA(I,L,7) = - V + V_ALPHA(I,L,8) = - V_ALPHA(I,L,4) + 30 CONTINUE + 40 CONTINUE + END IF +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_FLUX (FLUX_U,FLUX_V,DRAG_U,DRAG_V,ALT,DENSITY, + 1 DENSB,M_ALPHA,AK_ALPHA,K_ALPHA,SLOPE, + 2 NAZ,IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH, + 3 LORMS) +C +C Calculate zonal and meridional components of the vertical flux +C of horizontal momentum and corresponding wave drag (force per unit mass) +C on a longitude by altitude grid for the Hines' Doppler spread +C GWD parameterization scheme. +C NOTE: only 4 or 8 azimuths can be used. +C +C Aug. 6/95 - C. McLandress +C +C Output arguements: +C +C * FLUX_U = zonal component of vertical momentum flux (Pascals) +C * FLUX_V = meridional component of vertical momentum flux (Pascals) +C * DRAG_U = zonal component of drag (m/s^2). +C * DRAG_V = meridional component of drag (m/s^2). +C +C Input arguements: +C +C * ALT = altitudes (m). +C * DENSITY = background density (kg/m^3). +C * DENSB = background density at bottom level (kg/m^3). +C * M_ALPHA = cutoff vertical wavenumber (1/m). +C * AK_ALPHA = spectral amplitude factor (i.e., {AjKj} in m^4/s^2). +C * K_ALPHA = horizontal wavenumber (1/m). +C * SLOPE = slope of incident vertical wavenumber spectrum. +C * NAZ = actual number of horizontal azimuths used (must be 4 or 8). +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * LEV1 = first altitude level to use (LEV1 >=1). +C * LEV2 = last altitude level to use (LEV1 < LEV2 <= NLEVS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical levels. +C * NAZMTH = azimuthal array dimension (NAZMTH >= NAZ). +C +C * LORMS = .TRUE. for drag computation +C +C Constant in DATA statement. +C +C * COS45 = cosine of 45 degrees. +C +C Subroutine arguements. +C + INTEGER NAZ, IL1, IL2, LEV1, LEV2 + INTEGER NLONS, NLEVS, NAZMTH + REAL SLOPE + REAL FLUX_U(NLONS,NLEVS), FLUX_V(NLONS,NLEVS) + REAL DRAG_U(NLONS,NLEVS), DRAG_V(NLONS,NLEVS) + REAL ALT(NLONS,NLEVS), DENSITY(NLONS,NLEVS), DENSB(NLONS) + REAL M_ALPHA(NLONS,NLEVS,NAZMTH) + REAL AK_ALPHA(NLONS,NAZMTH), K_ALPHA(NLONS,NAZMTH) +C + LOGICAL LORMS(NLONS) +C +C Internal variables. +C + INTEGER I, L, LEV1P, LEV2M + REAL COS45, PROD2, PROD4, PROD6, PROD8, DENDZ, DENDZ2 + DATA COS45 / 0.7071068 / +C----------------------------------------------------------------------- +C + LEV1P = LEV1 + 1 + LEV2M = LEV2 - 1 + LEV2P = LEV2 + 1 +C +C Sum over azimuths for case where SLOPE = 1. +C + IF (SLOPE.EQ.1.) THEN +C +C Case with 4 azimuths. +C + IF (NAZ.EQ.4) THEN + DO 20 L = LEV1,LEV2 + DO 10 I = IL1,IL2 + FLUX_U(I,L) = AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1) + ^ - AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3) + FLUX_V(I,L) = AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2) + ^ - AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4) + 10 CONTINUE + 20 CONTINUE + END IF +C +C Case with 8 azimuths. +C + IF (NAZ.EQ.8) THEN + DO 40 L = LEV1,LEV2 + DO 30 I = IL1,IL2 + PROD2 = AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2) + PROD4 = AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4) + PROD6 = AK_ALPHA(I,6)*K_ALPHA(I,6)*M_ALPHA(I,L,6) + PROD8 = AK_ALPHA(I,8)*K_ALPHA(I,8)*M_ALPHA(I,L,8) + FLUX_U(I,L) = + ^ AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1) + ^ - AK_ALPHA(I,5)*K_ALPHA(I,5)*M_ALPHA(I,L,5) + ^ + COS45 * ( PROD2 - PROD4 - PROD6 + PROD8 ) + FLUX_V(I,L) = + ^ AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3) + ^ - AK_ALPHA(I,7)*K_ALPHA(I,7)*M_ALPHA(I,L,7) + ^ + COS45 * ( PROD2 + PROD4 - PROD6 - PROD8 ) + 30 CONTINUE + 40 CONTINUE + END IF +C + END IF +C +C Sum over azimuths for case where SLOPE not equal to 1. +C + IF (SLOPE.NE.1.) THEN +C +C Case with 4 azimuths. +C + IF (NAZ.EQ.4) THEN + DO 60 L = LEV1,LEV2 + DO 50 I = IL1,IL2 + FLUX_U(I,L) = + ^ AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1)**SLOPE + ^ - AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3)**SLOPE + FLUX_V(I,L) = + ^ AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2)**SLOPE + ^ - AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4)**SLOPE + 50 CONTINUE + 60 CONTINUE + END IF +C +C Case with 8 azimuths. +C + IF (NAZ.EQ.8) THEN + DO 80 L = LEV1,LEV2 + DO 70 I = IL1,IL2 + PROD2 = AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2)**SLOPE + PROD4 = AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4)**SLOPE + PROD6 = AK_ALPHA(I,6)*K_ALPHA(I,6)*M_ALPHA(I,L,6)**SLOPE + PROD8 = AK_ALPHA(I,8)*K_ALPHA(I,8)*M_ALPHA(I,L,8)**SLOPE + FLUX_U(I,L) = + ^ AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1)**SLOPE + ^ - AK_ALPHA(I,5)*K_ALPHA(I,5)*M_ALPHA(I,L,5)**SLOPE + ^ + COS45 * ( PROD2 - PROD4 - PROD6 + PROD8 ) + FLUX_V(I,L) = + ^ AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3)**SLOPE + ^ - AK_ALPHA(I,7)*K_ALPHA(I,7)*M_ALPHA(I,L,7)**SLOPE + ^ + COS45 * ( PROD2 + PROD4 - PROD6 - PROD8 ) + 70 CONTINUE + 80 CONTINUE + END IF +C + END IF +C +C Calculate flux from sum. +C + DO 100 L = LEV1,LEV2 + DO 90 I = IL1,IL2 + FLUX_U(I,L) = FLUX_U(I,L) * DENSB(I) / SLOPE + FLUX_V(I,L) = FLUX_V(I,L) * DENSB(I) / SLOPE + 90 CONTINUE + 100 CONTINUE +C +C Calculate drag at intermediate levels using centered differences +C + DO 120 L = LEV1P,LEV2M + DO 110 I = IL1,IL2 + IF (LORMS(I)) THEN +ccc DENDZ2 = DENSITY(I,L) * ( ALT(I,L+1) - ALT(I,L-1) ) + DENDZ2 = DENSITY(I,L) * ( ALT(I,L-1) - ALT(I,L) ) +ccc DRAG_U(I,L) = - ( FLUX_U(I,L+1) - FLUX_U(I,L-1) ) / DENDZ2 + DRAG_U(I,L) = - ( FLUX_U(I,L-1) - FLUX_U(I,L) ) / DENDZ2 +ccc DRAG_V(I,L) = - ( FLUX_V(I,L+1) - FLUX_V(I,L-1) ) / DENDZ2 + DRAG_V(I,L) = - ( FLUX_V(I,L-1) - FLUX_V(I,L) ) / DENDZ2 + + ENDIF + 110 CONTINUE + 120 CONTINUE +C +C Drag at first and last levels using one-side differences. +C + DO 130 I = IL1,IL2 + IF (LORMS(I)) THEN + DENDZ = DENSITY(I,LEV1) * ( ALT(I,LEV1) - ALT(I,LEV1P) ) + DRAG_U(I,LEV1) = FLUX_U(I,LEV1) / DENDZ + DRAG_V(I,LEV1) = FLUX_V(I,LEV1) / DENDZ + ENDIF + 130 CONTINUE + DO 140 I = IL1,IL2 + IF (LORMS(I)) THEN + DENDZ = DENSITY(I,LEV2) * ( ALT(I,LEV2M) - ALT(I,LEV2) ) + DRAG_U(I,LEV2) = - ( FLUX_U(I,LEV2M) - FLUX_U(I,LEV2) ) / DENDZ + DRAG_V(I,LEV2) = - ( FLUX_V(I,LEV2M) - FLUX_V(I,LEV2) ) / DENDZ + ENDIF + 140 CONTINUE + IF (NLEVS .GT. LEV2) THEN + DO 150 I = IL1,IL2 + IF (LORMS(I)) THEN + DENDZ = DENSITY(I,LEV2P) * ( ALT(I,LEV2) - ALT(I,LEV2P) ) + DRAG_U(I,LEV2P) = - FLUX_U(I,LEV2) / DENDZ + DRAG_V(I,LEV2P) = - FLUX_V(I,LEV2) / DENDZ + ENDIF +150 CONTINUE + ENDIF +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_HEAT (HEAT,DIFFCO,M_ALPHA,DMDZ_ALPHA, + 1 AK_ALPHA,K_ALPHA,BVFREQ,DENSITY,DENSB, + 2 SIGMA_T,VISC_MOL,KSTAR,SLOPE,F2,F3,F5,F6, + 3 NAZ,IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH) +C +C This routine calculates the gravity wave induced heating and +C diffusion coefficient on a longitude by altitude grid for +C the Hines' Doppler spread gravity wave drag parameterization scheme. +C +C Aug. 6/95 - C. McLandress +C +C Output arguements: +C +C * HEAT = gravity wave heating (K/sec). +C * DIFFCO = diffusion coefficient (m^2/sec) +C +C Input arguements: +C +C * M_ALPHA = cutoff vertical wavenumber (1/m). +C * DMDZ_ALPHA = vertical derivative of cutoff wavenumber. +C * AK_ALPHA = spectral amplitude factor of each azimuth +C (i.e., {AjKj} in m^4/s^2). +C * K_ALPHA = horizontal wavenumber of each azimuth (1/m). +C * BVFREQ = background Brunt Vassala frequency (rad/sec). +C * DENSITY = background density (kg/m^3). +C * DENSB = background density at bottom level (kg/m^3). +C * SIGMA_T = total rms horizontal wind (m/s). +C * VISC_MOL = molecular viscosity (m^2/s). +C * KSTAR = typical gravity wave horizontal wavenumber (1/m). +C * SLOPE = slope of incident vertical wavenumber spectrum. +C * F2,F3,F5,F6 = Hines's fudge factors. +C * NAZ = actual number of horizontal azimuths used. +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * LEV1 = first altitude level to use (LEV1 >=1). +C * LEV2 = last altitude level to use (LEV1 < LEV2 <= NLEVS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical levels. +C * NAZMTH = azimuthal array dimension (NAZMTH >= NAZ). +C + INTEGER NAZ, IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH + REAL KSTAR(NLONS), SLOPE, F2, F3, F5, F6 + REAL HEAT(NLONS,NLEVS), DIFFCO(NLONS,NLEVS) + REAL M_ALPHA(NLONS,NLEVS,NAZMTH), DMDZ_ALPHA(NLONS,NLEVS,NAZMTH) + REAL AK_ALPHA(NLONS,NAZMTH), K_ALPHA(NLONS,NAZMTH) + REAL BVFREQ(NLONS,NLEVS), DENSITY(NLONS,NLEVS), DENSB(NLONS) + REAL SIGMA_T(NLONS,NLEVS), VISC_MOL(NLONS,NLEVS) +C +C Internal variables. +C + INTEGER I, L, N + REAL M_SUB_M_TURB, M_SUB_M_MOL, M_SUB_M, HEATNG + REAL VISC, VISC_MIN, CPGAS, SM1 +C +C specific heat at constant pressure +C + DATA CPGAS / 1004. / +C +C minimum permissible viscosity +C + DATA VISC_MIN / 1.E-10 / +C----------------------------------------------------------------------- +C +C Initialize heating array. +C + DO 20 L = 1,NLEVS + DO 10 I = 1,NLONS + HEAT(I,L) = 0. + 10 CONTINUE + 20 CONTINUE +C +C Perform sum over azimuths for case where SLOPE = 1. +C + IF (SLOPE.EQ.1.) THEN + DO 50 N = 1,NAZ + DO 40 L = LEV1,LEV2 + DO 30 I = IL1,IL2 + HEAT(I,L) = HEAT(I,L) + AK_ALPHA(I,N) * K_ALPHA(I,N) + ^ * DMDZ_ALPHA(I,L,N) + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +C +C Perform sum over azimuths for case where SLOPE not 1. +C + IF (SLOPE.NE.1.) THEN + SM1 = SLOPE - 1. + DO 80 N = 1,NAZ + DO 70 L = LEV1,LEV2 + DO 60 I = IL1,IL2 + HEAT(I,L) = HEAT(I,L) + AK_ALPHA(I,N) * K_ALPHA(I,N) + ^ * M_ALPHA(I,L,N)**SM1 * DMDZ_ALPHA(I,L,N) + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + END IF +C +C Heating and diffusion. +C + DO 100 L = LEV1,LEV2 + DO 90 I = IL1,IL2 +C +C Maximum permissible value of cutoff wavenumber is the smaller +C of the instability-induced wavenumber (M_SUB_M_TURB) and +C that imposed by molecular viscosity (M_SUB_M_MOL). +C + VISC = AMAX1 ( VISC_MOL(I,L), VISC_MIN ) + M_SUB_M_TURB = BVFREQ(I,L) / ( F2 * SIGMA_T(I,L) ) + M_SUB_M_MOL = (BVFREQ(I,L)*KSTAR(I)/VISC)**0.33333333/F3 + M_SUB_M = AMIN1 ( M_SUB_M_TURB, M_SUB_M_MOL ) +C + HEATNG = - HEAT(I,L) * F5 * BVFREQ(I,L) / M_SUB_M + ^ * DENSB(I) / DENSITY(I,L) + DIFFCO(I,L) = F6 * HEATNG**0.33333333 / M_SUB_M**1.33333333 + HEAT(I,L) = HEATNG / CPGAS +C + 90 CONTINUE + 100 CONTINUE +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_SIGMA (SIGMA_T,SIGMA_ALPHA,SIGSQH_ALPHA, + 1 NAZ,LEV,IL1,IL2,NLONS,NLEVS,NAZMTH) +C +C This routine calculates the total rms and azimuthal rms horizontal +C velocities at a given level on a longitude by altitude grid for +C the Hines' Doppler spread GWD parameterization scheme. +C NOTE: only four or eight azimuths can be used. +C +C Aug. 7/95 - C. McLandress +C +C Output arguements: +C +C * SIGMA_T = total rms horizontal wind (m/s). +C * SIGMA_ALPHA = total rms wind in each azimuth (m/s). +C +C Input arguements: +C +C * SIGSQH_ALPHA = portion of wind variance from waves having wave +C * normals in the alpha azimuth (m/s). +C * NAZ = actual number of horizontal azimuths used (must be 4 or 8). +C * LEV = altitude level to process. +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical levels. +C * NAZMTH = azimuthal array dimension (NAZMTH >= NAZ). +C +C Subroutine arguements. +C + INTEGER LEV, NAZ, IL1, IL2 + INTEGER NLONS, NLEVS, NAZMTH + REAL SIGMA_T(NLONS,NLEVS) + REAL SIGMA_ALPHA(NLONS,NLEVS,NAZMTH) + REAL SIGSQH_ALPHA(NLONS,NLEVS,NAZMTH) +C +C Internal variables. +C + INTEGER I, N + REAL SUM_EVEN, SUM_ODD +C----------------------------------------------------------------------- +C +C Calculate azimuthal rms velocity for the 4 azimuth case. +C + IF (NAZ.EQ.4) THEN + DO 10 I = IL1,IL2 + SIGMA_ALPHA(I,LEV,1) = SQRT ( SIGSQH_ALPHA(I,LEV,1) + ^ + SIGSQH_ALPHA(I,LEV,3) ) + SIGMA_ALPHA(I,LEV,2) = SQRT ( SIGSQH_ALPHA(I,LEV,2) + ^ + SIGSQH_ALPHA(I,LEV,4) ) + SIGMA_ALPHA(I,LEV,3) = SIGMA_ALPHA(I,LEV,1) + SIGMA_ALPHA(I,LEV,4) = SIGMA_ALPHA(I,LEV,2) + 10 CONTINUE + END IF +C +C Calculate azimuthal rms velocity for the 8 azimuth case. +C + IF (NAZ.EQ.8) THEN + DO 20 I = IL1,IL2 + SUM_ODD = ( SIGSQH_ALPHA(I,LEV,1) + ^ + SIGSQH_ALPHA(I,LEV,3) + ^ + SIGSQH_ALPHA(I,LEV,5) + ^ + SIGSQH_ALPHA(I,LEV,7) ) / 2. + SUM_EVEN = ( SIGSQH_ALPHA(I,LEV,2) + ^ + SIGSQH_ALPHA(I,LEV,4) + ^ + SIGSQH_ALPHA(I,LEV,6) + ^ + SIGSQH_ALPHA(I,LEV,8) ) / 2. + SIGMA_ALPHA(I,LEV,1) = SQRT ( SIGSQH_ALPHA(I,LEV,1) + ^ + SIGSQH_ALPHA(I,LEV,5) + SUM_EVEN ) + SIGMA_ALPHA(I,LEV,2) = SQRT ( SIGSQH_ALPHA(I,LEV,2) + ^ + SIGSQH_ALPHA(I,LEV,6) + SUM_ODD ) + SIGMA_ALPHA(I,LEV,3) = SQRT ( SIGSQH_ALPHA(I,LEV,3) + ^ + SIGSQH_ALPHA(I,LEV,7) + SUM_EVEN ) + SIGMA_ALPHA(I,LEV,4) = SQRT ( SIGSQH_ALPHA(I,LEV,4) + ^ + SIGSQH_ALPHA(I,LEV,8) + SUM_ODD ) + SIGMA_ALPHA(I,LEV,5) = SIGMA_ALPHA(I,LEV,1) + SIGMA_ALPHA(I,LEV,6) = SIGMA_ALPHA(I,LEV,2) + SIGMA_ALPHA(I,LEV,7) = SIGMA_ALPHA(I,LEV,3) + SIGMA_ALPHA(I,LEV,8) = SIGMA_ALPHA(I,LEV,4) + 20 CONTINUE + END IF +C +C Calculate total rms velocity. +C + DO 50 I = IL1,IL2 + SIGMA_T(I,LEV) = 0. + 50 CONTINUE + DO 70 N = 1,NAZ + DO 60 I = IL1,IL2 + SIGMA_T(I,LEV) = SIGMA_T(I,LEV) + SIGSQH_ALPHA(I,LEV,N) + 60 CONTINUE + 70 CONTINUE + DO 80 I = IL1,IL2 + SIGMA_T(I,LEV) = SQRT ( SIGMA_T(I,LEV) ) + 80 CONTINUE +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_INTGRL (I_ALPHA,V_ALPHA,M_ALPHA,BVFB,SLOPE, + 1 NAZ,LEV,IL1,IL2,NLONS,NLEVS,NAZMTH, + 2 LORMS) +C +C This routine calculates the vertical wavenumber integral +C for a single vertical level at each azimuth on a longitude grid +C for the Hines' Doppler spread GWD parameterization scheme. +C NOTE: (1) only spectral slopes of 1, 1.5 or 2 are permitted. +C (2) the integral is written in terms of the product QM +C which by construction is always less than 1. Series +C solutions are used for small |QM| and analytical solutions +C for remaining values. +C +C Aug. 8/95 - C. McLandress +C +C Output arguement: +C +C * I_ALPHA = Hines' integral. +C +C Input arguements: +C +C * V_ALPHA = azimuthal wind component (m/s). +C * M_ALPHA = azimuthal cutoff vertical wavenumber (1/m). +C * BVFB = background Brunt Vassala frequency at model bottom. +C * SLOPE = slope of initial vertical wavenumber spectrum +C * (must use SLOPE = 1., 1.5 or 2.) +C * NAZ = actual number of horizontal azimuths used. +C * LEV = altitude level to process. +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical levels. +C * NAZMTH = azimuthal array dimension (NAZMTH >= NAZ). +C +C * LORMS = .TRUE. for drag computation +C +C Constants in DATA statements: +C +C * QMIN = minimum value of Q_ALPHA (avoids indeterminant form of integral) +C * QM_MIN = minimum value of Q_ALPHA * M_ALPHA (used to avoid numerical +C * problems). +C + INTEGER LEV, NAZ, IL1, IL2, NLONS, NLEVS, NAZMTH + REAL I_ALPHA(NLONS,NAZMTH) + REAL V_ALPHA(NLONS,NLEVS,NAZMTH) + REAL M_ALPHA(NLONS,NLEVS,NAZMTH) + REAL BVFB(NLONS), SLOPE +C + LOGICAL LORMS(NLONS) +C +C Internal variables. +C + INTEGER I, N + REAL Q_ALPHA, QM, SQRTQM, Q_MIN, QM_MIN +C + DATA Q_MIN / 1.0 /, QM_MIN / 0.01 / +C----------------------------------------------------------------------- +C +C For integer value SLOPE = 1. +C + IF (SLOPE .EQ. 1.) THEN +C + DO 20 N = 1,NAZ + DO 10 I = IL1,IL2 + IF (LORMS(I)) THEN +C + Q_ALPHA = V_ALPHA(I,LEV,N) / BVFB(I) + QM = Q_ALPHA * M_ALPHA(I,LEV,N) +C +C If |QM| is small then use first 4 terms series of Taylor series +C expansion of integral in order to avoid indeterminate form of integral, +C otherwise use analytical form of integral. +C + IF (ABS(Q_ALPHA).LT.Q_MIN .OR. ABS(QM).LT.QM_MIN) THEN + IF (Q_ALPHA .EQ. 0.) THEN + I_ALPHA(I,N) = M_ALPHA(I,LEV,N)**2 / 2. + ELSE + I_ALPHA(I,N) = ( QM**2/2. + QM**3/3. + QM**4/4. + ^ + QM**5/5. ) / Q_ALPHA**2 + END IF + ELSE + I_ALPHA(I,N) = - ( ALOG(1.-QM) + QM ) / Q_ALPHA**2 + END IF +C + ENDIF + 10 CONTINUE + 20 CONTINUE +C + END IF +C +C For integer value SLOPE = 2. +C + IF (SLOPE .EQ. 2.) THEN +C + DO 40 N = 1,NAZ + DO 30 I = IL1,IL2 + IF (LORMS(I)) THEN +C + Q_ALPHA = V_ALPHA(I,LEV,N) / BVFB(I) + QM = Q_ALPHA * M_ALPHA(I,LEV,N) +C +C If |QM| is small then use first 4 terms series of Taylor series +C expansion of integral in order to avoid indeterminate form of integral, +C otherwise use analytical form of integral. +C + IF (ABS(Q_ALPHA).LT.Q_MIN .OR. ABS(QM).LT.QM_MIN) THEN + IF (Q_ALPHA .EQ. 0.) THEN + I_ALPHA(I,N) = M_ALPHA(I,LEV,N)**3 / 3. + ELSE + I_ALPHA(I,N) = ( QM**3/3. + QM**4/4. + QM**5/5. + ^ + QM**6/6. ) / Q_ALPHA**3 + END IF + ELSE + I_ALPHA(I,N) = - ( ALOG(1.-QM) + QM + QM**2/2.) + ^ / Q_ALPHA**3 + END IF +C + ENDIF + 30 CONTINUE + 40 CONTINUE +C + END IF +C +C For real value SLOPE = 1.5 +C + IF (SLOPE .EQ. 1.5) THEN +C + DO 60 N = 1,NAZ + DO 50 I = IL1,IL2 + IF (LORMS(I)) THEN +C + Q_ALPHA = V_ALPHA(I,LEV,N) / BVFB(I) + QM = Q_ALPHA * M_ALPHA(I,LEV,N) +C +C If |QM| is small then use first 4 terms series of Taylor series +C expansion of integral in order to avoid indeterminate form of integral, +C otherwise use analytical form of integral. +C + IF (ABS(Q_ALPHA).LT.Q_MIN .OR. ABS(QM).LT.QM_MIN) THEN + IF (Q_ALPHA .EQ. 0.) THEN + I_ALPHA(I,N) = M_ALPHA(I,LEV,N)**2.5 / 2.5 + ELSE + I_ALPHA(I,N) = ( QM/2.5 + QM**2/3.5 + ^ + QM**3/4.5 + QM**4/5.5 ) + ^ * M_ALPHA(I,LEV,N)**1.5 / Q_ALPHA + END IF + ELSE + QM = ABS(QM) + SQRTQM = SQRT(QM) + IF (Q_ALPHA .GE. 0.) THEN + I_ALPHA(I,N) = ( ALOG( (1.+SQRTQM)/(1.-SQRTQM) ) + ^ -2.*SQRTQM*(1.+QM/3.) ) / Q_ALPHA**2.5 + ELSE + I_ALPHA(I,N) = 2. * ( ATAN(SQRTQM) + SQRTQM*(QM/3.-1.) ) + ^ / ABS(Q_ALPHA)**2.5 + END IF + END IF +C + ENDIF + 50 CONTINUE + 60 CONTINUE +C + END IF +C +C If integral is negative (which in principal should not happen) then +C print a message and some info since execution will abort when calculating +C the variances. +C +c DO 80 N = 1,NAZ +c DO 70 I = IL1,IL2 +c IF (I_ALPHA(I,N).LT.0.) THEN +c WRITE (6,*) +c WRITE (6,*) '******************************' +c WRITE (6,*) 'Hines integral I_ALPHA < 0 ' +c WRITE (6,*) ' longitude I=',I +c WRITE (6,*) ' azimuth N=',N +c WRITE (6,*) ' level LEV=',LEV +c WRITE (6,*) ' I_ALPHA =',I_ALPHA(I,N) +c WRITE (6,*) ' V_ALPHA =',V_ALPHA(I,LEV,N) +c WRITE (6,*) ' M_ALPHA =',M_ALPHA(I,LEV,N) +c WRITE (6,*) ' Q_ALPHA =',V_ALPHA(I,LEV,N) / BVFB(I) +c WRITE (6,*) ' QM =',V_ALPHA(I,LEV,N) / BVFB(I) +c ^ * M_ALPHA(I,LEV,N) +c WRITE (6,*) '******************************' +c END IF +c 70 CONTINUE +c 80 CONTINUE +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_SETUP (NAZ,SLOPE,F1,F2,F3,F5,F6,KSTAR, + 1 ICUTOFF,ALT_CUTOFF,SMCO,NSMAX,IHEATCAL, + 2 K_ALPHA,IERROR,NMESSG,NLONS,NAZMTH,COSLAT) +C +C This routine specifies various parameters needed for the +C the Hines' Doppler spread gravity wave drag parameterization scheme. +C +C Aug. 8/95 - C. McLandress +C +C Output arguements: +C +C * NAZ = actual number of horizontal azimuths used +C * (code set up presently for only NAZ = 4 or 8). +C * SLOPE = slope of incident vertical wavenumber spectrum +C * (code set up presently for SLOPE 1., 1.5 or 2.). +C * F1 = "fudge factor" used in calculation of trial value of +C * azimuthal cutoff wavenumber M_ALPHA (1.2 <= F1 <= 1.9). +C * F2 = "fudge factor" used in calculation of maximum +C * permissible instabiliy-induced cutoff wavenumber +C * M_SUB_M_TURB (0.1 <= F2 <= 1.4). +C * F3 = "fudge factor" used in calculation of maximum +C * permissible molecular viscosity-induced cutoff wavenumber +C * M_SUB_M_MOL (0.1 <= F2 <= 1.4). +C * F5 = "fudge factor" used in calculation of heating rate +C * (1 <= F5 <= 3). +C * F6 = "fudge factor" used in calculation of turbulent +C * diffusivity coefficient. +C * KSTAR = typical gravity wave horizontal wavenumber (1/m) +C * used in calculation of M_SUB_M_TURB. +C * ICUTOFF = 1 to exponentially damp off GWD, heating and diffusion +C * arrays above ALT_CUTOFF; otherwise arrays not modified. +C * ALT_CUTOFF = altitude in meters above which exponential decay applied. +C * SMCO = smoother used to smooth cutoff vertical wavenumbers +C * and total rms winds before calculating drag or heating. +C * (==> a 1:SMCO:1 stencil used; SMCO >= 1.). +C * NSMAX = number of times smoother applied ( >= 1), +C * = 0 means no smoothing performed. +C * IHEATCAL = 1 to calculate heating rates and diffusion coefficient. +C * = 0 means only drag and flux calculated. +C * K_ALPHA = horizontal wavenumber of each azimuth (1/m) which +C * is set here to KSTAR. +C * IERROR = error flag. +C * = 0 no errors. +C * = 10 ==> NAZ > NAZMTH +C * = 20 ==> invalid number of azimuths (NAZ must be 4 or 8). +C * = 30 ==> invalid slope (SLOPE must be 1., 1.5 or 2.). +C * = 40 ==> invalid smoother (SMCO must be >= 1.) +C +C Input arguements: +C +C * NMESSG = output unit number where messages to be printed. +C * NLONS = number of longitudes. +C * NAZMTH = azimuthal array dimension (NAZMTH >= NAZ). +C + INTEGER NAZ, NLONS, NAZMTH, IHEATCAL, ICUTOFF + INTEGER NMESSG, NSMAX, IERROR + REAL KSTAR(NLONS), SLOPE, F1, F2, F3, F5, F6, ALT_CUTOFF, SMCO + REAL K_ALPHA(NLONS,NAZMTH),COSLAT(NLONS) + REAL KSMIN, KSMAX +C +C Internal variables. +C + INTEGER I, N +C----------------------------------------------------------------------- +C +C Specify constants. +C + NAZ = 8 + SLOPE = 1. + F1 = 1.5 + F2 = 0.3 + F3 = 1.0 + F5 = 3.0 + F6 = 1.0 + KSMIN = 1.E-5 + KSMAX = 1.E-4 + DO I=1,NLONS + KSTAR(I) = KSMIN/( COSLAT(I)+(KSMIN/KSMAX) ) + ENDDO + ICUTOFF = 1 + ALT_CUTOFF = 105.E3 + SMCO = 2.0 +c SMCO = 1.0 + NSMAX = 5 +c NSMAX = 2 + IHEATCAL = 0 +C +C Print information to output file. +C +c WRITE (NMESSG,6000) +c 6000 FORMAT (/' Subroutine HINES_SETUP:') +c WRITE (NMESSG,*) ' SLOPE = ', SLOPE +c WRITE (NMESSG,*) ' NAZ = ', NAZ +c WRITE (NMESSG,*) ' F1,F2,F3 = ', F1, F2, F3 +c WRITE (NMESSG,*) ' F5,F6 = ', F5, F6 +c WRITE (NMESSG,*) ' KSTAR = ', KSTAR +c > ,' COSLAT = ', COSLAT +c IF (ICUTOFF .EQ. 1) THEN +c WRITE (NMESSG,*) ' Drag exponentially damped above ', +c & ALT_CUTOFF/1.E3 +c END IF +c IF (NSMAX.LT.1 ) THEN +c WRITE (NMESSG,*) ' No smoothing of cutoff wavenumbers, etc' +c ELSE +c WRITE (NMESSG,*) ' Cutoff wavenumbers and sig_t smoothed:' +c WRITE (NMESSG,*) ' SMCO =', SMCO +c WRITE (NMESSG,*) ' NSMAX =', NSMAX +c END IF +C +C Check that things are setup correctly and log error if not +C + IERROR = 0 + IF (NAZ .GT. NAZMTH) IERROR = 10 + IF (NAZ.NE.4 .AND. NAZ.NE.8) IERROR = 20 + IF (SLOPE.NE.1. .AND. SLOPE.NE.1.5 .AND. SLOPE.NE.2.) IERROR = 30 + IF (SMCO .LT. 1.) IERROR = 40 +C +C Use single value for azimuthal-dependent horizontal wavenumber. +C + DO 20 N = 1,NAZ + DO 10 I = 1,NLONS + K_ALPHA(I,N) = KSTAR(I) + 10 CONTINUE + 20 CONTINUE +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_PRINT (FLUX_U,FLUX_V,DRAG_U,DRAG_V,ALT,SIGMA_T, + 1 SIGMA_ALPHA,V_ALPHA,M_ALPHA, + 2 IU_PRINT,IV_PRINT,NMESSG, + 3 ILPRT1,ILPRT2,LEVPRT1,LEVPRT2, + 4 NAZ,NLONS,NLEVS,NAZMTH) +C +C Print out altitude profiles of various quantities from +C Hines' Doppler spread gravity wave drag parameterization scheme. +C (NOTE: only for NAZ = 4 or 8). +C +C Aug. 8/95 - C. McLandress +C +C Input arguements: +C +C * IU_PRINT = 1 to print out values in east-west direction. +C * IV_PRINT = 1 to print out values in north-south direction. +C * NMESSG = unit number for printed output. +C * ILPRT1 = first longitudinal index to print. +C * ILPRT2 = last longitudinal index to print. +C * LEVPRT1 = first altitude level to print. +C * LEVPRT2 = last altitude level to print. +C + INTEGER NAZ, ILPRT1, ILPRT2, LEVPRT1, LEVPRT2 + INTEGER NLONS, NLEVS, NAZMTH + INTEGER IU_PRINT, IV_PRINT, NMESSG + REAL FLUX_U(NLONS,NLEVS), FLUX_V(NLONS,NLEVS) + REAL DRAG_U(NLONS,NLEVS), DRAG_V(NLONS,NLEVS) + REAL ALT(NLONS,NLEVS), SIGMA_T(NLONS,NLEVS) + REAL SIGMA_ALPHA(NLONS,NLEVS,NAZMTH) + REAL V_ALPHA(NLONS,NLEVS,NAZMTH), M_ALPHA(NLONS,NLEVS,NAZMTH) +C +C Internal variables. +C + INTEGER N_EAST, N_WEST, N_NORTH, N_SOUTH + INTEGER I, L +C----------------------------------------------------------------------- +C +C Azimuthal indices of cardinal directions. +C + N_EAST = 1 + IF (NAZ.EQ.4) THEN + N_WEST = 3 + N_NORTH = 2 + N_SOUTH = 4 + ELSE IF (NAZ.EQ.8) THEN + N_WEST = 5 + N_NORTH = 3 + N_SOUTH = 7 + END IF +C +C Print out values for range of longitudes. +C + DO 100 I = ILPRT1,ILPRT2 +C +C Print east-west wind, sigmas, cutoff wavenumbers, flux and drag. +C + IF (IU_PRINT.EQ.1) THEN + WRITE (NMESSG,*) + WRITE (NMESSG,6001) I + WRITE (NMESSG,6005) + 6001 FORMAT ( 'Hines GW (east-west) at longitude I =',I3) + 6005 FORMAT (15x,' U ',2x,'sig_E',2x,'sig_T',3x,'m_E', + & 4x,'m_W',4x,'fluxU',5x,'gwdU') + DO 10 L = LEVPRT1,LEVPRT2 + WRITE (NMESSG,6701) ALT(I,L)/1.E3, V_ALPHA(I,L,N_EAST), + & SIGMA_ALPHA(I,L,N_EAST), SIGMA_T(I,L), + & M_ALPHA(I,L,N_EAST)*1.E3, + & M_ALPHA(I,L,N_WEST)*1.E3, + & FLUX_U(I,L)*1.E5, DRAG_U(I,L)*24.*3600. + 10 CONTINUE + 6701 FORMAT (' z=',f7.2,1x,3f7.1,2f7.3,f9.4,f9.3) + END IF +C +C Print north-south winds, sigmas, cutoff wavenumbers, flux and drag. +C + IF (IV_PRINT.EQ.1) THEN + WRITE(NMESSG,*) + WRITE(NMESSG,6002) I + 6002 FORMAT ( 'Hines GW (north-south) at longitude I =',I3) + WRITE(NMESSG,6006) + 6006 FORMAT (15x,' V ',2x,'sig_N',2x,'sig_T',3x,'m_N', + & 4x,'m_S',4x,'fluxV',5x,'gwdV') + DO 20 L = LEVPRT1,LEVPRT2 + WRITE (NMESSG,6701) ALT(I,L)/1.E3, V_ALPHA(I,L,N_NORTH), + & SIGMA_ALPHA(I,L,N_NORTH), SIGMA_T(I,L), + & M_ALPHA(I,L,N_NORTH)*1.E3, + & M_ALPHA(I,L,N_SOUTH)*1.E3, + & FLUX_V(I,L)*1.E5, DRAG_V(I,L)*24.*3600. + 20 CONTINUE + END IF +C + 100 CONTINUE +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_EXP (DATA,DATA_ZMAX,ALT,ALT_EXP,IORDER, + 1 IL1,IL2,LEV1,LEV2,NLONS,NLEVS) +C +C This routine exponentially damps a longitude by altitude array +C of data above a specified altitude. +C +C Aug. 13/95 - C. McLandress +C +C Output arguements: +C +C * DATA = modified data array. +C +C Input arguements: +C +C * DATA = original data array. +C * ALT = altitudes. +C * ALT_EXP = altitude above which exponential decay applied. +C * IORDER = 1 means vertical levels are indexed from top down +C * (i.e., highest level indexed 1 and lowest level NLEVS); +C * .NE. 1 highest level is index NLEVS. +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * LEV1 = first altitude level to use (LEV1 >=1). +C * LEV2 = last altitude level to use (LEV1 < LEV2 <= NLEVS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical +C +C Input work arrays: +C +C * DATA_ZMAX = data values just above altitude ALT_EXP. +C + INTEGER IORDER, IL1, IL2, LEV1, LEV2, NLONS, NLEVS + REAL ALT_EXP + REAL DATA(NLONS,NLEVS), DATA_ZMAX(NLONS), ALT(NLONS,NLEVS) +C +C Internal variables. +C + INTEGER LEVBOT, LEVTOP, LINCR, I, L + REAL HSCALE + DATA HSCALE / 5.E3 / +C----------------------------------------------------------------------- +C +C Index of lowest altitude level (bottom of drag calculation). +C + LEVBOT = LEV2 + LEVTOP = LEV1 + LINCR = 1 + IF (IORDER.NE.1) THEN + LEVBOT = LEV1 + LEVTOP = LEV2 + LINCR = -1 + END IF +C +C Data values at first level above ALT_EXP. +C + DO 20 I = IL1,IL2 + DO 10 L = LEVTOP,LEVBOT,LINCR + IF (ALT(I,L) .GE. ALT_EXP) THEN + DATA_ZMAX(I) = DATA(I,L) + END IF + 10 CONTINUE + 20 CONTINUE +C +C Exponentially damp field above ALT_EXP to model top at L=1. +C + DO 40 L = 1,LEV2 + DO 30 I = IL1,IL2 + IF (ALT(I,L) .GE. ALT_EXP) THEN + DATA(I,L) = DATA_ZMAX(I) * EXP( (ALT_EXP-ALT(I,L))/HSCALE ) + END IF + 30 CONTINUE + 40 CONTINUE +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE VERT_SMOOTH (DATA,WORK,COEFF,NSMOOTH, + 1 IL1,IL2,LEV1,LEV2,NLONS,NLEVS) +C +C Smooth a longitude by altitude array in the vertical over a +C specified number of levels using a three point smoother. +C +C NOTE: input array DATA is modified on output! +C +C Aug. 3/95 - C. McLandress +C +C Output arguement: +C +C * DATA = smoothed array (on output). +C +C Input arguements: +C +C * DATA = unsmoothed array of data (on input). +C * WORK = work array of same dimension as DATA. +C * COEFF = smoothing coefficient for a 1:COEFF:1 stencil. +C * (e.g., COEFF = 2 will result in a smoother which +C * weights the level L gridpoint by two and the two +C * adjecent levels (L+1 and L-1) by one). +C * NSMOOTH = number of times to smooth in vertical. +C * (e.g., NSMOOTH=1 means smoothed only once, +C * NSMOOTH=2 means smoothing repeated twice, etc.) +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * LEV1 = first altitude level to use (LEV1 >=1). +C * LEV2 = last altitude level to use (LEV1 < LEV2 <= NLEVS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical levels. +C +C Subroutine arguements. +C + INTEGER NSMOOTH, IL1, IL2, LEV1, LEV2, NLONS, NLEVS + REAL COEFF + REAL DATA(NLONS,NLEVS), WORK(NLONS,NLEVS) +C +C Internal variables. +C + INTEGER I, L, NS, LEV1P, LEV2M + REAL SUM_WTS +C----------------------------------------------------------------------- +C +C Calculate sum of weights. +C + SUM_WTS = COEFF + 2. +C + LEV1P = LEV1 + 1 + LEV2M = LEV2 - 1 +C +C Smooth NSMOOTH times +C + DO 50 NS = 1,NSMOOTH +C +C Copy data into work array. +C + DO 20 L = LEV1,LEV2 + DO 10 I = IL1,IL2 + WORK(I,L) = DATA(I,L) + 10 CONTINUE + 20 CONTINUE +C +C Smooth array WORK in vertical direction and put into DATA. +C + DO 40 L = LEV1P,LEV2M + DO 30 I = IL1,IL2 + DATA(I,L) = ( WORK(I,L+1) + COEFF*WORK(I,L) + WORK(I,L-1) ) + & / SUM_WTS + 30 CONTINUE + 40 CONTINUE +C + 50 CONTINUE +C + RETURN +C----------------------------------------------------------------------- + END + + + + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/histo_o500_pctau.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/histo_o500_pctau.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/histo_o500_pctau.F (revision 1280) @@ -0,0 +1,67 @@ +! +! $Header$ +! + SUBROUTINE histo_o500_pctau(nbreg,pct_ocean,w,histo,histoW,nhisto) + USE dimphy + IMPLICIT none + + INTEGER :: ij, k, l, nw + INTEGER :: nreg, nbreg +cym#include "dimensions.h" +cym#include "dimphy.h" + INTEGER, PARAMETER :: kmax=8, lmax=8 + INTEGER, PARAMETER :: kmaxm1=kmax-1, lmaxm1=lmax-1 + INTEGER, PARAMETER :: iwmax=40 + + INTEGER, dimension(klon) :: iw + REAL, dimension(klon) :: w + REAL, PARAMETER :: wmin=-200., pas_w=10. + REAL, dimension(kmaxm1,lmaxm1,iwmax,nbreg) :: histoW, nhisto + REAL, dimension(klon,kmaxm1,lmaxm1) :: histo + +! LOGICAL, dimension(klon,nbreg) :: pct_ocean + INTEGER, dimension(klon,nbreg) :: pct_ocean + +! initialisation + histoW(:,:,:,:)=0. + nhisto(:,:,:,:)=0. +! +!calcul de l'histogramme de chaque regime dynamique + DO nreg=1, nbreg + DO ij=1, klon + iw(ij) = int((w(ij)-wmin)/pas_w) +1 +c IF(pct_ocean(ij,nreg)) THEN +c IF(pct_ocean(ij,nreg).EQ.1) THEN + IF(iw(ij).GE.1.AND.iw(ij).LE.iwmax) THEN + DO l=1, lmaxm1 + DO k=1, kmaxm1 + IF(histo(ij,k,l).GT.0.) THEN + histoW(k,l,iw(ij),nreg) = histoW(k,l,iw(ij),nreg) + & + histo(ij,k,l)*pct_ocean(ij,nreg) + nhisto(k,l,iw(ij),nreg)= nhisto(k,l,iw(ij),nreg) + + & pct_ocean(ij,nreg) + ENDIF + ENDDO !k + ENDDO !l +c ELSE IF (iw(ij).LE.0.OR.iw(ij).GT.iwmax) THEN !iw +c PRINT*,'ij,iw=',ij,iw(ij) + ENDIF !iw +c ENDIF !pct_ocean + ENDDO !ij +!normalisation + DO nw=1, iwmax + DO l=1, lmaxm1 + DO k=1, kmaxm1 + IF(nhisto(k,l,nw,nreg).NE.0.) THEN + histoW(k,l,nw,nreg) = 100.*histoW(k,l,nw,nreg) + & /nhisto(k,l,nw,nreg) +c PRINT*,'k,l,nw,nreg,histoW',k,l,nw,nreg, +c & histoW(k,l,nw,nreg) + ENDIF + ENDDO !k + ENDDO !l + ENDDO !nw + ENDDO !nreg + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/homogene.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/homogene.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/homogene.F (revision 1280) @@ -0,0 +1,100 @@ +! +! $Header$ +! + SUBROUTINE homogene(paprs, q, dq, u,v, du, dv) + USE dimphy + IMPLICIT NONE +c============================================================== +c Schema ad hoc du melange vertical pour les vitesses u et v, +c a appliquer apres le schema de convection (fiajc et fiajh). +c +c paprs:input, pression demi-couche (inter-couche) +c q: input, vapeur d'eau (kg/kg) +c dq: input, incrementation de vapeur d'eau (de la convection) +c u: input, vitesse u +c v: input, vitesse v +c +c du: output, incrementation pour u +c dv: output, incrementation pour v +c============================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +c + REAL paprs(klon,klev+1) + REAL q(klon,klev), dq(klon,klev) + REAL u(klon,klev), du(klon,klev) + REAL v(klon,klev), dv(klon,klev) +c + REAL zm_dq(klon) ! quantite totale de l'eau deplacee + REAL zm_q(klon) ! quantite totale de la vapeur d'eau + REAL zm_u(klon) ! moyenne de u (brassage parfait et total) + REAL zm_v(klon) ! moyenne de v (brassage parfait et total) + REAL z_frac(klon) ! fraction du brassage parfait et total + REAL zm_dp(klon) +c + REAL zx + INTEGER i, k + REAL frac_max + PARAMETER (frac_max=0.1) + REAL seuil + PARAMETER (seuil=1.0e-10) + LOGICAL faisrien + PARAMETER (faisrien=.true.) +c + DO k = 1, klev + DO i = 1, klon + du(i,k) = 0.0 + dv(i,k) = 0.0 + ENDDO + ENDDO +c + IF (faisrien) RETURN +c + DO i = 1, klon + zm_dq(i)=0. + zm_q(i) =0. + zm_u(i)=0. + zm_v(i)=0. + zm_dp(i)=0. + ENDDO + DO k = 1, klev + DO i = 1, klon + IF (ABS(dq(i,k)).GT.seuil) THEN + zx = paprs(i,k) - paprs(i,k+1) + zm_dq(i) = zm_dq(i) + ABS(dq(i,k))*zx + zm_q(i) = zm_q(i) + q(i,k)*zx + zm_dp(i) = zm_dp(i) + zx + zm_u(i) = zm_u(i) + u(i,k)*zx + zm_v(i) = zm_v(i) + v(i,k)*zx + ENDIF + ENDDO + ENDDO +c +c Hypothese principale: apres la convection, la vitesse de chaque +c couche est composee de deux parties: celle (1-z_frac) de la vitesse +c original et celle (z_frac) de la vitesse moyenne qui serait la +c vitesse de chaque couche si le brassage etait parfait et total. +c La fraction du brassage est calculee par le rapport entre la quantite +c totale de la vapeur d'eau deplacee (ou condensee) et la quantite +c totale de la vapeur d'eau. Et cette fraction est limitee a frac_max +c (Est-ce vraiment raisonnable ? Z.X. Li, le 07-09-1995). +c + DO i = 1, klon + IF (zm_dp(i).GE.1.0E-15 .AND. zm_q(i).GE.1.0E-15) THEN + z_frac(i)=MIN(frac_max,zm_dq(i)/zm_q(i)) + zm_u(i)=zm_u(i)/zm_dp(i) + zm_v(i)=zm_v(i)/zm_dp(i) + ENDIF + ENDDO + DO k = 1, klev + DO i = 1, klon + IF (zm_dp(i).GE.1.e-15 .AND. zm_q(i).GE.1.e-15 + . .AND. ABS(dq(i,k)).GT.seuil) THEN + du(i,k) = u(i,k)*(1.-z_frac(i)) + zm_u(i)*z_frac(i) - u(i,k) + dv(i,k) = v(i,k)*(1.-z_frac(i)) + zm_v(i)*z_frac(i) - v(i,k) + ENDIF + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/hydrol.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/hydrol.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/hydrol.F (revision 1280) @@ -0,0 +1,121 @@ +! +! $Header$ +! +c +c + SUBROUTINE hydrol(dtime,pctsrf,rain_fall,snow_fall,evap, + . agesno, tsol,qsol,snow,runoff) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) +c date: 19940414 +c====================================================================== +c +c Traitement de l'hydrologie du sol +c --------------------------------- +c rain_fall: taux de pluie +c snow_fall: taux de neige +c agesno: age de la neige +c evap: taux d'evaporation +c tsol: temperature du sol +c qsol: humidite du sol +c snow: couverture neigeuse +C +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "indicesol.h" +c + REAL chasno ! epaisseur du sol: 0.15 m + PARAMETER (chasno=3.334E+05/(2.3867E+06*0.15)) + REAL mx_eau_sol + PARAMETER (mx_eau_sol=150.0) +c + REAL dtime + REAL pctsrf(klon,nbsrf) + REAL snow(klon,nbsrf), tsol(klon,nbsrf), qsol(klon,nbsrf) + REAL snow_fall(klon), rain_fall(klon), evap(klon) + REAL runoff(klon), agesno(klon) +C + INTEGER i, is + REAL subli, fsno +C----------------------------------------------------------------------- + DO 99999 i = 1, klon +c + runoff(i) = 0.0 +c + is = is_ter + snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is) + IF (pctsrf(i,is) .GT. epsfra) THEN + subli = MIN(evap(i)*dtime,snow(i,is)) + snow(i,is) = snow(i,is) - subli + fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is)) + snow(i,is) = snow(i,is) - fsno + tsol(i,is) = tsol(i,is) - fsno*chasno + qsol(i,is) = qsol(i,is) + (rain_fall(i)-evap(i))*dtime + . + subli + fsno + qsol(i,is) = MAX(qsol(i,is),0.0) + runoff(i) = runoff(i) + MAX(qsol(i,is)-mx_eau_sol, 0.0) + . * pctsrf(i,is) + qsol(i,is) = MIN(qsol(i,is),mx_eau_sol) +ccc ELSE +ccc snow(i,is) = 0.0 +ccc qsol(i,is) = 0.0 +ccc tsol(i,is) = 0.0 + ENDIF +c + is = is_lic + snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is) + IF (pctsrf(i,is) .GT. epsfra) THEN + subli = MIN(evap(i)*dtime,snow(i,is)) + snow(i,is) = snow(i,is) - subli + fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is)) + snow(i,is) = snow(i,is) - fsno + tsol(i,is) = tsol(i,is) - fsno*chasno + qsol(i,is) = qsol(i,is) + (rain_fall(i)-evap(i))*dtime + . + subli + fsno + qsol(i,is) = MAX(qsol(i,is),0.0) + runoff(i) = runoff(i) + MAX(qsol(i,is)-mx_eau_sol, 0.0) + . * pctsrf(i,is) + qsol(i,is) = MIN(qsol(i,is),mx_eau_sol) +c je limite la temperature a RTT-1.8 (il faudrait aussi prendre l'eau de +c la fonte) (Laurent Li, le 14mars98): +cIM cf GK tsol(i,is) = MIN(tsol(i,is),RTT-1.8) +cIM cf GK : la glace fond a 0C, non pas a -1.8 + tsol(i,is) = MIN(tsol(i,is),RTT) +c +ccc ELSE +ccc snow(i,is) = 0.0 +ccc qsol(i,is) = 0.0 +ccc tsol(i,is) = 0.0 + ENDIF +c + is = is_sic + qsol(i,is) = 0.0 + snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is) + IF (pctsrf(i,is) .GT. epsfra) THEN + subli = MIN(evap(i)*dtime,snow(i,is)) + snow(i,is) = snow(i,is) - subli + fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is)) + snow(i,is) = snow(i,is) - fsno + tsol(i,is) = tsol(i,is) - fsno*chasno +c je limite la temperature a RTT-1.8 (il faudrait aussi prendre l'eau de +c la fonte) (Laurent Li, le 14mars98): +cIM cf GK tsol(i,is) = MIN(tsol(i,is),RTT-1.8) +cIM cf GK : la glace fond a 0C, non pas a -1.8 + tsol(i,is) = MIN(tsol(i,is),RTT) +c +ccc ELSE +ccc snow(i,is) = 0.0 +ccc tsol(i,is) = 0.0 + ENDIF +c + agesno(i) = (agesno(i)+ (1.-agesno(i)/50.)*dtime/86400.) + . * EXP(-1.*MAX(0.0,snow_fall(i))*dtime/0.3) + agesno(i) = MAX(agesno(i),0.0) +c +99999 CONTINUE +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/indicesol.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/indicesol.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/indicesol.h (revision 1280) @@ -0,0 +1,29 @@ +! +! $Header$ +! +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez à n'utiliser que des ! pour les commentaires +! et à bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! + INTEGER nbsrf + PARAMETER (nbsrf=4) ! nombre de sous-fractions pour une maille +! + INTEGER is_oce + PARAMETER (is_oce=3) ! ocean + INTEGER is_sic + PARAMETER (is_sic=4) ! glace de mer + INTEGER is_ter + PARAMETER (is_ter=1) ! terre + INTEGER is_lic + PARAMETER (is_lic=2) ! glacier continental +! + REAL epsfra + PARAMETER (epsfra=1.0E-05) +! + CHARACTER(len=3) clnsurf(nbsrf) + DATA clnsurf/'ter', 'lic', 'oce', 'sic'/ + SAVE clnsurf +!$OMP THREADPRIVATE(clnsurf) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_bilKP_ave.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_bilKP_ave.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_bilKP_ave.h (revision 1280) @@ -0,0 +1,259 @@ +c +c $Header$ +c + IF (ok_journe) THEN +c + zsto = dtime + zout = ecrit_day + typeval=tave +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) +cym DO i = 1, iim +cym zx_lon(i,1) = rlon(i+1) +cym zx_lon(i,jjmp1) = rlon(i+1) +cym ENDDO + DO ll=1,klev + znivsig(ll)=float(ll) + ENDDO +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) +cym write(*,*)'zx_lon = ',zx_lon(:,1) +cym write(*,*)'zx_lat = ',zx_lat(1,:) +cym CALL histbeg("histbilKP_ave", iim,zx_lon(:,1), jjmp1, +cym . zx_lat(1,:), +cym . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, +cym . nhori, nid_bilKPave) + CALL histbeg_phy("histbilKP_ave", itau_phy, zjulian, dtime, + . nhori, nid_bilKPave) + + write(*,*)'Journee ', itau_phy, zjulian + CALL histvert(nid_bilKPave, "presnivs", + . "Vertical levels","mb", + . klev, presnivs/100., nvert) +c +c +c Champs 3D: +c + CALL histdef(nid_bilKPave,"ue", + . "Zonal energy transport","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"ve", + . "Merid energy transport","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"uq", + . "Zonal humidity transport","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"vq", + . "Merid humidity transport","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c +c Champs 3D: +c + CALL histdef(nid_bilKPave,"temp", + . "Air temperature","K", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"ovap", + . "Specific humidity","Kg/Kg", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"geop", + . "Geopotential height","m", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"vitu", + . "Zonal wind","m/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"vitv", + . "Meridional wind","m/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "vitw", + . "Vertical wind", "m/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "pres", + . "Inter-Layer Air pressure", + . "Pa", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "play", + . "Mean-Layer Air pressure", + . "Pa", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "oliq", + . "Liquid water content", + . "kg/kg", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dtdyn", + . "Dynamics dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dqdyn", + . "Dynamics dQ", "Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dtcon", + . "Convection dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "ducon", + . "Convection du", "m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dvcon", + . "Convection dv", "m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"dqcon", + . "Convection dQ","Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dtlsc", + . "Condensation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"dqlsc", + . "Condensation dQ","Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"dtvdf", + . "Boundary-layer dT","K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dqvdf", + . "Boundary-layer dQ", + . "Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"dtajs", + . "Ajustement sec dT","K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dqajs", + . "Ajustement sec dQ", + . "Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dteva", + . "Reevaporation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"dqeva", + . "Reevaporation dQ", + . "Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) + +c + CALL histdef(nid_bilKPave, "dtswr", + . "SW radiation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dtsw0", + . "SW radiation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dtlwr", + . "LW radiation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dtlw0", + . "LW radiation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"duvdf", + . "Boundary-layer dU","m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"dvvdf", + . "Boundary-layer dV","m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + IF (ok_orodr) THEN + IF (ok_orolf) THEN + CALL histdef(nid_bilKPave, "duoli", + . "Orography dU", "m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dvoli", + . "Orography dV", "m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + ENDIF + ENDIF +C + CALL histdef(nid_bilKPave, "duphy", + . "Physiq dU","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C + CALL histdef(nid_bilKPave, "dvphy", + . "Physiq dV","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C + CALL histdef(nid_bilKPave, "dtphy", + . "Physiq dT","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C + CALL histdef(nid_bilKPave, "dqphy", + . "Physiq dQ","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C + CALL histdef(nid_bilKPave, "dqlphy", + . "Physiq dQl","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C +C + CALL histend(nid_bilKPave) +c + ndex2d = 0 + ndex3d = 0 +c + ENDIF ! fin de test sur ok_journe Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_bilKP_ins.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_bilKP_ins.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_bilKP_ins.h (revision 1280) @@ -0,0 +1,326 @@ +c +c $Header$ +c + IF (ok_journe) THEN +c + zsto = dtime + zout = dtime + typeval=tinst +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) +cym DO i = 1, iim +cym zx_lon(i,1) = rlon(i+1) +cym zx_lon(i,jjmp1) = rlon(i+1) +cym ENDDO + DO ll=1,klev + znivsig(ll)=float(ll) + ENDDO +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) +cym write(*,*)'zx_lon = ',zx_lon(:,1) +cym write(*,*)'zx_lat = ',zx_lat(1,:) +c +cIM 280405 BEG +c +cIM cf. AM 081204 BEG region + imin_ins=1 + imax_ins=iim + jmin_ins=1 + jmax_ins=jjmp1 +cym do i=1,iim-1 +cym if(zx_lon(i,1).lt.lonmin_ins) imin_ins=i +cym if(zx_lon(i,1).le.lonmax_ins) imax_ins=i+1 +cym enddo +cym do j=1,jjmp1 +cym if(zx_lat(1,j).ge.latmin_ins) jmax_ins=j +cym if(zx_lat(1,j).gt.latmax_ins) jmin_ins=j +cym enddo +c + print*,'On stoke le fichier bilKP instantanne sur ', + s imin_ins,imax_ins,jmin_ins,jmax_ins + print*,'On stoke le fichier bilKP instantanne sur ', + s zx_lon(imin_ins,1),zx_lon(imax_ins,1), + s zx_lat(1,jmin_ins),zx_lat(1,jmax_ins) +cIM cf. AM 081204 END region +c +cIM 280405 END +c +cym IF(1.EQ.0) THEN +cym CALL histbeg("histbilKP_ins", iim,zx_lon(:,1), jjmp1, +cym . zx_lat(1,:), +cym . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, +cym . nhori, nid_bilKPins) + ENDIF +c +cIM 280405 BEG +c +cIM cf. AM 081204 BEG region +cym CALL histbeg("histbilKP_ins", iim,zx_lon(:,1), +cym . jjmp1,zx_lat(1,:), +cym . imin_ins,imax_ins-imin_ins+1, +cym . jmin_ins,jmax_ins-jmin_ins+1, +cym . itau_phy, zjulian, dtime, +cym . nhori, nid_bilKPins) + CALL histbeg_phy("histbilKP_ins", itau_phy, zjulian, dtime, + . nhori, nid_bilKPins) +cIM 081204 END +c +cIM 280405 END +c + write(*,*)'Journee ', itau_phy, zjulian + CALL histvert(nid_bilKPins, "presnivs", + . "Vertical levels","mb", + . klev, presnivs/100., nvert) +c +c Champs 3D: +c + CALL histdef(nid_bilKPins,"ue", + . "Zonal energy transport","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"ve", + . "Merid energy transport","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"uq", + . "Zonal humidity transport","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"vq", + . "Merid humidity transport","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c +c Champs 3D: +c + CALL histdef(nid_bilKPins, "temp", + . "Air temperature", "K", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"ovap", + . "Specific humidity","Kg/Kg", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"geop", + . "Geopotential height", "m", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"vitu", + . "Zonal wind", "m/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"vitv", + . "Meridional wind", "m/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "vitw", + . "Vertical wind", "m/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "pres", + . "Inter-Layer Air pressure", + . "Pa", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "play", + . "Mean-Layer Air pressure", + . "Pa", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "oliq", + . "Liquid water content", + . "kg/kg", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dtdyn", + . "Dynamics dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dqdyn", + . "Dynamics dQ", "Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dtcon", + . "Convection dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "ducon", + . "Convection du", "m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dvcon", + . "Convection dv", "m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"dqcon", + . "Convection dQ","Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dtlsc", + . "Condensation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"dqlsc", + . "Condensation dQ","Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"dtvdf", + . "Boundary-layer dT","K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dqvdf", + . "Boundary-layer dQ", + . "Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"dtajs", + . "Ajustement sec dT","K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"dqajs", + . "Ajustement sec dQ", + . "Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"dteva", + . "Reevaporation dT","K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"dqeva", + . "Reevaporation dQ", + . "Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) + +c + CALL histdef(nid_bilKPins, "dtswr", + . "SW radiation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dtsw0", + . "SW radiation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dtlwr", + . "LW radiation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dtlw0", + . "LW radiation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"duvdf", + . "Boundary-layer dU","m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"dvvdf", + . "Boundary-layer dV","m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + IF (ok_orodr) THEN + IF (ok_orolf) THEN + CALL histdef(nid_bilKPins, "duoli", + . "Orography dU", "m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dvoli", + . "Orography dV", "m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + ENDIF + ENDIF +C + CALL histdef(nid_bilKPins, "duphy", + . "Physiq dU","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C + CALL histdef(nid_bilKPins, "dvphy", + . "Physiq dV","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C + CALL histdef(nid_bilKPins, "dtphy", + . "Physiq dT","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C + CALL histdef(nid_bilKPins, "dqphy", + . "Physiq dQ","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C + CALL histdef(nid_bilKPins, "dqlphy", + . "Physiq dQl","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +cIM 280405 BEG +c +c Champs 2D: +c +c u850, v850 +c DO k=1, nlevSTD + DO k=1, 12 +c + IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k) + IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k) +c + IF(bb2.EQ."850") THEN +c + CALL histdef(nid_bilKPins, "u"//bb2, + . "Zonal wind "//bb2//"mb","m/s", + . iim,jjphy_nb,nhori, 1,1,1, -99, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "v"//bb2, + . "Meridional wind "//bb2//"mb","m/s", + . iim,jjphy_nb,nhori, 1,1,1, -99, 32, + . typeval, zsto,zout) +c + ENDIF !(bb2.EQ."850") +c + ENDDO !k=1, 12 +c +cIM 280405 END +c + CALL histend(nid_bilKPins) +c + ndex2d = 0 + ndex3d = 0 +c + ENDIF ! fin de test sur ok_journe Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_coord_REGDYN.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_coord_REGDYN.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_coord_REGDYN.h (revision 1280) @@ -0,0 +1,81 @@ +c +c $Header$ +c + nsrf=3 + DO nreg=1, nbregdyn + DO i=1, klon + +c IF (debut) THEN + IF(rlon(i).LT.0.) THEN + rlonPOS(i)=rlon(i)+360. + ELSE + rlonPOS(i)=rlon(i) + ENDIF +c ENDIF + + pct_ocean(i,nreg)=0 + +c test si c'est 1 point d'ocean + IF(pctsrf(i,nsrf).EQ.1.) THEN + + IF(nreg.EQ.1) THEN + +c TROP + IF(rlat(i).GE.-30.AND.rlat(i).LE.30.) THEN + pct_ocean(i,nreg)=1 + ENDIF + +c PACIFIQUE NORD + ELSEIF(nreg.EQ.2) THEN + IF(rlat(i).GE.40.AND.rlat(i).LE.60.) THEN + IF(rlonPOS(i).GE.160..AND.rlonPOS(i).LE.235.) THEN + pct_ocean(i,nreg)=1 + ENDIF + ENDIF +c CALIFORNIE ST-CU + ELSEIF(nreg.EQ.3) THEN + IF(rlonPOS(i).GE.220..AND.rlonPOS(i).LE.250.) THEN + IF(rlat(i).GE.15.AND.rlat(i).LE.35.) THEN + pct_ocean(i,nreg)=1 + ENDIF + ENDIF +c HAWAI + ELSEIF(nreg.EQ.4) THEN + IF(rlonPOS(i).GE.180..AND.rlonPOS(i).LE.220.) THEN + IF(rlat(i).GE.15.AND.rlat(i).LE.35.) THEN + pct_ocean(i,nreg)=1 + ENDIF + ENDIF +c WARM POOL + ELSEIF(nreg.EQ.5) THEN + IF(rlonPOS(i).GE.70..AND.rlonPOS(i).LE.150.) THEN + IF(rlat(i).GE.-5.AND.rlat(i).LE.20.) THEN + pct_ocean(i,nreg)=1 + ENDIF + ENDIF + ENDIF !nbregdyn +c TROP +c IF(rlat(i).GE.-30.AND.rlat(i).LE.30.) THEN +c pct_ocean(i)=.TRUE. +c WRITE(*,*) 'pct_ocean =',i, rlon(i), rlat(i) +c ENDIF !lon +c ENDIF !lat + + ENDIF !pctsrf + ENDDO !klon + ENDDO !nbregdyn +cIM 190504 ENDIF !ok_regdyn + +cIM somme de toutes les nhistoW BEG + IF (debut) THEN + DO nreg = 1, nbregdyn + DO k = 1, kmaxm1 + DO l = 1, lmaxm1 + DO iw = 1, iwmax + nhistoWt(k,l,iw,nreg)=0. + ENDDO !iw + ENDDO !l + ENDDO !k + ENDDO !nreg + ENDIF !(debut) THEN +cIM 190504 BEG Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histISCCP.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histISCCP.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histISCCP.h (revision 1280) @@ -0,0 +1,277 @@ +! +! $Header$ +! + IF (ok_isccp) THEN +c +c$OMP MASTER + ndex2d = 0 + ndex3d = 0 +c +c pour les champs instantannes, il faut mettre la meme valeur pour +c zout et zsto. +c dtime est passe par ailleurs a histbeg +c zstophy = frequence de stockage des champs tous les pdt physiques +c zout = frequence d'ecriture des champs +cIM 300505 zstophy = dtime +c appel du simulateur toutes les 3heures +!IM on lit la frequence d'appel dans physiq.def +! zcals(1) = dtime *6. !toutes les 3h (en s) + zcals(1) = freq_ISCCP !toutes les freq_ISCCP secondes + DO n=1, napisccp + zcalh(n) = zcals(n)/3600. !stoutes les Xh (en heures) + ENDDO !n +c +c ecriture 8 fois par jour +c zout = dtime * REAL(NINT(86400./dtime*ecrit_isccp)) +c ecriture toutes les 2h (12 fois par jour) +c zout = dtime * 4. +c ecriture toutes les 1/2 h (48 fois par jour) +c zout = dtime +c +c IF(freqout_isccp.EQ.1.) THEN +c ecriture jounaliere +!IM on ecrit les resultats du simulateur ISCCP toutes les +! ecrit_ISCCP secondes zout_isccp(1) = ecrit_day !(en s) + zout_isccp(1) = ecrit_ISCCP !(en s) +c ecriture mensuelle +c zout = dtime * ecrit_mth !(en s) + DO n=1, napisccp + zoutj(n)=zout_isccp(n)/86400. !(en jours) +c +c le nombre de sous-colonnes ncol : ncol=(100.*zcalh)/zoutd + ncol(n)=NINT((100.*zcalh(n))/zoutj(n)) + IF(ncol(n).GT.ncolmx) THEN + PRINT*,'Warning: Augmenter le nombre colonnes du simulateur' + PRINT*,' ISCCP ncol=', ncol,' ncolmx=',ncolmx +c PRINT*,'n ncol',n,ncol(n) + CALL abort + ENDIF +c + DO l=1, ncol(n) + vertlev(l,n)=float(l) + ENDDO !ncol +c + ENDDO !n + +c PRINT*, 'La frequence de sortie ISCCP est de ', ecrit_isccp +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c write(*,*)'ISCCP ', itau_phy, zjulian +c +c +c definition coordonnees lon,lat en globale +c +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) +cym DO i = 1, iim +cym zx_lon(i,1) = rlon(i+1) +cym zx_lon(i,jjmp1) = rlon(i+1) +cym ENDDO + +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) +c +cIM BEG region +cym Desole dans un premier temps le mode region ne marchera pas +cym Il faudra voir dans un second temps pour l'implementer +cym Mais cela posera des problemes au niveau de la reconstruction + + imin_ins=1 + imax_ins=iim + jmin_ins=1 + jmax_ins=jjmp1 +cym do i=1,iim-1 +cym if(zx_lon(i,1).lt.lonmin_ins) imin_ins=i +cym if(zx_lon(i,1).le.lonmax_ins) imax_ins=i+1 +cym enddo +cym do j=1,jjmp1 +cym if(zx_lat(1,j).ge.latmin_ins) jmax_ins=j +cym if(zx_lat(1,j).gt.latmax_ins) jmin_ins=j +cym enddo +c + print*,'On stoke le fichier histISCCP sur ', + s imin_ins,imax_ins,jmin_ins,jmax_ins +cym print*,'On stoke le fichier histISCCP instantanne sur ', +cym s zx_lon(imin_ins,1),zx_lon(imax_ins,1), +cym s zx_lat(1,jmin_ins),zx_lat(1,jmax_ins) +cIM END region +c + IF(1.EQ.0) THEN +cym CALL histbeg("histISCCP.nc", iim,zx_lon(:,1),jjmp1,zx_lat(1,:), +cym . 1, iim, 1, jjmp1, +cym . itau_phy, zjulian, dtime, +cym . nhori, nid_isccp) + CALL histbeg_phy("histISCCP.nc", itau_phy, zjulian, dtime, + . nhori, nid_isccp) + ENDIF !(1.EQ.0) THEN +c +cym CALL histbeg("histISCCP.nc", iim,zx_lon(:,1), +cym . jjmp1,zx_lat(1,:), +cym . imin_ins,imax_ins-imin_ins+1, +cym . jmin_ins,jmax_ins-jmin_ins+1, +cym . itau_phy, zjulian, dtime, +cym . nhori, nid_isccp) + + CALL histbeg_phy("histISCCP.nc", itau_phy, zjulian, dtime, + . nhori, nid_isccp) +c + IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN + CALL histvert(nid_isccp, "cldtopres","Cloud Top Pressure","mb", + . lmaxm1, cldtopres, nvert,'down') + ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN + CALL histvert(nid_isccp,"cldtopres3","Cloud Top Pressure","mb", + . lmax3, cldtopres3, nvert3,'down') + ENDIF + DO n=1, napisccp + CALL histvert(nid_isccp, "Nbcol"//verticaxe(n), + . "Nb of Column"//verticaxe(n),"1", + . ncol(n), vertlev(:,n), nvlev(n),'up') + ENDDO +c + IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN +c +c variables a ecrire +c + DO n=1, napisccp +c + DO k=1, kmaxm1 + CALL histdef(nid_isccp, "cldISCCP_"//taulev(k)//verticaxe(n), + . "LMDZ ISCCP cld", "%", + . iim, jj_nb,nhori,lmaxm1,1,lmaxm1,nvert,32, + . "ave(X)", zcals(n),zout_isccp(n)) + ENDDO +c + CALL histdef(nid_isccp, "nsunlit"//verticaxe(n), + . "Nb of calls with sunlit ", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "meantaucld"//verticaxe(n), + . "ISCCP mean cloud optical thickness", "1", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + ENDDO +c + ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN +c + DO n=1, napisccp +c +c print*,'n=',n,' avant histdef(..LMDZ ISCCP cld' +c + DO k=1, kmaxm1 + DO l=1, lmaxm1 +c + CALL histdef(nid_isccp, pclev(l)//taulev(k)//verticaxe(n), + . "LMDZ ISCCP cld "//cnameisccp(l,k), "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + ENDDO + ENDDO +c +c print*,'n=',n,' avant histdef(..Nb of calls sunlit' + CALL histdef(nid_isccp, "nsunlit"//verticaxe(n), + . "Nb of calls with sunlit ", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "meantaucld"//verticaxe(n), + . "ISCCP mean cloud optical thickness", "1", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c +c 9types de nuages ISCCP-D2 + CALL histdef(nid_isccp, "cirr", + . "Cirrus lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "cist", + . "CiSt lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "deep", + . "Deep lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "alcu", + . "AlCu lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "alst", + . "AlSt lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "nist", + . "NiSt lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "cumu", + . "Cumu lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "stcu", + . "StCu lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "stra", + . "Stra lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c +c 3_epaisseurs_optiques x3_pressions_au_sommet_des_nuages types de nuages + CALL histdef(nid_isccp, "thin", + . "Opt. thin ISCCP-D2 like clouds", "%", + . iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "mid", + . "Opt. intermediate ISCCP-D2 like clouds", "%", + . iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "thick", + . "Opt. thick ISCCP-D2 like clouds", "%", + . iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c +c IF(1.EQ.0) THEN +c IF(n.EQ.3) THEN +c IF(n.EQ.1) THEN +c +cIM 070905 BEG + IF(1.EQ.0) THEN + print*,'n=',n,' avant histdef(..boxptop axe' +cIM verif boxptop + CALL histdef(nid_isccp,"boxptop"//verticaxe(n), + . "Boxptop axe"//verticaxe(n), "mb", + . iim, jj_nb,nhori, + . ncol(n),1,ncol(n),nvlev(n),32, +cIM . ncolmx,1,ncolmx,nvlev,32, +cIM . "inst(X)",dtime,dtime) + . "ave(X)",zcals(n),zout_isccp(n)) + ENDIF !(1.EQ.0) THEN +cIM 070905 END +c ENDIF !(n.EQ.3) THEN +c ENDIF !(1.EQ.0) THEN +c +c print*,'n=',n,' avant histdef(..seed axe' + CALL histdef(nid_isccp, "seed"//verticaxe(n), + . "seed axe"//verticaxe(n), "-", + . iim, jj_nb,nhori,1,1,1,-99,32, +cIM . "inst(X)", dtime,dtime) + . "ave(X)", zcals(n),zout_isccp(n)) +c + ENDDO !n + ENDIF + CALL histend(nid_isccp) +c +c$OMP END MASTER + ENDIF ! ok_isccp Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histREGDYN.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histREGDYN.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histREGDYN.h (revision 1280) @@ -0,0 +1,127 @@ +! +! $Header$ +! + + IF (ok_regdyn) THEN + + if (is_sequential) then +c +cIM PRINT*, 'La frequence de sortie REGDYN est de ', ecrit_mth +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c +c axe vertical pour les differents niveaux des histogrammes + DO iw=1, iwmax + zx_o500(iw)=wmin+(iw-1./2.)*pas_w + ENDDO + + CALL histbeg("histREGDYN", kmaxm1,zx_tau, lmaxm1,zx_pc, + . 1,kmaxm1,1,lmaxm1, itau_phy, zjulian, dtime, + . nhoriRD, nid_regdyn) + + CALL histvert(nid_regdyn, "omeganivs", "Omega levels", + . "mb/day", + . iwmax, zx_o500, komega) +c +c pour les champs instantannes, il faut mettre la meme valeur pour +c zout et zsto. +c dtime est passe par ailleurs a histbeg +c +c zout = dtime * REAL(NINT(86400./dtime*ecrit_regdyn)) +c zsto = zout +c print*,'zout,zsto=',zout,zsto +c +c stockage a chaque pas de temps de la physique +c + zstophy = dtime +cIM 020904 zstophy = dtime * nbapp_isccp + +c ecriture mensuelle +c + zout = dtime * ecrit_mth +cIM 020904 +c zout = dtime * ecrit_day +c zout = dtime * REAL(NINT(86400./dtime*ecrit_regdyn)) + +c +c Champs 3D: +c +c TROP + CALL histdef(nid_regdyn, "hw1", "Tropics Histogram ", "%", + & kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, + & "ave(X)", zstophy,zout) + + CALL histdef(nid_regdyn, "nh1", "Nb of pixels Tropics Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c + + CALL histdef(nid_regdyn, "nht1", + & "Total Nb pixels Tropics Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c +c PAN + CALL histdef(nid_regdyn, "hw2", "North Pacific Histogram", "%", + & kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, + & "ave(X)", zstophy,zout) + + CALL histdef(nid_regdyn, "nh2", "Nb of pixels North Pacific", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c + + CALL histdef(nid_regdyn, "nht2", + & "Total Nb pixels North Pacific Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c CAL + CALL histdef(nid_regdyn, "hw3", "California Histogram", "%", + & kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, + & "ave(X)", zstophy,zout) + + CALL histdef(nid_regdyn, "nh3", + & "Nb of pixels California Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c + + CALL histdef(nid_regdyn, "nht3", + & "Total Nb pixels California Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c HAW + CALL histdef(nid_regdyn, "hw4", "Hawai Histogram", "%", + & kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, + & "ave(X)", zstophy,zout) + + CALL histdef(nid_regdyn, "nh4", "Nb of pixels Hawai Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c + + CALL histdef(nid_regdyn, "nht4", + & "Total Nb pixels Hawai Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c WAP + CALL histdef(nid_regdyn, "hw5", "Warm Pool Histogram", "%", + & kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, + & "ave(X)", zstophy,zout) + + CALL histdef(nid_regdyn, "nh5", "Nb of pixels Warm Pool Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c + + CALL histdef(nid_regdyn, "nht5", + & "Total Nb pixels Warm Pool Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c + CALL histend(nid_regdyn) + + endif ! is_sequential + + endif ! ok_regdyn Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histday_seri.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histday_seri.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histday_seri.h (revision 1280) @@ -0,0 +1,131 @@ +c +c $Header$ +c +cym Ne fonctionnera pas en mode parallele + IF (is_sequential) THEN + + IF (type_run.EQ."AMIP") THEN +c + zstophy = dtime + zout = ecrit_day +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) + DO i = 1, iim + zx_lon(i,1) = rlon(i+1) + zx_lon(i,jjmp1) = rlon(i+1) + ENDDO + DO ll=1,klev + znivsig(ll)=float(ll) + ENDDO + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) +c + imin_debut=1 + nbpti=1 + jmin_debut=1 + nbptj=1 +c + CALL histbeg("histday_seri.nc", + . iim,zx_lon(:,1), jjmp1,zx_lat(1,:), + . imin_debut,nbpti,jmin_debut,nbptj, + . itau_phy, zjulian, dtime, + . nhori, nid_day_seri) +c + CALL histvert(nid_day_seri, "presnivs", + . "Vertical levels","mb", + . klev, presnivs/100., nvert) +c + CALL histdef(nid_day_seri, "bilTOA", + . "Net radiation at model top", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_day_seri, "bils", + . "Net downward energy flux at surface","W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_day_seri, "ecin", + . "Total kinetic energy (per unit area)","J/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c +cIM 151004 BEG + IF(1.EQ.0) THEN +c + CALL histdef(nid_day_seri, "momang", + . "Total relative angular momentum (per unit area)", + . "kg/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_day_seri, "frictor", + . "Friction torque (per unit area)", "N/m", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_day_seri, "mountor", + . "Mountain torque (per unit area)", "N/m", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + ENDIF !(1.EQ.0) THEN +c + CALL histdef(nid_day_seri, "momang", + . "Axial angular momentum (per unit area)", + . "kg/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_day_seri, "torsfc", + . "Total surface torque (including mountain torque)", "N/m", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c +cIM 151004 END +c + CALL histdef(nid_day_seri, "tamv", + . "Temperature (mass-weighted vert. ave)", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_day_seri, "psol", + . "Surface pressure", "Pa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_day_seri, "evap", + . "Evaporation and sublimation (per unit area)", + . "kg/(m2*s)", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c +c call histdef(nid_day_seri, +c . "SnowFrac", +c . "Snow-covered area ", "%", +c . iim,jjmp1,nhori, 1,1,1, -99, 32, +c . "ave(X)", zstophy,zout) +c +c CALL histdef(nid_day_seri, "snow_depth", +cIM 080904 . "Snow Depth (water equivalent)", "m", +cIM 191104 . "Snow Depth (water equivalent)", "kg/m2", +c . "Snow Mass", "kg/m2", +c . iim,jjmp1,nhori, 1,1,1, -99, 32, +c . "ave(X)", zstophy,zout) +c + call histdef(nid_day_seri, + . "tsol_"//clnsurf(is_oce), + . "SST over open (ice-free) ocean ", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c +c================================================================= +c + CALL histend(nid_day_seri) +c +c================================================================= + ENDIF ! fin de test sur type_run.EQ.AMIP + + ENDIF ! is_sequential Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histhf3d.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histhf3d.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histhf3d.h (revision 1280) @@ -0,0 +1,51 @@ +c $Header$ +c +c sorties hf 3d +c + zstohf = ecrit_hf + zout = ecrit_hf +c +c PRINT*, 'La frequence de sortie hf3d est de ', ecrit_hf +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c + +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) +cym DO i = 1, iim +cym zx_lon(i,1) = rlon(i+1) +cym zx_lon(i,jjmp1) = rlon(i+1) +cym ENDDO + +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) + +cccIM CALL histbeg("histhf", iim,zx_lon, jjmp1,zx_lat, +cym CALL histbeg("histhf3d", iim,zx_lon(:,1), jjmp1,zx_lat(1,:), +cym . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, +cym . nhori, nid_hf3d) + CALL histbeg_phy("histhf3d", itau_phy, zjulian, dtime, + . nhori, nid_hf3d) + + CALL histvert(nid_hf3d, "presnivs", "Vertical levels", "mb", + . klev, presnivs/100., nvert) +c +c Champs 3D: +c + CALL histdef(nid_hf3d, "temp", "Air temperature", "K", + . iim,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zstohf,zout) +c + CALL histdef(nid_hf3d, "ovap", "Specific humidity", "kg/kg", + . iim,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zstohf,zout) +c + CALL histdef(nid_hf3d, "vitu", "Zonal wind", "m/s", + . iim,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zstohf,zout) +c + CALL histdef(nid_hf3d, "vitv", "Meridional wind", "m/s", + . iim,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zstohf,zout) +c + CALL histend(nid_hf3d) +c Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histmthNMC.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histmthNMC.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histmthNMC.h (revision 1280) @@ -0,0 +1,185 @@ +! +! $Header$ +! + IF (ok_mensuel) THEN +c +c$OMP MASTER + + zstophy = dtime + zstohf = ecrit_hf + zstomth = ecrit_mth + zout = ecrit_mth +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) +cym DO i = 1, iim +cym zx_lon(i,1) = rlon(i+1) +cym zx_lon(i,jjmp1) = rlon(i+1) +cym ENDDO + DO ll=1,klev + znivsig(ll)=float(ll) + ENDDO +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) +cym CALL histbeg("histNMC.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:), +cym . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, +cym . nhori, nid_nmc) + + CALL histbeg_phy("histNMC",itau_phy, zjulian, dtime, + . nhori, nid_nmc) +c + CALL histvert(nid_nmc, "presnivs", "Vertical levels", "mb", + . nlevSTD, rlevSTD/100., nvert) +ccc +ccc Champs 3D interpolles sur des niveaux de pression du NMC +ccc + IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN +c + CALL histdef(nid_nmc, "temp", + . "Temperature","K", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "phi", + . "Geopotential", "m", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "q", + . "Specific humidity","kg/kg", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "rh", + . "Relative humidity", "%", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "u", + . "Zonal wind","m/s", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "v", + . "Meridional wind","m/s", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN +c +c ATTENTION : pour AMIP2 on interpole t,u,v,wphi,q,rh +c sur les niveaux du NMC et on somme & moyenne +c toutes les 6 heures par des routines undefSTD et +c moy_undefSTD pour eliminer les valeurs "undef" +c de la moyenne mensuelle +c ======> le "inst(X)" ci-dessous est par consequence factice ! +c + CALL histdef(nid_nmc, "temp", + . "Temperature","K", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "phi", + . "Geopotential ", "m", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "q", + . "Specific humidity","kg/kg", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "rh", + . "Relative humidity", "%", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "u", + . "Zonal wind","m/s", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "v", + . "Meridional wind","m/s", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "w", + . "Vertical motion","Pa/s", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c +c ATTENTION : pour AMIP2 on interpole t,u,v,wphi,q,rh +c sur les niveaux du NMC et on somme & moyenne +c toutes les 6 heures par des routines undefSTD et +c moy_undefSTD pour eliminer les valeurs "undef" +c de la moyenne mensuelle +c ======> le "inst(X)" ci-dessus est par consequence factice ! +c +c + CALL histdef(nid_nmc, "psbg", + . "Pressure sfce below ground","%", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "uv", + . "uv ", + . "m2/s2",iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "vq", + . "vq ", + . "m/s * (kg/kg)",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "vT", + . "vT ", + . "mK/s",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "wq", + . "wq ", + . "(Pa/s)*(kg/kg)",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "vphi", + . "vphi ", + . "m2/s",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "wT", + . "wT ", + . "K*Pa/s",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "uxu", + . "u2 ", + . "m2/s2",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "vxv", + . "v2 ", + . "m2/s2",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + CALL histdef(nid_nmc, "TxT", + . "T2 ", + . "K2",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "inst(X)", zout,zout) +c + ENDIF !(type_run.EQ."AMIP") + + CALL histend(nid_nmc) +c +c$OMP END MASTER + + ENDIF ! fin de test sur ok_mensuel Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histrac.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histrac.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_histrac.h (revision 1280) @@ -0,0 +1,124 @@ +! +! $Id $ +! + IF (ecrit_tra>0. .AND. config_inca == 'none') THEN +!$OMP MASTER + CALL ymds2ju(annee_ref, 1, day_ref, 0.0, zjulian) + CALL histbeg_phy("histrac", itau_phy, zjulian, pdtphys,nhori, nid_tra) + CALL histvert(nid_tra, "presnivs", "Vertical levels", "mb",klev, presnivs, nvert) + + zsto = pdtphys + zout = ecrit_tra + CALL histdef(nid_tra, "phis", "Surface geop. height", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32,"once", zsto,zout) + CALL histdef(nid_tra, "aire", "Grid area", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32,"once", zsto,zout) + +!TRACEURS +!---------------- + DO it = 1,nbtr + iiq = niadv(it+2) + +! CONCENTRATIONS + CALL histdef(nid_tra, tname(iiq), ttext(iiq), "U/kga", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32,"ave(X)", zsto,zout) + +! TD LESSIVAGE + IF (lessivage .AND. aerosol(it)) THEN + CALL histdef(nid_tra, "fl"//tname(iiq),"Flux "//ttext(iiq), & + "U/m2/s",iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + END IF + +! TD THERMIQUES + IF (iflag_thermals.gt.0) THEN + CALL histdef(nid_tra, "d_tr_th_"//tname(iiq), & + "tendance thermique"// ttext(iiq), "?", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + ENDIF + +! TD CONVECTION + IF (iflag_con.GE.2) THEN + CALL histdef(nid_tra, "d_tr_cv_"//tname(iiq), & + "tendance convection"// ttext(iiq), "?", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + ENDIF + +! TD COUCHE-LIMITE + CALL histdef(nid_tra, "d_tr_cl_"//tname(iiq), & + "tendance couche limite"// ttext(iiq), "?", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + ENDDO +!--------------- +! +! VENT (niveau 1) + CALL histdef(nid_tra, "pyu1", "Vent niv 1", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) + CALL histdef(nid_tra, "pyv1", "Vent niv 1", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) + +! TEMPERATURE DU SOL + CALL histdef(nid_tra, "ftsol1", "temper sol", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) + CALL histdef(nid_tra, "ftsol2", "temper sol", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) + CALL histdef(nid_tra, "ftsol3", "temper sol", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst", zout,zout) + CALL histdef(nid_tra, "ftsol4", "temper sol", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) + +! NATURE DU SOL + CALL histdef(nid_tra, "psrf1", "nature sol", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) + CALL histdef(nid_tra, "psrf2", "nature sol", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) + CALL histdef(nid_tra, "psrf3", "nature sol", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) + CALL histdef(nid_tra, "psrf4", "nature sol", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) +! DIVERS + CALL histdef(nid_tra, "pplay", "flux u mont","-", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "inst(X)", zout,zout) + CALL histdef(nid_tra, "t", "flux u mont","-", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "inst(X)", zout,zout) + CALL histdef(nid_tra, "mfu", "flux u mont","-", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + CALL histdef(nid_tra, "mfd", "flux u decen","-", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + CALL histdef(nid_tra, "en_u", "flux u mont","-", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + CALL histdef(nid_tra, "en_d", "flux u mont","-", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + CALL histdef(nid_tra, "de_d", "flux u mont","-", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + CALL histdef(nid_tra, "de_u", "flux u decen","-", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + CALL histdef(nid_tra, "coefh", "turbulent coef","-", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + + CALL histend(nid_tra) +!$OMP END MASTER + END IF ! ecrit_tra>0. .AND. config_inca == 'none' + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_paramLMDZ_phy.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_paramLMDZ_phy.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_paramLMDZ_phy.h (revision 1280) @@ -0,0 +1,361 @@ +cym Non implemente en mode parallele + + IF (is_sequential) THEN +c + zstophy = dtime + zout = ecrit_day +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) + if (iim.gt.1) then + DO i = 1, iim + zx_lon(i,1) = rlon(i+1) + zx_lon(i,jjmp1) = rlon(i+1) + ENDDO + endif + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) +c + CALL histbeg("paramLMDZ_phy.nc", + . iim,zx_lon(:,1), jjmp1,zx_lat(1,:), + . 1,1,1,1, + . itau_phy, zjulian, dtime, + . nhori, nid_ctesGCM) +c +c Variables type caractere : plusieurs valeurs possibles +c + CALL histdef(nid_ctesGCM, "ocean", + . "Type ocean utilise: 1=force, 2=slab, 3=couple", + . "-",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "type_run", + . "Type run: 1= CLIM ou ENSP, 2= AMIP ou CFMI", + . "-",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c +c Variables logiques (1=true, 0=false) +c + CALL histdef(nid_ctesGCM, "ok_veget", + . "Type de modele de vegetation: 1=ORCHIDEE, 0=bucket", + . "-",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ok_journe", + . "Creation du fichier histday: 1=true, 0=false", + . "-",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ok_mensuel", + . "Creation du fichier histmth: 1=true, 0=false", + . "-",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ok_instan", + . "Creation du fichier histins: 1=true, 0=false", + . "-",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ok_ade", + . "Aerosol direct effect: 1=true, 0=false", + . "-",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ok_aie", + . "Aerosol indirect effect: 1=true, 0=false", + . "-",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "bl95_b0", + . "Parameter in CDNC-maer link (Boucher&Lohmann 1995)", + . "-",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "bl95_b1", + . "Parameter in CDNC-maer link (Boucher&Lohmann 1995)", + . "-",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ip_ebil_phy", + . "Niveau sortie diags bilan energie cote physique", + . "-",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "R_ecc", + . "Excentricite","-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "R_peri", + . "Equinoxe","-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "R_incl", + . "Inclinaison","deg", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "solaire", + . "Constante solaire","W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "co2_ppm", + . "Concentration du CO2", "ppm", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "CH4_ppb", + . "Concentration du CH4", "ppb", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "N2O_ppb", + . "Concentration du N2O", "ppb", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "CFC11_ppt", + . "Concentration du CFC11", "ppt", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "CFC12_ppt", + . "Concentration du CFC12", "ppt", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "epmax", + . "Efficacite precip", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ok_adj_ema", + . "ok_adj_ema: 1=true, 0=false", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "iflag_clw", + . "iflag_clw", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "cld_lc_lsc", + . "cld_lc_lsc", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "cld_lc_con", + . "cld_lc_con", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "cld_tau_lsc", + . "cld_tau_lsc", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "cld_tau_con", + . "cld_tau_con", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ffallv_lsc", + . "ffallv_lsc", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ffallv_con", + . "ffallv_con", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "coef_eva", + . "coef_eva", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "reevap_ice", + . "reevap_ice: 1=true, 0=false", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "iflag_cldcon", + . "iflag_cldcon", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "iflag_pdf", + . "iflag_pdf", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "fact_cldcon", + . "fact_cldcon", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "facttemps", + . "facttemps", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ok_newmicro", + . "Nouvelle micro-physique: 1=true, 0=false", + . "-",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ratqsbas", + . "ratqsbas", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ratqshaut", + . "ratqshaut", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "rad_froid", + . "rad_froid", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "rad_chau1", + . "rad_chau1", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "rad_chau2", + . "rad_chau2", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "top_height", + . "top_height", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "overlap", + . "overlap", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "cdmmax", + . "cdmmax", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "cdhmax", + . "cdhmax", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ksta", + . "ksta", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ksta_ter", + . "ksta_ter", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ok_kzmin", + . "ok_kzmin: 1=true, 0=false", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "iflag_pbl", + . "iflag_pbl", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "lev_histhf", + . "lev_histhf", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "lev_histday", + . "lev_histday", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "lev_histmth", + . "lev_histmth", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ok_isccp", + . "Creation fichier histISCCP: 1=true, 0=false", + . "-",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "lonmin_ins", + . "lonmin_ins", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "lonmax_ins", + . "lonmax_ins", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "latmin_ins", + . "latmin_ins", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "latmax_ins", + . "latmax_ins", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ecrit_ins", + . "ecrit_ins", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ecrit_hf", + . "ecrit_hf", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ecrit_day", + . "ecrit_day", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ecrit_mth", + . "ecrit_mth", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ecrit_tra", + . "ecrit_tra", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ecrit_reg", + . "ecrit_reg", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "freq_ISCCP", + . "freq_ISCCP", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "ecrit_ISCCP", + . "ecrit_ISCCP", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zstophy,zout) +c +c================================================================= +c + CALL histend(nid_ctesGCM) + + ENDIF ! is_sequential +c +c================================================================= Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_undefSTD.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_undefSTD.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_undefSTD.F (revision 1280) @@ -0,0 +1,87 @@ +! +! $Header$ +! + + SUBROUTINE ini_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth, + $ tnondef,tsumSTD) + USE dimphy + IMPLICIT none +c +c==================================================================== +c +c I. Musat : 09.2004 +c +c Initialisation - a des frequences differentes : +c +c 1) des variables moyennees sur la journee "day" ou sur le mois "mth" +c calculees a partir des valeurs "instantannees" de la physique +c +c 2) des variables moyennes mensuelles "NMC" calculees a partir des val. +c toutes les 6 heures +c +c nout=1 !var. journaliere "day" moyenne sur tous les pas de temps +c ! de la physique +c nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps +c ! de la physique +c nout=3 !var. mensuelle "NMC" moyennee toutes les 6heures +c +c +c NB: mettre "inst(X)" dans le write_histXXX.h ! +c==================================================================== +c +cym #include "dimensions.h" +cym integer jjmp1 +cym parameter (jjmp1=jjm+1-1/jjm) +cym #include "dimphy.h" +c variables Input/Output + INTEGER nlevSTD, klevSTD, itap + PARAMETER(klevSTD=17) + REAL dtime + REAL ecrit_day,ecrit_mth +c +c variables locales + INTEGER i, k, nout + PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC +c +c variables Output + REAL tnondef(klon,klevSTD,nout) + REAL tsumSTD(klon,klevSTD,nout) +c +c initialisation variables journalieres en debut de journee +c + IF(MOD(itap,NINT(ecrit_day/dtime)).EQ.1.) THEN + DO k=1, nlevSTD + DO i=1, klon + tnondef(i,k,1)=0. + tsumSTD(i,k,1)=0. + ENDDO !i + ENDDO !k + ENDIF +c +c initialisation variables mensuelles (calculees a chaque pas de temps) +c en debut de mois : nout=2 +c + IF(MOD(itap,NINT(ecrit_mth/dtime)).EQ.1.) THEN +c + DO k=1, nlevSTD + DO i=1, klon + tnondef(i,k,2)=0. + tsumSTD(i,k,2)=0. + ENDDO !i + ENDDO !k +c +c initialisation variables mensuelles - runs type Amip - (calculees toutes les 6h) +c en debut de mois : nout = 3 +c + DO k=1, nlevSTD + DO i=1, klon + tnondef(i,k,3)=0. + tsumSTD(i,k,3)=0. + ENDDO !i + ENDDO !k +c + ENDIF +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_wake.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_wake.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ini_wake.F (revision 1280) @@ -0,0 +1,73 @@ + SUBROUTINE INI_WAKE(wape,fip,it_wape_prescr, + : wape_prescr, fip_prescr, alp_bl_prescr, ale_bl_prescr) +*************************************************************** +* * +* INI_WAKE : variables d'initialisation de la poche * +* froide, necessaires au declenchement * +* de la convection. * +* * +* * +*************************************************************** +c Arguments +c ========= +c Input +c ----- +c wape : valeur de l'energie potentielle de la poche (WAPE) +c dans l'etat initial +c fip : valeur de la puissance incidente sur le front (FIP) +c dans l'etat initial +c Output +c ------ +c it_wape_prescr : nombre de pas de temps pendant lesquels la WAPE +c doit etre imposee. +c wape_prescr : valeur prescrite de la WAPE. +c fip_prescr : valeur prescrite de la FIP. +c +c Variables internes +c ================== +c it = nbre de pas de temps lu +c w = WAPE lue +c f = FIP lue +c +cdeclarations + real ale_bl_prescr + real alp_bl_prescr + real it +cCR: on rajoute ale et alp de la PBL precrits +c open (99,file='wake.data',form='formatted') +c read (99,*) it +c read (99,*) w +c read (99,*) f +c read (99,*) u +c read (99,*) p +c close (99) + +! FH A mettre si besoin dans physiq.def +! FH : voir avec JYG + it=0. + w=4. + f=0.1 + u=0.1 + p=4. +c + print *,' it,w ',it,w + it_wape_prescr = it + if (w .lt. 0) then + wape_prescr = wape + fip_prescr = fip + else + wape_prescr = w + fip_prescr = f + endif +c + print *,' u,p ',u,p + alp_bl_prescr=u + ale_bl_prescr=p + print *,'Initialisation de la poche : WAPE, FIP imposees =' + $ ,wape_prescr, fip_prescr + print *, ' pendant ',it_wape_prescr,' steps' +c + print *,'Initialisation de la BL: ALP, ALE imposees =' + $ ,alp_bl_prescr, ale_bl_prescr + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/inifis.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/inifis.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/inifis.F (revision 1280) @@ -0,0 +1,73 @@ +! +! $Header$ +! + SUBROUTINE inifis(ngrid,nlayer, + $ punjours, + $ pdayref,ptimestep, + $ plat,plon,parea, + $ prad,pg,pr,pcpp) + USE dimphy + IMPLICIT NONE +c +c======================================================================= +c +c subject: +c -------- +c +c Initialisation for the physical parametrisations of the LMD +c martian atmospheric general circulation modele. +c +c author: Frederic Hourdin 15 / 10 /93 +c ------- +c +c arguments: +c ---------- +c +c input: +c ------ +c +c ngrid Size of the horizontal grid. +c All internal loops are performed on that grid. +c nlayer Number of vertical layers. +c pdayref Day of reference for the simulation +c firstcall True at the first call +c lastcall True at the last call +c pday Number of days counted from the North. Spring +c equinoxe. +c +c======================================================================= +c +c----------------------------------------------------------------------- +c declarations: +c ------------- + +cym#include "dimensions.h" +cym#include "dimphy.h" + + REAL prad,pg,pr,pcpp,punjours + + INTEGER ngrid,nlayer + REAL plat(ngrid),plon(ngrid),parea(klon) + INTEGER pdayref + + REAL ptimestep + + IF (nlayer.NE.klev) THEN + PRINT*,'STOP in inifis' + PRINT*,'Probleme de dimensions :' + PRINT*,'nlayer = ',nlayer + PRINT*,'klev = ',klev + STOP + ENDIF + + IF (ngrid.NE.klon) THEN + PRINT*,'STOP in inifis' + PRINT*,'Probleme de dimensions :' + PRINT*,'ngrid = ',ngrid + PRINT*,'klon = ',klon + STOP + ENDIF + + RETURN +9999 STOP'Cette version demande les fichier rnatur.dat et surf.def' + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/iniorbit.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/iniorbit.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/iniorbit.F (revision 1280) @@ -0,0 +1,104 @@ + SUBROUTINE iniorbit + $ (paphelie,pperiheli,pyear_day,pperi_day,pobliq) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: +c ------- +c Frederic Hourdin 22 Fevrier 1991 +c +c Objet: +c ------ +c Initialisation du sous programme orbite qui calcule +c a une date donnee de l'annee de duree year_day commencant +c a l'equinoxe de printemps et dont le perihelie se situe +c a la date peri_day, la distance au soleil et la declinaison. +c +c Interface: +c ---------- +c - Doit etre appele avant d'utiliser orbite. +c - initialise une partie du common planete.h +c +c Arguments: +c ---------- +c +c Input: +c ------ +c aphelie \ aphelie et perihelie de l'orbite +c periheli / en millions de kilometres. +c +c======================================================================= + +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "planete.h" +#include "YOMCST.h" + +c Arguments: +c ---------- + + REAL paphelie,pperiheli,pyear_day,pperi_day,pobliq + +c Local: +c ------ + + REAL zxref,zanom,zz,zx0,zdx, pi + INTEGER iter + +c----------------------------------------------------------------------- + + pi=2.*asin(1.) + + aphelie =paphelie + periheli=pperiheli + year_day=pyear_day + obliquit=pobliq + peri_day=pperi_day + + PRINT*,'Perihelie en Mkm ',periheli + PRINT*,'Aphelie en Mkm ',aphelie + PRINT*,'obliquite en degres :',obliquit + PRINT*,'Jours dans l annee : ',year_day + PRINT*,'Date perihelie : ',peri_day + unitastr=149.597870 + e_elips=(aphelie-periheli)/(periheli+aphelie) + p_elips=0.5*(periheli+aphelie)*(1-e_elips*e_elips)/unitastr + + print*,'e_elips',e_elips + print*,'p_elips',p_elips + +c----------------------------------------------------------------------- +c calcul de l'angle polaire et de la distance au soleil : +c ------------------------------------------------------- + +c calcul de l'zanomalie moyenne + + zz=(year_day-pperi_day)/year_day + zanom=2.*pi*(zz-nint(zz)) + zxref=abs(zanom) + PRINT*,'zanom ',zanom + +c resolution de l'equation horaire zx0 - e * sin (zx0) = zxref +c methode de Newton + + zx0=zxref+R_ecc*sin(zxref) + DO 110 iter=1,100 + zdx=-(zx0-R_ecc*sin(zx0)-zxref)/(1.-R_ecc*cos(zx0)) + if(abs(zdx).le.(1.e-12)) goto 120 + zx0=zx0+zdx +110 continue +120 continue + zx0=zx0+zdx + if(zanom.lt.0.) zx0=-zx0 + PRINT*,'zx0 ',zx0 + +c zteta est la longitude solaire + + timeperi=2.*atan(sqrt((1.+R_ecc)/(1.-R_ecc))*tan(zx0/2.)) + PRINT*,'longitude solaire du perihelie timeperi = ',timeperi + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/iniphysiq.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/iniphysiq.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/iniphysiq.F (revision 1280) @@ -0,0 +1,99 @@ +! +! $Header$ +! +c +c + SUBROUTINE iniphysiq(ngrid,nlayer, + $ punjours, + $ pdayref,ptimestep, + $ plat,plon,parea,pcu,pcv, + $ prad,pg,pr,pcpp) + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE comgeomphy + + IMPLICIT NONE +c +c======================================================================= +c +c subject: +c -------- +c +c Initialisation for the physical parametrisations of the LMD +c martian atmospheric general circulation modele. +c +c author: Frederic Hourdin 15 / 10 /93 +c ------- +c +c arguments: +c ---------- +c +c input: +c ------ +c +c ngrid Size of the horizontal grid. +c All internal loops are performed on that grid. +c nlayer Number of vertical layers. +c pdayref Day of reference for the simulation +c firstcall True at the first call +c lastcall True at the last call +c pday Number of days counted from the North. Spring +c equinoxe. +c +c======================================================================= +c +c----------------------------------------------------------------------- +c declarations: +c ------------- + +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "comgeomphy.h" +#include "YOMCST.h" + REAL prad,pg,pr,pcpp,punjours + + INTEGER ngrid,nlayer + REAL plat(ngrid),plon(ngrid),parea(klon_glo) + REAL pcu(klon_glo),pcv(klon_glo) + INTEGER pdayref + INTEGER :: ibegin,iend,offset + + REAL ptimestep + + IF (nlayer.NE.klev) THEN + PRINT*,'STOP in inifis' + PRINT*,'Probleme de dimensions :' + PRINT*,'nlayer = ',nlayer + PRINT*,'klev = ',klev + STOP + ENDIF + + IF (ngrid.NE.klon_glo) THEN + PRINT*,'STOP in inifis' + PRINT*,'Probleme de dimensions :' + PRINT*,'ngrid = ',ngrid + PRINT*,'klon = ',klon_glo + STOP + ENDIF +c$OMP PARALLEL PRIVATE(ibegin,iend) +c$OMP+ SHARED(parea,pcu,pcv,plon,plat) + + offset=klon_mpi_begin-1 + airephy(1:klon_omp)=parea(offset+klon_omp_begin: + & offset+klon_omp_end) + cuphy(1:klon_omp)=pcu(offset+klon_omp_begin:offset+klon_omp_end) + cvphy(1:klon_omp)=pcv(offset+klon_omp_begin:offset+klon_omp_end) + rlond(1:klon_omp)=plon(offset+klon_omp_begin:offset+klon_omp_end) + rlatd(1:klon_omp)=plat(offset+klon_omp_begin:offset+klon_omp_end) + + call suphel + +c$OMP END PARALLEL + + print*,'ATTENTION !!! TRAVAILLER SUR INIPHYSIQ' + print*,'CONTROLE DES LATITUDES, LONGITUDES, PARAMETRES ...' + + RETURN +9999 STOP'Cette version demande les fichier rnatur.dat et surf.def' + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/iniradia.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/iniradia.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/iniradia.F (revision 1280) @@ -0,0 +1,32 @@ + SUBROUTINE iniradia (klon,klev,pres) + + IMPLICIT none +c====================================================================== +c +c Auteur(s) MP Lefebvre date: 20080827 +c +c Objet: initialise le rayonnement RRTM +c====================================================================== +c Arguments: +c +c klon----input-I-nombre de points horizontaux +c klev----input-I-nombre de couches verticales +c pres----input-R-pression pour chaque inter-couche (en Pa) +c====================================================================== +c + INTEGER klon + INTEGER klev + REAL pres(klev+1) + +! CALL suphel ! initialiser constantes et parametres phys. +! print*,'Physiq: apres suphel ' +! CALL SUINIT(klon,klev) +! print*,'iniradia: apres suinit ' +! calcul des niveaux de pression de reference au bord des couches pour +! l'intialisation des aerosols. Momentannement, on passe un point de +! grille du profil de pression. +! CALL SURAYOLMD(pres(klev+1)) ! initialiser le rayonnement RRTM +! print*,'iniradia: apres surayolmd ' + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/init_be.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/init_be.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/init_be.F90 (revision 1280) @@ -0,0 +1,510 @@ +!$Id $ + +SUBROUTINE init_be(pctsrf,masktr,tautr,vdeptr,scavtr,srcbe) + + USE dimphy + USE comgeomphy + USE infotrac, ONLY : nbtr + + IMPLICIT NONE +!===================================================================== +! Objet : prescription d'une source de Beryllium 7 +! pour 19 niveaux verticaux +! (d'apres le diagramme de Lal and Peters, 1967) +! +! +! written by : O. Coindreau (CEA/LDG) 05/2005 +! last modified by : A. Jamelot (LMD/CEA) 04/03/2009 +!===================================================================== + + INCLUDE "YOMCST.h" + INCLUDE "YOECUMF.h" + INCLUDE "indicesol.h" + +! +! Input Arguments +! + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf !Pourcentage de sol (f(nature du sol)) +! +! Output Arguments +! + REAL,DIMENSION(klon),INTENT(OUT) :: masktr ! Masque de l'echange avec la surface (possible => 1 ) + REAL,INTENT(OUT) :: tautr ! Constante de decroissance radioactive + REAL,INTENT(OUT) :: vdeptr ! Vitesse de depot sec dans la couche Brownienne + REAL,INTENT(OUT) :: scavtr ! Coefficient de lessivage + REAL,DIMENSION(klon,klev),INTENT(OUT) :: srcbe ! source volumique de 7Be +! +! Local Variables +! + REAL,DIMENSION(klon) :: rlatgeo ! latitudes geomagnetiques de la grille + REAL :: glt ! latitude du pole geomagnetique + REAL :: glg ! longitude du pole geomagnetique + REAL :: latgeo,qcos + INTEGER :: k,i + + WRITE(*,*)'PASSAGE init_be ...' + +! Source actuellement definie pour klev = 19 et klev >= 39 + IF (klev /= 19 .AND. klev<39) CALL abort_gcm("init_be","Source du be7 necessite klev=19 ou klev>=39",1) +! +! Definition des constantes +! ------------------------- + tautr = 6645000. + vdeptr = 1.E-3 + scavtr = 0.5 + + WRITE(*,*) '-------------- SOURCE DE BERYLLIUM ------------------- ' + WRITE(*,*)'Decroissance (s): ', tautr + WRITE(*,*)'Vitesse de depot sec: ',vdeptr + WRITE(*,*)'Facteur de lessivage: ',scavtr + + DO i = 1,klon + masktr(i) = 0. + IF ( NINT(pctsrf(i,1)) .EQ. 1 ) masktr(i) = 1. + END DO + +! Premiers niveaux: source nulle +! ------------------------------ + DO k = 1,6 + DO i = 1,klon + srcbe(i,k) = 0. + END DO + END DO +! +! Pour les autres niveaux: +! 1-passer des coordonnees geographiques a la latitude geomagnetique +! 2-prescrire la source de Be (en 10exp5 at/g/s) dans ce repere +! 3-mettre la source de Be ds la bonne unite (en at/kgA/s) +! + glt=78.5*rpi/180. + glg=69.0*rpi/180. + + DO i = 1,klon + qcos=sin(glt)*sin(rlatd(i)) + qcos=qcos+cos(glt)*cos(rlatd(i))*cos(rlond(i)+glg) + IF ( qcos .LT. -1.) qcos = -1. + IF ( qcos .GT. 1.) qcos = 1. + rlatgeo(i)=rpi/2.-acos(qcos) + ENDDO + +!=========================== +! Cas 19 niveaux verticaux +!=========================== + IF (klev.eq.19) then + DO k = 1,klev + DO i = 1,klon + latgeo=(180./rpi)*abs(rlatgeo(i)) + IF ( k .EQ. 1 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.1 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.09 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.07 + END IF + IF ( k .EQ. 2 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.12 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.1 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.09 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.07 + END IF + IF ( k .EQ. 3 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.14 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.12 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.1 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.09 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.07 + END IF + IF ( k .EQ. 4 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.175 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.16 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.14 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.12 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.1 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.09 + END IF + IF ( k .EQ. 5 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.28 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.26 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.23 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.175 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.14 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.12 + END IF + IF ( k .EQ. 6 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.56 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.49 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.42 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.28 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.26 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.245 + END IF + IF ( k .EQ. 7 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=1.05 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.875 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.7 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.52 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.44 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.385 + END IF + IF ( k .EQ. 8 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=2. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=1.8 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=1.5 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=1. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.8 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.75 + END IF + IF ( k .EQ. 9 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=4. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=3.5 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=3. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=2.5 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=1.8 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=1.4 + END IF + IF ( k .EQ. 10 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=8.5 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=8. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=7. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=4.5 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=3.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=3. + END IF + IF ( k .EQ. 11 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=17. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=15. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=11. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=8. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=5. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=4. + END IF + IF ( k .EQ. 12 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=25. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=22. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=17. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=11. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=7.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7. + END IF + IF ( k .EQ. 13 ) THEN + IF (latgeo.GE.60.0) srcbe(i,k)=33. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=32. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=30. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=22. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=11. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=8. + END IF + IF ( k .EQ. 14 ) THEN + IF (latgeo.GE.60.0) srcbe(i,k)=48. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=45. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=36. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=26. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=17.5 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10. + END IF + IF ( k .EQ. 15 ) THEN + IF (latgeo.GE.70.0) srcbe(i,k)=58. + IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=57. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=38. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=25. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10. + END IF + IF ( k .EQ. 16 ) THEN + IF (latgeo.GE.70.0) srcbe(i,k)=70. + IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=65. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=32. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=20. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=13. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=9. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.5 + END IF + IF ( k .GE. 17 ) THEN + IF (latgeo.GE.70.0) srcbe(i,k)=80. + IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=70. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=45. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=27. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=17.5 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=12. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=8. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7. + END IF + END DO + END DO + END IF ! fin de 19 niveaux verticaux + +!================================ +! Cas 39 niveaux verticaux +!================================ + IF (klev .ge. 39) then + DO k = 1,klev + DO i = 1,klon + latgeo=(180./rpi)*abs(rlatgeo(i)) + IF ( k .LE. 4 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.07 + END IF + IF ( k .EQ. 5 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.1 + IF (latgeo.GE.20.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.09 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.07 + END IF + IF ( k .EQ. 6 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.14 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.12 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.1 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.09 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.07 + END IF + IF ( k .EQ. 7 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.16 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.16 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.14 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.12 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.1 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.09 + END IF + IF ( k .EQ. 8 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.175 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.16 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.14 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.12 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.1 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.1 + END IF + IF ( k .EQ. 9 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.245 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.21 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.175 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.14 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.12 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.12 + END IF + IF ( k .EQ. 10 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.31 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.28 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.245 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.21 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.16 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.14 + END IF + IF ( k .EQ. 11 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.35 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.3 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.3 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.2 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.18 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.16 + END IF + IF ( k .EQ. 12 ) THEN + IF (latgeo.GE.40.0) srcbe(i,k)=0.5 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.4 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.35 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.3 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.25 + END IF + IF ( k .EQ. 13 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.8 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.7 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.6 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.5 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.4 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.35 + END IF + IF ( k .EQ. 14 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=1.2 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=1. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.75 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.6 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.4 + END IF + IF ( k .EQ. 15 ) THEN + IF (latgeo.GE.60.0) srcbe(i,k)=1.75 + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=1.8 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=1.6 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=1.4 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.9 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.75 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.65 + END IF + IF ( k .EQ. 16 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=3. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=2.5 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=1.8 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=1.5 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=1.2 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.9 + END IF + IF ( k .EQ. 17 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=4. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=3. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=2.5 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=2. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=1.6 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=1.4 + END IF + IF ( k .EQ. 18 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=7. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=6. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=4.5 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=3.5 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=3. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=2. + END IF + IF ( k .EQ. 19 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=8.5 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=8. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=7. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=4. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=3.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=3. + END IF + IF ( k .EQ. 20 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=12.5 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=12. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=8. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=6. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=4. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=3.5 + END IF + IF ( k .EQ. 21 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=16. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=13. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=10. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=7.5 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=4.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=4. + END IF + IF ( k .EQ. 22 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=20. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=17.5 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=12.5 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=9. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=6. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=4.5 + END IF + IF ( k .EQ. 23 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=25. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=22. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=15. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=10. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=7.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=6. + END IF + IF ( k .EQ. 24 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=28. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=26. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=18. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=12. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=8.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7. + END IF + IF ( k .EQ. 25 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=33. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=28. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=20. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=14. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=10. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=8.5 + END IF + IF ( k .EQ. 26 ) THEN + IF (latgeo.GE.60.0) srcbe(i,k)=38. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=36. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=32. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=24. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=11.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=6. + END IF + IF ( k .EQ. 27 ) THEN + IF (latgeo.GE.60.0) srcbe(i,k)=46. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=44. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=35. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=25. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=16. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10. + END IF + IF ( k .EQ. 28 ) THEN + IF (latgeo.GE.60.0) srcbe(i,k)=53. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=48. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=37. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=25. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=16. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10. + END IF + IF ( k .EQ. 29 ) THEN + IF (latgeo.GE.70.0) srcbe(i,k)=58. + IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=56. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=36. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=24. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=11.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10. + END IF + IF ( k .EQ. 30 ) THEN + IF (latgeo.GE.70.0) srcbe(i,k)=65. + IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=60. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=35. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=22. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=14. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=10. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=9. + END IF + IF ( k .EQ. 31 ) THEN + IF (latgeo.GE.70.0) srcbe(i,k)=70. + IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=62. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=48. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=32. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=21. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=13. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=9. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.6 + END IF + IF ( k .EQ. 32 ) THEN + IF (latgeo.GE.70.0) srcbe(i,k)=80. + IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=60. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=46. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=30. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=17.5 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=11. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=8. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.4 + END IF + IF ( k .GE. 33 ) THEN + IF (latgeo.GE.70.0) srcbe(i,k)=80. + IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=70. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=45. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=27. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=15. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=10. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=7.6 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7. + END IF + END DO + END DO + END IF ! fin de 39 niveaux verticaux + + +!==================================== +! Conversion de la source en U/s/kgA +!==================================== + DO k = 1,klev + DO i = 1,klon + ! La source est at/min/m3 -> at/s/kgA + ! avec une masse volumique de l'air = 1.295 kg/m3 + ! 1/(60*1.295) = 0.01287 + srcbe(i,k)=srcbe(i,k)*0.01287 + ! La source est at/min/m3 -> at/s/m3 + ! srcbe(i,k)=srcbe(i,k)*0.0166667 + END DO + END DO + +END SUBROUTINE init_be Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/init_phys_lmdz.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/init_phys_lmdz.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/init_phys_lmdz.F90 (revision 1280) @@ -0,0 +1,23 @@ +! +!$Header$ +! +SUBROUTINE Init_Phys_lmdz(iim,jjp1,llm,nb_proc,distrib) + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz + USE dimphy, ONLY : Init_dimphy + IMPLICIT NONE + + INTEGER,INTENT(in) :: iim + INTEGER,INTENT(in) :: jjp1 + INTEGER,INTENT(in) :: llm + INTEGER,INTENT(in) :: nb_proc + INTEGER,INTENT(in) :: distrib(0:nb_proc-1) + + + CALL Init_grid_phy_lmdz(iim,jjp1,llm) + CALL Init_phys_lmdz_para(iim,jjp1,nb_proc,distrib) +!$OMP PARALLEL + CALL Init_dimphy(klon_omp,nbp_lev) +!$OMP END PARALLEL + +END SUBROUTINE Init_Phys_lmdz Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/initphysto.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/initphysto.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/initphysto.F (revision 1280) @@ -0,0 +1,304 @@ +! +! $Header$ +! +C +C + subroutine initphysto + . (infile, + . rlon, rlat, tstep,t_ops,t_wrt,nq,fileid) + + USE dimphy + USE mod_phys_lmdz_para + USE IOIPSL + USE iophy + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C infile: nom du fichier histoire a creer +C day0,anne0: date de reference +C tstep: duree du pas de temps en seconde +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C nq: nombre de traceurs +C +C Sortie: +C fileid: ID du fichier netcdf cree +C filevid:ID du fichier netcdf pour la grille v +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "indicesol.h" +#include "control.h" +cym#include "dimphy.h" + +C Arguments + character*(*) infile + integer nhoriid, i + real tstep, t_ops, t_wrt + integer fileid, filevid + integer nq,l + real nivsigs(llm) + +C Variables locales +C + integer tau0 + real zjulian + character*3 str + character*10 ctrac + integer iq + integer uhoriid, vhoriid, thoriid, zvertiid + integer ii,jj + integer zan, idayref + logical ok_sync + REAL zx_lon(iim,jjm+1), zx_lat(iim,jjm+1) +C + REAL rlon(klon), rlat(klon) + +C Initialisations +C + pi = 4. * atan (1.) + str='q ' + ctrac = 'traceur ' + ok_sync= .true. +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = annee_ref + idayref = day_ref + CALL ymds2ju(zan, 1, idayref, 0.0, zjulian) + tau0 = 0 + +cym CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon) +cym DO i = 1, iim +cym zx_lon(i,1) = rlon(i+1) +cym zx_lon(i,jjm+1) = rlon(i+1) +cym ENDDO +cym CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat) + + + call histbeg_phy(infile,tau0, zjulian, tstep, + . nhoriid, fileid) + +c$OMP MASTER +C Appel a histvert pour la grille verticale +C + DO l=1,llm + nivsigs(l)=float(l) + ENDDO + + write(*,*) 'avant histvert ds initphysto' + + call histvert(fileid, 'sig_s', 'Niveaux sigma', + . 'sigma_level', + . llm, nivsigs, zvertiid) +C +C Appels a histdef pour la definition des variables a sauvegarder +C + write(*,*) 'apres histvert ds initphysto' + + CALL histdef(fileid, "phis", "Surface geop. height", "-", + . iim,jj_nb,nhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) +c + write(*,*) 'apres phis ds initphysto' + + CALL histdef(fileid, "aire", "Grid area", "-", + . iim,jj_nb,nhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + write(*,*) 'apres aire ds initphysto' + +cym Attention dtime et istphy ne sont pas �rit ---> a �iminer ? + CALL histdef(fileid, "dtime", "tps phys ", "s", + . 1,1,nhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(fileid, "istphy", "tps stock", "s", + . 1,1,nhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + +C T +C + call histdef(fileid, 't', 'Temperature', 'K', + . iim, jj_nb, nhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + write(*,*) 'apres t ds initphysto' +C mfu +C + call histdef(fileid, 'mfu', 'flx m. pan. mt', 'kg m/s', + . iim, jj_nb, nhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + write(*,*) 'apres mfu ds initphysto' +C +C mfd +C + call histdef(fileid, 'mfd', 'flx m. pan. des', 'kg m/s', + . iim, jj_nb, nhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +C +C en_u +C + call histdef(fileid, 'en_u', 'flx ent pan mt', 'kg m/s', + . iim, jj_nb, nhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + write(*,*) 'apres en_u ds initphysto' +C +C de_u +C + call histdef(fileid, 'de_u', 'flx det pan mt', 'kg m/s', + . iim, jj_nb, nhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +C +C en_d +C + call histdef(fileid, 'en_d', 'flx ent pan dt', 'kg m/s', + . iim, jj_nb, nhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C + +C +C de_d +C + call histdef(fileid, 'de_d', 'flx det pan dt', 'kg m/s', + . iim, jj_nb, nhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +c coefh frac_impa,frac_nucl + + call histdef(fileid, "coefh", " ", " ", + . iim, jj_nb, nhoriid, llm, 1, llm, zvertiid, + . 32, "inst(X)", t_ops, t_wrt) + +c abderrahmane le 16 09 02 + call histdef(fileid, "fm_th", " ", " ", + . iim, jj_nb, nhoriid, llm, 1, llm, zvertiid, + . 32, "inst(X)", t_ops, t_wrt) + + call histdef(fileid, "en_th", " ", " ", + . iim, jj_nb, nhoriid, llm, 1, llm, zvertiid, + . 32, "inst(X)", t_ops, t_wrt) +c fin aj + + write(*,*) 'apres coefh ds initphysto' + + call histdef(fileid, 'frac_impa', ' ', ' ', + . iim, jj_nb, nhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + + call histdef(fileid, 'frac_nucl', ' ', ' ', + . iim, jj_nb, nhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +c +c pyu1 +c + CALL histdef(fileid, "pyu1", " ", " ", + . iim,jj_nb,nhoriid, 1,1,1, -99, 32, + . "inst(X)", t_ops, t_wrt) + +c +c pyv1 +c + CALL histdef(fileid, "pyv1", " ", " ", + . iim,jj_nb,nhoriid, 1,1,1, -99, 32, + . "inst(X)", t_ops, t_wrt) + + write(*,*) 'apres pyv1 ds initphysto' +c +c ftsol1 +c + call histdef(fileid, "ftsol1", " ", " ", + . iim, jj_nb, nhoriid, 1, 1,1, -99,32, + . "inst(X)", t_ops, t_wrt) + +c +c ftsol2 +c + call histdef(fileid, "ftsol2", " ", " ", + . iim, jj_nb, nhoriid, 1, 1,1, -99,32, + . "inst(X)", t_ops, t_wrt) + +c +c ftsol3 +c + call histdef(fileid, "ftsol3", " ", " ", + . iim, jj_nb, nhoriid, 1, 1,1, -99, + . 32, "inst(X)", t_ops, t_wrt) + +c +c ftsol4 +c + call histdef(fileid, "ftsol4", " ", " ", + . iim, jj_nb, nhoriid, 1, 1,1, -99, + . 32, "inst(X)", t_ops, t_wrt) + +c +c rain +c + call histdef(fileid, "rain", " ", " ", + . iim, jj_nb, nhoriid, 1, 1,1, -99, + . 32, "inst(X)", t_ops, t_wrt) + +c +c psrf1 +c + call histdef(fileid, "psrf1", " ", " ", + . iim, jj_nb, nhoriid, 1, 1, 1, -99, + . 32, "inst(X)", t_ops, t_wrt) + +c +c psrf2 +c + call histdef(fileid, "psrf2", " ", " ", + . iim, jj_nb, nhoriid, 1, 1, 1, -99, + . 32, "inst(X)", t_ops, t_wrt) + +c +c psrf3 +c + call histdef(fileid, "psrf3", " ", " ", + . iim, jj_nb, nhoriid, 1, 1, 1, -99, + . 32, "inst(X)", t_ops, t_wrt) + +c +c psrf4 +c + call histdef(fileid, "psrf4", " ", " ", + . iim, jj_nb, nhoriid, 1, 1, 1, -99, + . 32, "inst(X)", t_ops, t_wrt) + + write(*,*) 'avant histend ds initphysto' + + call histend(fileid) +c if (ok_sync) call histsync(fileid) + if (ok_sync) call histsync +c$OMP END MASTER + + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/initrrnpb.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/initrrnpb.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/initrrnpb.F90 (revision 1280) @@ -0,0 +1,92 @@ +! +! $Id $ +! +SUBROUTINE initrrnpb(ftsol,pctsrf,masktr,fshtr,hsoltr,tautr,vdeptr,scavtr) + USE dimphy + USE infotrac, ONLY : nbtr + IMPLICIT NONE +!====================================================================== +! Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94 +! Objet: initialisation des constantes des traceurs +!AA Revison pour le controle avec la temperature du sol +!AA +!AA it = 1 radon ss controle de ts +!AA it = 2 plomb ss controle de ts +!====================================================================== +! Arguments: +! nbtr.............. nombre de vrais traceurs (sans l'eau) +! ftsol....input-R- Temperature du sol (Kelvin) +! pctsrf...input-R- Nature de sol (pourcentage de sol) +! masktr...output-R- Masque reservoir de sol traceur (1 = reservoir) +! fshtr....output-R- Flux surfacique de production dans le reservoir de sol +! hsoltr...output-R- Epaisseur equivalente du reservoir de sol +! tautr....output-R- Constante de decroissance radioactive du traceur +! vdeptr...output-R- Vitesse de depot sec dans la couche Brownienne +! scavtr...output-R- Coefficient de lessivage +!====================================================================== + INCLUDE "indicesol.h" +!====================================================================== + + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol + REAL,DIMENSION(klon,nbtr),INTENT(OUT) :: masktr + REAL,DIMENSION(klon,nbtr),INTENT(OUT) :: fshtr + REAL,DIMENSION(nbtr),INTENT(OUT) :: hsoltr + REAL,DIMENSION(nbtr),INTENT(OUT) :: tautr + REAL,DIMENSION(nbtr),INTENT(OUT) :: vdeptr + REAL,DIMENSION(nbtr),INTENT(OUT) :: scavtr + INTEGER :: i, it + REAL :: s + + WRITE(*,*)'PASSAGE initrrnpb ...' +! +! Radon it = 1 +!---------------- + IF ( nbtr .LE. 0 ) STOP '**PHYTRAC:initrrnpb:** nbtr < 0; verifier RN dans traceur.def' + it = 1 + s = 1.E4 ! Source: atome par m2 + hsoltr(it) = 0.1 ! Hauteur equivalente du reservoir : + ! 1 m * porosite 0.1 + tautr(it) = 4.765E5 ! Decroissance du radon, secondes + vdeptr(it) = 0. ! Pas de depot sec pour le radon + scavtr(it) = 0. ! Pas de lessivage pour le radon + + WRITE(*,*)'-------------- SOURCE DU RADON ------------------------ ' + WRITE(*,*)'it = ',it + WRITE(*,*)'Source : ', s + WRITE(*,*)'Hauteur equivalente du reservoir de sol: ',hsoltr(it) + WRITE(*,*)'Decroissance (s): ', tautr(it) + WRITE(*,*)'Vitesse de depot sec: ',vdeptr(it) + WRITE(*,*)'Facteur de lessivage: ',scavtr(it) + + DO i = 1,klon + masktr(i,it) = 0. + IF ( NINT(pctsrf(i,1)) .EQ. 1 ) masktr(i,it) = 1. + fshtr(i,it) = s * masktr(i,it) + END DO +! +! 210Pb it = 2 +!---------------- + IF ( nbtr .LE. 1 ) STOP '**PHYTRAC**:initrrnpb:** nbtr <= 1; verifier PB dans traceur.def' + it = 2 + s = 0. ! Pas de source + hsoltr(it) = 10. ! Hauteur equivalente du reservoir + ! a partir duquel le depot Brownien a lieu + tautr(it) = 1.028E9 ! Decroissance du Pb210, secondes + vdeptr(it) = 1.E-3 ! 1 mm/s pour le 210Pb + scavtr(it) = .5 ! Lessivage du Pb210 + DO i = 1,klon + masktr(i,it) = 1. ! Le depot sec peut avoir lieu partout + fshtr(i,it) = s * masktr(i,it) + END DO + WRITE(*,*)'-------------- SOURCE DU PLOMB ------------------------ ' + WRITE(*,*)'it = ',it + WRITE(*,*)'Source : ', s + WRITE(*,*)'Hauteur equivalente du reservoir : ',hsoltr(it) + WRITE(*,*)'Decroissance (s): ', tautr(it) + WRITE(*,*)'Vitesse de depot sec: ',vdeptr(it) + WRITE(*,*)'Facteur de lessivage: ',scavtr(it) + + WRITE(*,*) 'Initialisation RN et PB ok' + +END SUBROUTINE initrrnpb Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/interfoce_lim.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/interfoce_lim.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/interfoce_lim.F90 (revision 1280) @@ -0,0 +1,289 @@ +! +! $Header$ +! +SUBROUTINE interfoce_lim(itime, dtime, jour, & + knon, knindex, & + debut, & + lmt_sst_p, pctsrf_new_p) + + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + + IMPLICIT NONE + + INCLUDE "indicesol.h" + INCLUDE "netcdf.inc" + +! Cette routine sert d'interface entre le modele atmospherique et un fichier +! de conditions aux limites +! +! L. Fairhead 02/2000 +! +! input: +! itime numero du pas de temps courant +! dtime pas de temps de la physique (en s) +! jour jour a lire dans l'annee +! nisurf index de la surface a traiter (1 = sol continental) +! knon nombre de points dans le domaine a traiter +! knindex index des points de la surface a traiter +! klon taille de la grille +! debut logical: 1er appel a la physique (initialisation) +! +! output: +! lmt_sst_p SST lues dans le fichier de CL +! pctsrf_new-p sous-maille fractionnelle +! + + +! Parametres d'entree +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime + INTEGER, INTENT(IN) :: jour + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon_loc), INTENT(IN) :: knindex + REAL , INTENT(IN) :: dtime + LOGICAL, INTENT(IN) :: debut + +! Parametres de sortie +!**************************************************************************************** + REAL, INTENT(OUT), DIMENSION(klon_loc) :: lmt_sst_p + REAL, INTENT(OUT), DIMENSION(klon_loc,nbsrf) :: pctsrf_new_p + + +! Variables locales avec l'attribut SAVE +!**************************************************************************************** +! frequence de lecture des conditions limites (en pas de physique) + INTEGER,SAVE :: lmt_pas + !$OMP THREADPRIVATE(lmt_pas) +! pour indiquer que le jour a lire est deja lu pour une surface precedente + LOGICAL,SAVE :: deja_lu + !$OMP THREADPRIVATE(deja_lu) + INTEGER,SAVE :: jour_lu + !$OMP THREADPRIVATE(jour_lu) + CHARACTER (len = 20),SAVE :: fich ='limit.nc' + !$OMP THREADPRIVATE(fich) + LOGICAL, SAVE :: newlmt = .TRUE. + !$OMP THREADPRIVATE(newlmt) + LOGICAL, SAVE :: check = .FALSE. + !$OMP THREADPRIVATE(check) + REAL, ALLOCATABLE , SAVE, DIMENSION(:) :: sst_lu_p + !$OMP THREADPRIVATE(sst_lu_p) + REAL, ALLOCATABLE , SAVE, DIMENSION(:,:) :: pct_tmp_p + !$OMP THREADPRIVATE(pct_tmp_p) + +! Variables locales +!**************************************************************************************** + INTEGER :: nid, nvarid + INTEGER :: ii + INTEGER :: ierr + INTEGER, DIMENSION(2) :: start, epais + CHARACTER (len = 20) :: modname = 'interfoce_lim' + CHARACTER (len = 80) :: abort_message + REAL, DIMENSION(klon_glo,nbsrf) :: pctsrf_new + REAL, DIMENSION(klon_glo,nbsrf) :: pct_tmp + REAL, DIMENSION(klon_glo) :: sst_lu + REAL, DIMENSION(klon_glo) :: nat_lu +! +! Fin declaration +!**************************************************************************************** + +!**************************************************************************************** +! Start calculation +! +!**************************************************************************************** + IF (debut .AND. .NOT. ALLOCATED(sst_lu_p)) THEN + lmt_pas = NINT(86400./dtime * 1.0) ! pour une lecture une fois par jour + jour_lu = jour - 1 + ALLOCATE(sst_lu_p(klon_loc)) + ALLOCATE(pct_tmp_p(klon_loc,nbsrf)) + ENDIF + + IF ((jour - jour_lu) /= 0) deja_lu = .FALSE. + + IF (check) WRITE(*,*) modname, ' :: jour, jour_lu, deja_lu', jour, jour_lu, deja_lu + IF (check) WRITE(*,*) modname, ' :: itime, lmt_pas ', itime, lmt_pas,dtime + +!**************************************************************************************** +! Ouverture et lecture du fichier pour le master process si c'est le bon moment +! +!**************************************************************************************** +! Tester d'abord si c'est le moment de lire le fichier + IF (MOD(itime-1, lmt_pas) == 0 .AND. .NOT. deja_lu) THEN + +!$OMP MASTER + IF (is_mpi_root) THEN + + fich = TRIM(fich) + ierr = NF_OPEN (fich, NF_NOWRITE,nid) + IF (ierr.NE.NF_NOERR) THEN + abort_message = 'Pb d''ouverture du fichier de conditions aux limites' + CALL abort_gcm(modname,abort_message,1) + ENDIF + + ! La tranche de donnees a lire: + + start(1) = 1 + start(2) = jour + epais(1) = klon_glo + epais(2) = 1 + + IF (newlmt) THEN + ! + ! Fraction "ocean" + ! + ierr = NF_INQ_VARID(nid, 'FOCE', nvarid) + IF (ierr /= NF_NOERR) THEN + abort_message = 'Le champ est absent' + CALL abort_gcm(modname,abort_message,1) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_oce)) +#else + ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_oce)) +#endif + IF (ierr /= NF_NOERR) THEN + abort_message = 'Lecture echouee pour ' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ! + ! Fraction "glace de mer" + ! + ierr = NF_INQ_VARID(nid, 'FSIC', nvarid) + IF (ierr /= NF_NOERR) THEN + abort_message = 'Le champ est absent' + CALL abort_gcm(modname,abort_message,1) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_sic)) +#else + ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_sic)) +#endif + IF (ierr /= NF_NOERR) THEN + abort_message = 'Lecture echouee pour ' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ! + ! Fraction "terre" + ! + ierr = NF_INQ_VARID(nid, 'FTER', nvarid) + IF (ierr /= NF_NOERR) THEN + abort_message = 'Le champ est absent' + CALL abort_gcm(modname,abort_message,1) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_ter)) +#else + ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_ter)) +#endif + IF (ierr /= NF_NOERR) THEN + abort_message = 'Lecture echouee pour ' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ! + ! Fraction "glacier terre" + ! + ierr = NF_INQ_VARID(nid, 'FLIC', nvarid) + IF (ierr /= NF_NOERR) THEN + abort_message = 'Le champ est absent' + CALL abort_gcm(modname,abort_message,1) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_lic)) +#else + ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_lic)) +#endif + IF (ierr /= NF_NOERR) THEN + abort_message = 'Lecture echouee pour ' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ! + ELSE ! on en est toujours a rnatur + ! + ierr = NF_INQ_VARID(nid, 'NAT', nvarid) + IF (ierr /= NF_NOERR) THEN + abort_message = 'Le champ est absent' + CALL abort_gcm(modname,abort_message,1) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, nat_lu) +#else + ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, nat_lu) +#endif + IF (ierr /= NF_NOERR) THEN + abort_message = 'Lecture echouee pour ' + CALL abort_gcm(modname,abort_message,1) + ENDIF +! +! Remplissage des fractions de surface +! nat = 0, 1, 2, 3 pour ocean, terre, glacier, seaice +! + pct_tmp = 0.0 + DO ii = 1, klon_glo + pct_tmp(ii,NINT(nat_lu(ii)) + 1) = 1. + ENDDO + +! +! On se retrouve avec ocean en 1 et terre en 2 alors qu'on veut le contraire +! + pctsrf_new = pct_tmp + pctsrf_new (:,2)= pct_tmp (:,1) + pctsrf_new (:,1)= pct_tmp (:,2) + pct_tmp = pctsrf_new + ENDIF ! fin test sur newlmt +! +! Lecture SST +! + ierr = NF_INQ_VARID(nid, 'SST', nvarid) + IF (ierr /= NF_NOERR) THEN + abort_message = 'Le champ est absent' + CALL abort_gcm(modname,abort_message,1) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, sst_lu) +#else + ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, sst_lu) +#endif + IF (ierr /= NF_NOERR) THEN + abort_message = 'Lecture echouee pour ' + CALL abort_gcm(modname,abort_message,1) + ENDIF + +!**************************************************************************************** +! Fin de lecture, fermeture de fichier +! +!**************************************************************************************** + ierr = NF_CLOSE(nid) + ENDIF ! is_mpi_root + +!$OMP END MASTER +!$OMP BARRIER + + +!**************************************************************************************** +! Distribue les variables sur tous les processus +! +!**************************************************************************************** + CALL Scatter(sst_lu,sst_lu_p) + CALL Scatter(pct_tmp(:,is_oce),pct_tmp_p(:,is_oce)) + CALL Scatter(pct_tmp(:,is_sic),pct_tmp_p(:,is_sic)) + deja_lu = .TRUE. + jour_lu = jour + ENDIF + +!**************************************************************************************** +! Recopie des variables dans les champs de sortie +! +!**************************************************************************************** + lmt_sst_p = 999999999. + + DO ii = 1, knon + lmt_sst_p(ii) = sst_lu_p(knindex(ii)) + ENDDO + + DO ii=1,klon_loc + pctsrf_new_p(ii,is_oce)=pct_tmp_p(ii,is_oce) + pctsrf_new_p(ii,is_sic)=pct_tmp_p(ii,is_sic) + ENDDO + + +END SUBROUTINE interfoce_lim Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/iophy.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/iophy.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/iophy.F90 (revision 1280) @@ -0,0 +1,210 @@ +! +! $Header$ +! +module iophy + + REAL,private,allocatable,dimension(:,:),save :: tmp_tab2d + REAL,private,allocatable,dimension(:,:,:),save :: tmp_tab3d + INTEGER,private,allocatable,dimension(:),save :: ndex2d + INTEGER,private,allocatable,dimension(:),save :: ndex3d +! abd REAL,private,allocatable,dimension(:),save :: io_lat +! abd REAL,private,allocatable,dimension(:),save :: io_lon + REAL,allocatable,dimension(:),save :: io_lat + REAL,allocatable,dimension(:),save :: io_lon + INTEGER, save :: phys_domain_id + + INTERFACE histwrite_phy + MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy + END INTERFACE + + +contains + + subroutine init_iophy_new(rlat,rlon) + USE dimphy + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz + USE ioipsl + implicit none + include 'dimensions.h' + real,dimension(klon),intent(in) :: rlon + real,dimension(klon),intent(in) :: rlat + + REAL,dimension(klon_glo) :: rlat_glo + REAL,dimension(klon_glo) :: rlon_glo + + INTEGER,DIMENSION(2) :: ddid + INTEGER,DIMENSION(2) :: dsg + INTEGER,DIMENSION(2) :: dsl + INTEGER,DIMENSION(2) :: dpf + INTEGER,DIMENSION(2) :: dpl + INTEGER,DIMENSION(2) :: dhs + INTEGER,DIMENSION(2) :: dhe + INTEGER :: i + + CALL gather(rlat,rlat_glo) + CALL bcast(rlat_glo) + CALL gather(rlon,rlon_glo) + CALL bcast(rlon_glo) + +!$OMP MASTER + ALLOCATE(io_lat(jjm+1-1/iim)) + io_lat(1)=rlat_glo(1) + io_lat(jjm+1-1/iim)=rlat_glo(klon_glo) + IF (iim > 1) then + DO i=2,jjm + io_lat(i)=rlat_glo(2+(i-2)*iim) + ENDDO + ENDIF + + ALLOCATE(io_lon(iim)) + io_lon(:)=rlon_glo(2-1/iim:iim+1-1/iim) + + + allocate(tmp_tab2d(iim,jj_nb)) + allocate(tmp_tab3d(iim,jj_nb,klev)) + allocate(ndex2d(iim*jj_nb)) + allocate(ndex3d(iim*jj_nb*klev)) + ndex2d(:)=0 + ndex3d(:)=0 + + ddid=(/ 1,2 /) + dsg=(/ iim, jjm+1-1/iim /) + dsl=(/ iim, jj_nb /) + dpf=(/ 1,jj_begin /) + dpl=(/ iim, jj_end /) + dhs=(/ ii_begin-1,0 /) + if (mpi_rank==mpi_size-1) then + dhe=(/0,0/) + else + dhe=(/ iim-ii_end,0 /) + endif + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, & + 'APPLE',phys_domain_id) + +!$OMP END MASTER + + end subroutine init_iophy_new + + subroutine init_iophy(lat,lon) + USE dimphy + USE mod_phys_lmdz_para + use ioipsl + implicit none + include 'dimensions.h' + real,dimension(iim),intent(in) :: lon + real,dimension(jjm+1-1/iim),intent(in) :: lat + + INTEGER,DIMENSION(2) :: ddid + INTEGER,DIMENSION(2) :: dsg + INTEGER,DIMENSION(2) :: dsl + INTEGER,DIMENSION(2) :: dpf + INTEGER,DIMENSION(2) :: dpl + INTEGER,DIMENSION(2) :: dhs + INTEGER,DIMENSION(2) :: dhe + +!$OMP MASTER + allocate(io_lat(jjm+1-1/iim)) + io_lat(:)=lat(:) + allocate(io_lon(iim)) + io_lon(:)=lon(:) + allocate(tmp_tab2d(iim,jj_nb)) + allocate(tmp_tab3d(iim,jj_nb,klev)) + allocate(ndex2d(iim*jj_nb)) + allocate(ndex3d(iim*jj_nb*klev)) + ndex2d(:)=0 + ndex3d(:)=0 + + ddid=(/ 1,2 /) + dsg=(/ iim, jjm+1-1/iim /) + dsl=(/ iim, jj_nb /) + dpf=(/ 1,jj_begin /) + dpl=(/ iim, jj_end /) + dhs=(/ ii_begin-1,0 /) + if (mpi_rank==mpi_size-1) then + dhe=(/0,0/) + else + dhe=(/ iim-ii_end,0 /) + endif + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, & + 'APPLE',phys_domain_id) + +!$OMP END MASTER + + end subroutine init_iophy + + subroutine histbeg_phy(name,itau0,zjulian,dtime,nhori,nid_day) + USE dimphy + USE mod_phys_lmdz_para + use ioipsl + use write_field + implicit none + include 'dimensions.h' + + character*(*), intent(IN) :: name + integer, intent(in) :: itau0 + real,intent(in) :: zjulian + real,intent(in) :: dtime + integer,intent(out) :: nhori + integer,intent(out) :: nid_day + +!$OMP MASTER + if (is_sequential) then + call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), & + 1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day) + else + call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), & + 1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id) + endif +!$OMP END MASTER + + end subroutine histbeg_phy + + subroutine histwrite2d_phy(nid,name,itau,field) + USE dimphy + USE mod_phys_lmdz_para + USE ioipsl + implicit none + include 'dimensions.h' + + integer,intent(in) :: nid + character*(*), intent(IN) :: name + integer, intent(in) :: itau + real,dimension(klon),intent(in) :: field + + REAL,dimension(klon_mpi) :: buffer_omp + + CALL Gather_omp(field,buffer_omp) +!$OMP MASTER + CALL grid1Dto2D_mpi(buffer_omp,tmp_tab2d) + CALL histwrite(nid,name,itau,tmp_tab2d,iim*jj_nb,ndex2d) +!$OMP END MASTER + end subroutine histwrite2d_phy + + subroutine histwrite3d_phy(nid,name,itau,field) + USE dimphy + USE mod_phys_lmdz_para + + use ioipsl + implicit none + include 'dimensions.h' + + integer,intent(in) :: nid + character*(*), intent(IN) :: name + integer, intent(in) :: itau + real,dimension(klon,klev),intent(in) :: field + + REAL,dimension(klon_mpi,klev) :: buffer_omp + + CALL Gather_omp(field,buffer_omp) +!$OMP MASTER + CALL grid1Dto2D_mpi(buffer_omp,tmp_tab3d) + CALL histwrite(nid,name,itau,tmp_tab3d,iim*jj_nb*klev,ndex3d) +!$OMP END MASTER + end subroutine histwrite3d_phy + + + +end module iophy Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/iostart.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/iostart.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/iostart.F90 (revision 1280) @@ -0,0 +1,491 @@ +MODULE iostart + +PRIVATE + INTEGER,SAVE :: nid_start + INTEGER,SAVE :: nid_restart + + INTEGER,SAVE :: idim1,idim2,idim3 + INTEGER,PARAMETER :: length=100 + + INTERFACE get_field + MODULE PROCEDURE Get_field_r1,Get_field_r2,Get_field_r3 + END INTERFACE get_field + + INTERFACE get_var + MODULE PROCEDURE get_var_r0,Get_var_r1,Get_var_r2,Get_var_r3 + END INTERFACE get_var + + INTERFACE put_field + MODULE PROCEDURE put_field_r1,put_field_r2,put_field_r3 + END INTERFACE put_field + + INTERFACE put_var + MODULE PROCEDURE put_var_r0,put_var_r1,put_var_r2,put_var_r3 + END INTERFACE put_var + + PUBLIC get_field,get_var,put_field,put_var + PUBLIC Open_startphy,close_startphy,open_restartphy,close_restartphy + +CONTAINS + + SUBROUTINE Open_startphy(filename) + USE netcdf + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*) :: filename + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + ierr = NF90_OPEN (filename, NF90_NOWRITE,nid_start) + IF (ierr.NE.NF90_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier '//filename + write(6,*)' ierr = ', ierr + CALL ABORT + ENDIF + ENDIF + + END SUBROUTINE Open_startphy + + SUBROUTINE Close_startphy + USE netcdf + USE mod_phys_lmdz_para + IMPLICIT NONE + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + ierr = NF90_CLOSE (nid_start) + ENDIF + + END SUBROUTINE close_startphy + + + FUNCTION Inquire_Field(Field_name) + USE netcdf + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*) :: Field_name + LOGICAL :: inquire_field + INTEGER :: varid + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + ierr=NF90_INQ_VARID(nid_start,Field_name,varid) + IF (ierr==NF90_NOERR) THEN + Inquire_field=.TRUE. + ELSE + Inquire_field=.FALSE. + ENDIF + ENDIF + + CALL bcast(Inquire_field) + + END FUNCTION Inquire_Field + + + SUBROUTINE Get_Field_r1(field_name,field,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: Field_name + REAL,INTENT(INOUT) :: Field(:) + LOGICAL,INTENT(OUT),OPTIONAL :: found + + IF (PRESENT(found)) THEN + CALL Get_field_rgen(field_name,field,1,found) + ELSE + CALL Get_field_rgen(field_name,field,1) + ENDIF + + END SUBROUTINE Get_Field_r1 + + SUBROUTINE Get_Field_r2(field_name,field,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: Field_name + REAL,INTENT(INOUT) :: Field(:,:) + LOGICAL,INTENT(OUT),OPTIONAL :: found + + IF (PRESENT(found)) THEN + CALL Get_field_rgen(field_name,field,size(field,2),found) + ELSE + CALL Get_field_rgen(field_name,field,size(field,2)) + ENDIF + + + END SUBROUTINE Get_Field_r2 + + SUBROUTINE Get_Field_r3(field_name,field,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: Field_name + REAL,INTENT(INOUT) :: Field(:,:,:) + LOGICAL,INTENT(OUT),OPTIONAL :: found + + IF (PRESENT(found)) THEN + CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3),found) + ELSE + CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3)) + ENDIF + + END SUBROUTINE Get_Field_r3 + + SUBROUTINE Get_field_rgen(field_name,field,field_size,found) + USE netcdf + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*) :: Field_name + INTEGER :: field_size + REAL :: field(klon,field_size) + LOGICAL,OPTIONAL :: found + + REAL :: field_glo(klon_glo,field_size) + LOGICAL :: tmp_found + INTEGER :: varid + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + + ierr=NF90_INQ_VARID(nid_start,Field_name,varid) + + IF (ierr==NF90_NOERR) THEN + CALL body(field_glo) + tmp_found=.TRUE. + ELSE + tmp_found=.FALSE. + ENDIF + + ENDIF + + CALL bcast(tmp_found) + + IF (tmp_found) THEN + CALL scatter(field_glo,field) + ENDIF + + IF (PRESENT(found)) THEN + found=tmp_found + ELSE + IF (.NOT. tmp_found) THEN + PRINT*, 'phyetat0: Le champ <'//field_name//'> est absent' + CALL abort + ENDIF + ENDIF + + + CONTAINS + + SUBROUTINE body(field_glo) + REAL :: field_glo(klon_glo*field_size) + ierr=NF90_GET_VAR(nid_start,varid,field_glo) + IF (ierr/=NF90_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour <'//field_name//'>' + CALL abort + ENDIF + + END SUBROUTINE body + + END SUBROUTINE Get_field_rgen + + + SUBROUTINE get_var_r0(var_name,var,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + REAL,INTENT(INOUT) :: var + LOGICAL,OPTIONAL,INTENT(OUT) :: found + + REAL :: varout(1) + + IF (PRESENT(found)) THEN + CALL Get_var_rgen(var_name,varout,size(varout),found) + ELSE + CALL Get_var_rgen(var_name,varout,size(varout)) + ENDIF + var=varout(1) + + END SUBROUTINE get_var_r0 + + SUBROUTINE get_var_r1(var_name,var,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + REAL,INTENT(INOUT) :: var(:) + LOGICAL,OPTIONAL,INTENT(OUT) :: found + + IF (PRESENT(found)) THEN + CALL Get_var_rgen(var_name,var,size(var),found) + ELSE + CALL Get_var_rgen(var_name,var,size(var)) + ENDIF + + END SUBROUTINE get_var_r1 + + SUBROUTINE get_var_r2(var_name,var,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + REAL,INTENT(OUT) :: var(:,:) + LOGICAL,OPTIONAL,INTENT(OUT) :: found + + IF (PRESENT(found)) THEN + CALL Get_var_rgen(var_name,var,size(var),found) + ELSE + CALL Get_var_rgen(var_name,var,size(var)) + ENDIF + + END SUBROUTINE get_var_r2 + + SUBROUTINE get_var_r3(var_name,var,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + REAL,INTENT(INOUT) :: var(:,:,:) + LOGICAL,OPTIONAL,INTENT(OUT) :: found + + IF (PRESENT(found)) THEN + CALL Get_var_rgen(var_name,var,size(var),found) + ELSE + CALL Get_var_rgen(var_name,var,size(var)) + ENDIF + + END SUBROUTINE get_var_r3 + + SUBROUTINE Get_var_rgen(var_name,var,var_size,found) + USE netcdf + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*) :: var_name + INTEGER :: var_size + REAL :: var(var_size) + LOGICAL,OPTIONAL :: found + + LOGICAL :: tmp_found + INTEGER :: varid + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + + ierr=NF90_INQ_VARID(nid_start,var_name,varid) + + IF (ierr==NF90_NOERR) THEN + ierr=NF90_GET_VAR(nid_start,varid,var) + IF (ierr/=NF90_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour <'//var_name//'>' + CALL abort + ENDIF + tmp_found=.TRUE. + ELSE + tmp_found=.FALSE. + ENDIF + + ENDIF + + CALL bcast(tmp_found) + + IF (tmp_found) THEN + CALL bcast(var) + ENDIF + + IF (PRESENT(found)) THEN + found=tmp_found + ELSE + IF (.NOT. tmp_found) THEN + PRINT*, 'phyetat0: La variable champ <'//var_name//'> est absente' + CALL abort + ENDIF + ENDIF + + END SUBROUTINE Get_var_rgen + + + SUBROUTINE open_restartphy(filename) + USE netcdf + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz + USE dimphy + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: filename + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + ierr = NF90_CREATE(filename, NF90_CLOBBER, nid_restart) + IF (ierr/=NF90_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier '//filename + write(6,*)' ierr = ', ierr + CALL ABORT + ENDIF + + ierr = NF90_PUT_ATT (nid_restart, NF90_GLOBAL, "title","Fichier redemmarage physique") + + ierr = NF90_DEF_DIM (nid_restart, "index", length, idim1) + ierr = NF90_DEF_DIM (nid_restart, "points_physiques", klon_glo, idim2) + ierr = NF90_DEF_DIM (nid_restart, "horizon_vertical", klon_glo*klev, idim3) + + ierr = NF90_ENDDEF(nid_restart) + ENDIF + + END SUBROUTINE open_restartphy + + SUBROUTINE close_restartphy + USE netcdf + USE mod_phys_lmdz_para + IMPLICIT NONE + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + ierr = NF90_CLOSE (nid_restart) + ENDIF + + END SUBROUTINE close_restartphy + + + SUBROUTINE put_field_r1(field_name,title,field) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: field_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: field(:) + + CALL put_field_rgen(field_name,title,field,1) + + END SUBROUTINE put_field_r1 + + SUBROUTINE put_field_r2(field_name,title,field) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: field_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: field(:,:) + + CALL put_field_rgen(field_name,title,field,size(field,2)) + + END SUBROUTINE put_field_r2 + + SUBROUTINE put_field_r3(field_name,title,field) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: field_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: field(:,:,:) + + CALL put_field_rgen(field_name,title,field,size(field,2)*size(field,3)) + + END SUBROUTINE put_field_r3 + + SUBROUTINE put_field_rgen(field_name,title,field,field_size) + USE netcdf + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: field_name + CHARACTER(LEN=*),INTENT(IN) :: title + INTEGER,INTENT(IN) :: field_size + REAL,INTENT(IN) :: field(klon,field_size) + + REAL :: field_glo(klon_glo,field_size) + INTEGER :: ierr + INTEGER :: nvarid + INTEGER :: idim + + + CALL gather(field,field_glo) + + IF (is_mpi_root .AND. is_omp_root) THEN + + IF (field_size==1) THEN + idim=idim2 + ELSE IF (field_size==klev) THEN + idim=idim3 + ELSE + PRINT *, "erreur phyredem : probleme de dimension" + CALL ABORT + ENDIF + + ierr = NF90_REDEF (nid_restart) +#ifdef NC_DOUBLE + ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim /),nvarid) +#else + ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_FLOAT,(/ idim /),nvarid) +#endif + IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title) + ierr = NF90_ENDDEF(nid_restart) + ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/))) + ENDIF + + END SUBROUTINE put_field_rgen + + SUBROUTINE put_var_r0(var_name,title,var) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: var + REAL :: varin(1) + + varin(1)=var + + CALL put_var_rgen(var_name,title,varin,size(varin)) + + END SUBROUTINE put_var_r0 + + + SUBROUTINE put_var_r1(var_name,title,var) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: var(:) + + CALL put_var_rgen(var_name,title,var,size(var)) + + END SUBROUTINE put_var_r1 + + SUBROUTINE put_var_r2(var_name,title,var) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: var(:,:) + + CALL put_var_rgen(var_name,title,var,size(var)) + + END SUBROUTINE put_var_r2 + + SUBROUTINE put_var_r3(var_name,title,var) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: var(:,:,:) + + CALL put_var_rgen(var_name,title,var,size(var)) + + END SUBROUTINE put_var_r3 + + SUBROUTINE put_var_rgen(var_name,title,var,var_size) + USE netcdf + USE dimphy + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + CHARACTER(LEN=*),INTENT(IN) :: title + INTEGER,INTENT(IN) :: var_size + REAL,INTENT(IN) :: var(var_size) + + INTEGER :: ierr + INTEGER :: nvarid + + IF (is_mpi_root .AND. is_omp_root) THEN + + IF (var_size/=length) THEN + PRINT *, "erreur phyredem : probleme de dimension" + CALL abort + ENDIF + + ierr = NF90_REDEF (nid_restart) + +#ifdef NC_DOUBLE + ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_DOUBLE,(/ idim1 /),nvarid) +#else + ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_FLOAT,(/ idim1 /),nvarid) +#endif + IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title) + ierr = NF90_ENDDEF(nid_restart) + + ierr = NF90_PUT_VAR(nid_restart,nvarid,var) + + ENDIF + + END SUBROUTINE put_var_rgen + +END MODULE iostart Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/isccp_cloud_types.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/isccp_cloud_types.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/isccp_cloud_types.F (revision 1280) @@ -0,0 +1,1668 @@ +! +! $Header$ +! + SUBROUTINE ISCCP_CLOUD_TYPES( + & debug, + & debugcol, + & npoints, + & sunlit, + & nlev, + & ncol, + & seed, + & pfull, + & phalf, + & qv, + & cc, + & conv, + & dtau_s, + & dtau_c, + & top_height, + & overlap, + & tautab, + & invtau, + & skt, + & emsfc_lw, + & at,dem_s,dem_c, + & fq_isccp, + & totalcldarea, + & meanptop, + & meantaucld, + & boxtau, + & boxptop + &) + + +! Copyright Steve Klein and Mark Webb 2002 - all rights reserved. +! +! This code is available without charge with the following conditions: +! +! 1. The code is available for scientific purposes and is not for +! commercial use. +! 2. Any improvements you make to the code should be made available +! to the to the authors for incorporation into a future release. +! 3. The code should not be used in any way that brings the authors +! or their employers into disrepute. + + implicit none + +! NOTE: the maximum number of levels and columns is set by +! the following parameter statement + + INTEGER ncolprint + +! ----- +! Input +! ----- + + INTEGER npoints ! number of model points in the horizontal +c PARAMETER(npoints=6722) + INTEGER nlev ! number of model levels in column + INTEGER ncol ! number of subcolumns + + INTEGER sunlit(npoints) ! 1 for day points, 0 for night time + + INTEGER seed(npoints) ! seed value for random number generator +c ! ( see Numerical Recipes Chapter 7) +c ! It is recommended that the seed is set +c ! to a different value for each model +c ! gridbox it is called on, as it is +c ! possible that the choice of the samec +c ! seed value every time may introduce some +c ! statistical bias in the results, particularly +c ! for low values of NCOL. +c + REAL pfull(npoints,nlev) ! pressure of full model levels (Pascals) +c ! pfull(npoints,1) is top level of model +c ! pfull(npoints,nlev) is bottom level of model + + REAL phalf(npoints,nlev+1) ! pressure of half model levels (Pascals) +c ! phalf(npoints,1) is top of model +c ! phalf(npoints,nlev+1) is the surface pressure + + REAL qv(npoints,nlev) ! water vapor specific humidity (kg vapor/ kg air) +c ! on full model levels + + REAL cc(npoints,nlev) ! input cloud cover in each model level (fraction) +c ! NOTE: This is the HORIZONTAL area of each +c ! grid box covered by clouds + + REAL conv(npoints,nlev) ! input convective cloud cover in each model level (fraction) +c ! NOTE: This is the HORIZONTAL area of each +c ! grid box covered by convective clouds + + REAL dtau_s(npoints,nlev) ! mean 0.67 micron optical depth of stratiform +c ! clouds in each model level +c ! NOTE: this the cloud optical depth of only the +c ! cloudy part of the grid box, it is not weighted +c ! with the 0 cloud optical depth of the clear +c ! part of the grid box + + REAL dtau_c(npoints,nlev) ! mean 0.67 micron optical depth of convective +c ! clouds in each +c ! model level. Same note applies as in dtau_s. + + INTEGER overlap ! overlap type + +! 1=max + +! 2=rand +! 3=max/rand + + INTEGER top_height ! 1 = adjust top height using both a computed +c ! infrared brightness temperature and the visible +c ! optical depth to adjust cloud top pressure. Note +c ! that this calculation is most appropriate to compare +c ! to ISCCP data during sunlit hours. +c ! 2 = do not adjust top height, that is cloud top +c ! pressure is the actual cloud top pressure +c ! in the model +c ! 3 = adjust top height using only the computed +c ! infrared brightness temperature. Note that this +c ! calculation is most appropriate to compare to ISCCP +c ! IR only algortihm (i.e. you can compare to nighttime +c ! ISCCP data with this option) + + REAL tautab(0:255) ! ISCCP table for converting count value to +c ! optical thickness + + INTEGER invtau(-20:45000) ! ISCCP table for converting optical thickness +c ! to count value +! +! The following input variables are used only if top_height = 1 or top_height = 3 +! + REAL skt(npoints) ! skin Temperature (K) + REAL emsfc_lw ! 10.5 micron emissivity of surface (fraction) + REAL at(npoints,nlev) ! temperature in each model level (K) + REAL dem_s(npoints,nlev) ! 10.5 micron longwave emissivity of stratiform +c ! clouds in each +c ! model level. Same note applies as in dtau_s. + REAL dem_c(npoints,nlev) ! 10.5 micron longwave emissivity of convective +c ! clouds in each +c ! model level. Same note applies as in dtau_s. +cIM reg.dyn BEG + REAL t1, t2 +! REAL w(npoints) !vertical wind at 500 hPa +! LOGICAL pct_ocean(npoints) !TRUE if oceanic point, FALSE otherway +! INTEGER iw(npoints) , nw +! REAL wmin, pas_w +! INTEGER k, l, iwmx +! PARAMETER(wmin=-100.,pas_w=10.,iwmx=30) +! REAL fq_dynreg(7,7,iwmx) +! REAL nfq_dynreg(7,7,iwmx) +! LOGICAL pctj(7,7,iwmx) +cIM reg.dyn END +! ------ +! Output +! ------ + + REAL fq_isccp(npoints,7,7) ! the fraction of the model grid box covered by +c ! each of the 49 ISCCP D level cloud types + + REAL totalcldarea(npoints) ! the fraction of model grid box columns +c ! with cloud somewhere in them. This should +c ! equal the sum over all entries of fq_isccp + + +c ! The following three means are averages over the cloudy areas only. If no +c ! clouds are in grid box all three quantities should equal zero. + + REAL meanptop(npoints) ! mean cloud top pressure (mb) - linear averaging +c ! in cloud top pressure. + + REAL meantaucld(npoints) ! mean optical thickness +c ! linear averaging in albedo performed. + + REAL boxtau(npoints,ncol) ! optical thickness in each column + + REAL boxptop(npoints,ncol) ! cloud top pressure (mb) in each column + + +! +! ------ +! Working variables added when program updated to mimic Mark Webb's PV-Wave code +! ------ + + REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into +c ! Equivalent of BOX in original version, but +c ! indexed by column then row, rather than +c ! by row then column + + REAL tca(npoints,0:nlev) ! total cloud cover in each model level (fraction) +c ! with extra layer of zeroes on top +c ! in this version this just contains the values input +c ! from cc but with an extra level + REAL cca(npoints,nlev) ! convective cloud cover in each model level (fraction) +c ! from conv + + REAL threshold(npoints,ncol) ! pointer to position in gridbox + REAL maxocc(npoints,ncol) ! Flag for max overlapped conv cld + REAL maxosc(npoints,ncol) ! Flag for max overlapped strat cld + + REAL boxpos(npoints,ncol) ! ordered pointer to position in gridbox + + REAL threshold_min(npoints,ncol) ! minimum value to define range in with new threshold +c ! is chosen + + REAL dem(npoints,ncol),bb(npoints) ! working variables for 10.5 micron longwave +c ! emissivity in part of +c ! gridbox under consideration + + REAL ran(npoints) ! vector of random numbers + REAL ptrop(npoints) + REAL attrop(npoints) + REAL attropmin (npoints) + REAL atmax(npoints) + REAL atmin(npoints) + REAL btcmin(npoints) + REAL transmax(npoints) + + INTEGER i,j,ilev,ibox,itrop(npoints) + INTEGER ipres(npoints) + INTEGER itau(npoints),ilev2 + INTEGER acc(nlev,ncol) + INTEGER match(npoints,nlev-1) + INTEGER nmatch(npoints) + INTEGER levmatch(npoints,ncol) + +c !variables needed for water vapor continuum absorption + real fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints) + real taumin(npoints) + real dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0 + real press(npoints), dpress(npoints), atmden(npoints) + real rvh20(npoints), wk(npoints), rhoave(npoints) + real rh20s(npoints), rfrgn(npoints) + real tmpexp(npoints),tauwv(npoints) + + character*1 cchar(6),cchar_realtops(6) + integer icycle + REAL tau(npoints,ncol) + LOGICAL box_cloudy(npoints,ncol) + REAL tb(npoints,ncol) + REAL ptop(npoints,ncol) + REAL emcld(npoints,ncol) + REAL fluxtop(npoints,ncol) + REAL trans_layers_above(npoints,ncol) + real isccp_taumin,fluxtopinit(npoints),tauir(npoints) + real meanalbedocld(npoints) + REAL albedocld(npoints,ncol) + real boxarea + integer debug ! set to non-zero value to print out inputs +c ! with step debug + integer debugcol ! set to non-zero value to print out column +c ! decomposition with step debugcol + + integer index1(npoints),num1,jj + real rec2p13,tauchk + + character*10 ftn09 + + DATA isccp_taumin / 0.3 / + DATA cchar / ' ','-','1','+','I','+'/ + DATA cchar_realtops / ' ',' ','1','1','I','I'/ + + tauchk = -1.*log(0.9999999) + rec2p13=1./2.13 + + ncolprint=0 + +cIM +c PRINT*,' isccp_cloud_types npoints=',npoints +c +c if ( debug.ne.0 ) then +c j=1 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write(6,'(a10)') 'debug=' +c write(6,'(8I10)') debug +c write(6,'(a10)') 'debugcol=' +c write(6,'(8I10)') debugcol +c write(6,'(a10)') 'npoints=' +c write(6,'(8I10)') npoints +c write(6,'(a10)') 'nlev=' +c write(6,'(8I10)') nlev +c write(6,'(a10)') 'ncol=' +c write(6,'(8I10)') ncol +c write(6,'(a10)') 'top_height=' +c write(6,'(8I10)') top_height +c write(6,'(a10)') 'overlap=' +c write(6,'(8I10)') overlap +c write(6,'(a10)') 'emsfc_lw=' +c write(6,'(8f10.2)') emsfc_lw +c write(6,'(a10)') 'tautab=' +c write(6,'(8f10.2)') tautab +c write(6,'(a10)') 'invtau(1:100)=' +c write(6,'(8i10)') (invtau(i),i=1,100) +c do j=1,npoints,debug +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write(6,'(a10)') 'sunlit=' +c write(6,'(8I10)') sunlit(j) +c write(6,'(a10)') 'seed=' +c write(6,'(8I10)') seed(j) +c write(6,'(a10)') 'pfull=' +c write(6,'(8f10.2)') (pfull(j,i),i=1,nlev) +c write(6,'(a10)') 'phalf=' +c write(6,'(8f10.2)') (phalf(j,i),i=1,nlev+1) +c write(6,'(a10)') 'qv=' +c write(6,'(8f10.3)') (qv(j,i),i=1,nlev) +c write(6,'(a10)') 'cc=' +c write(6,'(8f10.3)') (cc(j,i),i=1,nlev) +c write(6,'(a10)') 'conv=' +c write(6,'(8f10.2)') (conv(j,i),i=1,nlev) +c write(6,'(a10)') 'dtau_s=' +c write(6,'(8g12.5)') (dtau_s(j,i),i=1,nlev) +c write(6,'(a10)') 'dtau_c=' +c write(6,'(8f10.2)') (dtau_c(j,i),i=1,nlev) +c write(6,'(a10)') 'skt=' +c write(6,'(8f10.2)') skt(j) +c write(6,'(a10)') 'at=' +c write(6,'(8f10.2)') (at(j,i),i=1,nlev) +c write(6,'(a10)') 'dem_s=' +c write(6,'(8f10.3)') (dem_s(j,i),i=1,nlev) +c write(6,'(a10)') 'dem_c=' +c write(6,'(8f10.2)') (dem_c(j,i),i=1,nlev) +c enddo +c endif + +! ---------------------------------------------------! + +! assign 2d tca array using 1d input array cc + + do j=1,npoints + tca(j,0)=0 + enddo + + do ilev=1,nlev + do j=1,npoints + tca(j,ilev)=cc(j,ilev) + enddo + enddo + +! assign 2d cca array using 1d input array conv + + do ilev=1,nlev +cIM pas besoin do ibox=1,ncol + do j=1,npoints + cca(j,ilev)=conv(j,ilev) + enddo +cIM enddo + enddo + +cIM +! do j=1, iwmx +! do l=1, 7 +! do k=1, 7 +! fq_dynreg(k,l,j) =0. +! nfq_dynreg(k,l,j) =0. +! enddo !k +! enddo !l +! enddo !j +cIM +cIM +c if (ncolprint.ne.0) then +c do j=1,npoints,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(a)') 'seed:' +c write (6,'(I3.2)') seed(j) + +c write (6,'(a)') 'tca_pp_rev:' +c write (6,'(8f5.2)') +c & ((tca(j,ilev)), +c & ilev=1,nlev) + +c write (6,'(a)') 'cca_pp_rev:' +c write (6,'(8f5.2)') +c & ((cca(j,ilev),ibox=1,ncolprint),ilev=1,nlev) +c enddo +c endif + + if (top_height .eq. 1 .or. top_height .eq. 3) then + + do j=1,npoints + ptrop(j)=5000. + atmin(j) = 400. + attropmin(j) = 400. + atmax(j) = 0. + attrop(j) = 120. + itrop(j) = 1 + enddo + + do 12 ilev=1,nlev + do j=1,npoints + if (pfull(j,ilev) .lt. 40000. .and. + & pfull(j,ilev) .gt. 5000. .and. + & at(j,ilev) .lt. attropmin(j)) then + ptrop(j) = pfull(j,ilev) + attropmin(j) = at(j,ilev) + attrop(j) = attropmin(j) + itrop(j)=ilev + end if + if (at(j,ilev) .gt. atmax(j)) atmax(j)=at(j,ilev) + if (at(j,ilev) .lt. atmin(j)) atmin(j)=at(j,ilev) + enddo +12 continue + + end if + +! -----------------------------------------------------! + +! ---------------------------------------------------! + +cIM +c do 13 ilev=1,nlev +cnum1=0 +c do j=1,npoints +c if (cc(j,ilev) .lt. 0. .or. cc(j,ilev) .gt. 1.) then +c num1=num1+1 +c index1(num1)=j +c end if +c enddo +c do jj=1,num1 +c j=index1(jj) +c write(6,*) ' error = cloud fraction less than zero' +c write(6,*) ' or ' +c write(6,*) ' error = cloud fraction greater than 1' +c write(6,*) 'value at point ',j,' is ',cc(j,ilev) +c write(6,*) 'level ',ilev +c STOP +c enddo +cnum1=0 +c do j=1,npoints +c if (conv(j,ilev) .lt. 0. .or. conv(j,ilev) .gt. 1.) then +c num1=num1+1 +c index1(num1)=j +c end if +c enddo +c do jj=1,num1 +c j=index1(jj) +c write(6,*) +c & ' error = convective cloud fraction less than zero' +c write(6,*) ' or ' +c write(6,*) +c & ' error = convective cloud fraction greater than 1' +c write(6,*) 'value at point ',j,' is ',conv(j,ilev) +c write(6,*) 'level ',ilev +c STOP +c enddo + +cnum1=0 +c do j=1,npoints +c if (dtau_s(j,ilev) .lt. 0.) then +c num1=num1+1 +c index1(num1)=j +c end if +c enddo +c do jj=1,num1 +c j=index1(jj) +c write(6,*) +c & ' error = stratiform cloud opt. depth less than zero' +c write(6,*) 'value at point ',j,' is ',dtau_s(j,ilev) +c write(6,*) 'level ',ilev +c STOP +c enddo +cnum1=0 +c do j=1,npoints +c if (dtau_c(j,ilev) .lt. 0.) then +c num1=num1+1 +c index1(num1)=j +c end if +c enddo +c do jj=1,num1 +c j=index1(jj) +c write(6,*) +c & ' error = convective cloud opt. depth less than zero' +c write(6,*) 'value at point ',j,' is ',dtau_c(j,ilev) +c write(6,*) 'level ',ilev +c STOP +c enddo + +cnum1=0 +c do j=1,npoints +c if (dem_s(j,ilev) .lt. 0. .or. dem_s(j,ilev) .gt. 1.) then +c num1=num1+1 +c index1(num1)=j +c end if +c enddo +c do jj=1,num1 +c j=index1(jj) +c write(6,*) +c & ' error = stratiform cloud emissivity less than zero' +c write(6,*)'or' +c write(6,*) +c & ' error = stratiform cloud emissivity greater than 1' +c write(6,*) 'value at point ',j,' is ',dem_s(j,ilev) +c write(6,*) 'level ',ilev +c STOP +c enddo + +cnum1=0 +c do j=1,npoints +c if (dem_c(j,ilev) .lt. 0. .or. dem_c(j,ilev) .gt. 1.) then +c num1=num1+1 +c index1(num1)=j +c end if +c enddo +c do jj=1,num1 +c j=index1(jj) +c write(6,*) +c & ' error = convective cloud emissivity less than zero' +c write(6,*)'or' +c write(6,*) +c & ' error = convective cloud emissivity greater than 1' +c write (6,*) +c & 'j=',j,'ilev=',ilev,'dem_c(j,ilev) =',dem_c(j,ilev) +c STOP +c enddo +c13 continue + + + do ibox=1,ncol + do j=1,npoints + boxpos(j,ibox)=(ibox-.5)/ncol + enddo + enddo + +! ---------------------------------------------------! +! Initialise working variables +! ---------------------------------------------------! + +! Initialised frac_out to zero + + do ilev=1,nlev + do ibox=1,ncol + do j=1,npoints + frac_out(j,ibox,ilev)=0.0 + enddo + enddo + enddo + +cIM +c if (ncolprint.ne.0) then +c write (6,'(a)') 'frac_out_pp_rev:' +c do j=1,npoints,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(8f5.2)') +c & ((frac_out(j,ibox,ilev),ibox=1,ncolprint),ilev=1,nlev) + +c enddo +c write (6,'(a)') 'ncol:' +c write (6,'(I3)') ncol +c endif +c if (ncolprint.ne.0) then +c write (6,'(a)') 'last_frac_pp:' +c do j=1,npoints,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(8f5.2)') (tca(j,0)) +c enddo +c endif + +! ---------------------------------------------------! +! ALLOCATE CLOUD INTO BOXES, FOR NCOLUMNS, NLEVELS +! frac_out is the array that contains the information +! where 0 is no cloud, 1 is a stratiform cloud and 2 is a +! convective cloud + + !loop over vertical levels + DO 200 ilev = 1,nlev + +! Initialise threshold + + IF (ilev.eq.1) then + ! If max overlap + IF (overlap.eq.1) then + ! select pixels spread evenly + ! across the gridbox + DO ibox=1,ncol + do j=1,npoints + threshold(j,ibox)=boxpos(j,ibox) + enddo + enddo + ELSE + DO ibox=1,ncol + call ran0_vec(npoints,seed,ran) + ! select random pixels from the non-convective + ! part the gridbox ( some will be converted into + ! convective pixels below ) + do j=1,npoints + threshold(j,ibox)= + & cca(j,ilev)+(1-cca(j,ilev))*ran(j) + enddo + enddo + ENDIF +cIM +c IF (ncolprint.ne.0) then +c write (6,'(a)') 'threshold_nsf2:' +c do j=1,npoints,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint) +c enddo +c ENDIF + ENDIF + +c IF (ncolprint.ne.0) then +c write (6,'(a)') 'ilev:' +c write (6,'(I2)') ilev +c ENDIF + + DO ibox=1,ncol + + ! All versions + do j=1,npoints + if (boxpos(j,ibox).le.cca(j,ilev)) then +cIM REAL maxocc(j,ibox) = 1 + maxocc(j,ibox) = 1.0 + else +cIM REAL maxocc(j,ibox) = 0 + maxocc(j,ibox) = 0.0 + end if + enddo + + ! Max overlap + if (overlap.eq.1) then + do j=1,npoints + threshold_min(j,ibox)=cca(j,ilev) +cIM REAL maxosc(j,ibox)=1 + maxosc(j,ibox)=1.0 + enddo + endif + + ! Random overlap + if (overlap.eq.2) then + do j=1,npoints + threshold_min(j,ibox)=cca(j,ilev) +cIM REAL maxosc(j,ibox)=0 + maxosc(j,ibox)=0.0 + enddo + endif + + ! Max/Random overlap + if (overlap.eq.3) then + do j=1,npoints + threshold_min(j,ibox)=max(cca(j,ilev), + & min(tca(j,ilev-1),tca(j,ilev))) + if (threshold(j,ibox) + & .lt.min(tca(j,ilev-1),tca(j,ilev)) + & .and.(threshold(j,ibox).gt.cca(j,ilev))) then +cIM REAL maxosc(j,ibox)= 1 + maxosc(j,ibox)= 1.0 + else +cIM REAL maxosc(j,ibox)= 0 + maxosc(j,ibox)= 0.0 + end if + enddo + endif + + ! Reset threshold + call ran0_vec(npoints,seed,ran) + + do j=1,npoints + threshold(j,ibox)= + !if max overlapped conv cloud + & maxocc(j,ibox) * ( + & boxpos(j,ibox) + & ) + + !else + & (1-maxocc(j,ibox)) * ( + !if max overlapped strat cloud + & (maxosc(j,ibox)) * ( + !threshold=boxpos + & threshold(j,ibox) + & ) + + !else + & (1-maxosc(j,ibox)) * ( + !threshold_min=random[thrmin,1] + & threshold_min(j,ibox)+ + & (1-threshold_min(j,ibox))*ran(j) + & ) + & ) + enddo + + ENDDO ! ibox + +! Fill frac_out with 1's where tca is greater than the threshold + + DO ibox=1,ncol + do j=1,npoints + if (tca(j,ilev).gt.threshold(j,ibox)) then +cIM REAL frac_out(j,ibox,ilev)=1 + frac_out(j,ibox,ilev)=1.0 + else +cIM REAL frac_out(j,ibox,ilev)=0 + frac_out(j,ibox,ilev)=0.0 + end if + enddo + ENDDO + +! Code to partition boxes into startiform and convective parts +! goes here + + DO ibox=1,ncol + do j=1,npoints + if (threshold(j,ibox).le.cca(j,ilev)) then + ! = 2 IF threshold le cca(j) +cIM REAL frac_out(j,ibox,ilev) = 2 + frac_out(j,ibox,ilev) = 2.0 + else + ! = the same IF NOT threshold le cca(j) + frac_out(j,ibox,ilev) = frac_out(j,ibox,ilev) + end if + enddo + ENDDO + +! Set last_frac to tca at this level, so as to be tca +! from last level next time round + +cIM +c if (ncolprint.ne.0) then + +c do j=1,npoints ,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(a)') 'last_frac:' +c write (6,'(8f5.2)') (tca(j,ilev-1)) + +c write (6,'(a)') 'cca:' +c write (6,'(8f5.2)') (cca(j,ilev),ibox=1,ncolprint) + +c write (6,'(a)') 'max_overlap_cc:' +c write (6,'(8f5.2)') (maxocc(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'max_overlap_sc:' +c write (6,'(8f5.2)') (maxosc(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'threshold_min_nsf2:' +c write (6,'(8f5.2)') (threshold_min(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'threshold_nsf2:' +c write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'frac_out_pp_rev:' +c write (6,'(8f5.2)') +c & ((frac_out(j,ibox,ilev2),ibox=1,ncolprint),ilev2=1,nlev) +c enddo +c endif + +200 CONTINUE !loop over nlev + +! +! ---------------------------------------------------! + + +! +! ---------------------------------------------------! +! COMPUTE CLOUD OPTICAL DEPTH FOR EACH COLUMN and +! put into vector tau + + !initialize tau and albedocld to zero + do 15 ibox=1,ncol + do j=1,npoints + tau(j,ibox)=0. + albedocld(j,ibox)=0. + boxtau(j,ibox)=0. + boxptop(j,ibox)=0. + box_cloudy(j,ibox)=.false. + enddo +15 continue + + !compute total cloud optical depth for each column + do ilev=1,nlev + !increment tau for each of the boxes + do ibox=1,ncol + do j=1,npoints +cIM REAL if (frac_out(j,ibox,ilev).eq.1) then + if (frac_out(j,ibox,ilev).eq.1.0) then + tau(j,ibox)=tau(j,ibox) + & + dtau_s(j,ilev) + endif +cIM REAL if (frac_out(j,ibox,ilev).eq.2) then + if (frac_out(j,ibox,ilev).eq.2.0) then + tau(j,ibox)=tau(j,ibox) + & + dtau_c(j,ilev) + end if + enddo + enddo ! ibox + enddo ! ilev +cIM +c if (ncolprint.ne.0) then + +c do j=1,npoints ,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write(6,'(i2,1X,8(f7.2,1X))') +c & ilev, +c & (tau(j,ibox),ibox=1,ncolprint) +c enddo +c endif +! +! ---------------------------------------------------! + + + +! +! ---------------------------------------------------! +! COMPUTE INFRARED BRIGHTNESS TEMPERUATRES +! AND CLOUD TOP TEMPERATURE SATELLITE SHOULD SEE +! +! again this is only done if top_height = 1 or 3 +! +! fluxtop is the 10.5 micron radiance at the top of the +! atmosphere +! trans_layers_above is the total transmissivity in the layers +! above the current layer +! fluxtop_clrsky(j) and trans_layers_above_clrsky(j) are the clear +! sky versions of these quantities. + + if (top_height .eq. 1 .or. top_height .eq. 3) then + + + !---------------------------------------------------------------------- + ! + ! DO CLEAR SKY RADIANCE CALCULATION FIRST + ! + !compute water vapor continuum emissivity + !this treatment follows Schwarkzopf and Ramasamy + !JGR 1999,vol 104, pages 9467-9499. + !the emissivity is calculated at a wavenumber of 955 cm-1, + !or 10.47 microns + wtmair = 28.9644 + wtmh20 = 18.01534 + Navo = 6.023E+23 + grav = 9.806650E+02 + pstd = 1.013250E+06 + t0 = 296. +cIM +c if (ncolprint .ne. 0) +c & write(6,*) 'ilev pw (kg/m2) tauwv(j) dem_wv' + do 125 ilev=1,nlev + do j=1,npoints + !press and dpress are dyne/cm2 = Pascals *10 + press(j) = pfull(j,ilev)*10. + dpress(j) = (phalf(j,ilev+1)-phalf(j,ilev))*10 + !atmden = g/cm2 = kg/m2 / 10 + atmden(j) = dpress(j)/grav + rvh20(j) = qv(j,ilev)*wtmair/wtmh20 + wk(j) = rvh20(j)*Navo*atmden(j)/wtmair + rhoave(j) = (press(j)/pstd)*(t0/at(j,ilev)) + rh20s(j) = rvh20(j)*rhoave(j) + rfrgn(j) = rhoave(j)-rh20s(j) + tmpexp(j) = exp(-0.02*(at(j,ilev)-t0)) + tauwv(j) = wk(j)*1.e-20*( + & (0.0224697*rh20s(j)*tmpexp(j)) + + & (3.41817e-7*rfrgn(j)) )*0.98 + dem_wv(j,ilev) = 1. - exp( -1. * tauwv(j)) + enddo +cIM +c if (ncolprint .ne. 0) then +c do j=1,npoints ,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write(6,'(i2,1X,3(f8.3,3X))') ilev, +c & qv(j,ilev)*(phalf(j,ilev+1)-phalf(j,ilev))/(grav/100.), +c & tauwv(j),dem_wv(j,ilev) +c enddo +c endif +125 continue + + !initialize variables + do j=1,npoints + fluxtop_clrsky(j) = 0. + trans_layers_above_clrsky(j)=1. + enddo + + do ilev=1,nlev + do j=1,npoints + + ! Black body emission at temperature of the layer + + bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. ) + !bb(j)= 5.67e-8*at(j,ilev)**4 + + ! increase TOA flux by flux emitted from layer + ! times total transmittance in layers above + + fluxtop_clrsky(j) = fluxtop_clrsky(j) + & + dem_wv(j,ilev)*bb(j)*trans_layers_above_clrsky(j) + + ! update trans_layers_above with transmissivity + ! from this layer for next time around loop + + trans_layers_above_clrsky(j)= + & trans_layers_above_clrsky(j)*(1.-dem_wv(j,ilev)) + + + enddo +cIM +c if (ncolprint.ne.0) then +c do j=1,npoints ,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(a)') 'ilev:' +c write (6,'(I2)') ilev + +c write (6,'(a)') +c & 'emiss_layer,100.*bb(j),100.*f,total_trans:' +c write (6,'(4(f7.2,1X))') dem_wv(j,ilev),100.*bb(j), +c & 100.*fluxtop_clrsky(j),trans_layers_above_clrsky(j) +c enddo +c endif + + enddo !loop over level + + do j=1,npoints + !add in surface emission + bb(j)=1/( exp(1307.27/skt(j)) - 1. ) + !bb(j)=5.67e-8*skt(j)**4 + + fluxtop_clrsky(j) = fluxtop_clrsky(j) + emsfc_lw * bb(j) + & * trans_layers_above_clrsky(j) + enddo + +cIM +c if (ncolprint.ne.0) then +c do j=1,npoints ,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(a)') 'id:' +c write (6,'(a)') 'surface' + +c write (6,'(a)') 'emsfc,100.*bb(j),100.*f,total_trans:' +c write (6,'(4(f7.2,1X))') emsfc_lw,100.*bb(j), +c & 100.*fluxtop_clrsky(j), +c & trans_layers_above_clrsky(j) +c enddo +c endif + + + ! + ! END OF CLEAR SKY CALCULATION + ! + !---------------------------------------------------------------- + + +cIM +c if (ncolprint.ne.0) then + +c do j=1,npoints ,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(a)') 'ts:' +c write (6,'(8f7.2)') (skt(j),ibox=1,ncolprint) + +c write (6,'(a)') 'ta_rev:' +c write (6,'(8f7.2)') +c & ((at(j,ilev2),ibox=1,ncolprint),ilev2=1,nlev) + +c enddo +c endif + !loop over columns + do ibox=1,ncol + do j=1,npoints + fluxtop(j,ibox)=0. + trans_layers_above(j,ibox)=1. + enddo + enddo + + do ilev=1,nlev + do j=1,npoints + ! Black body emission at temperature of the layer + + bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. ) + !bb(j)= 5.67e-8*at(j,ilev)**4 + enddo + + do ibox=1,ncol + do j=1,npoints + + ! emissivity for point in this layer +cIM REAL if (frac_out(j,ibox,ilev).eq.1) then + if (frac_out(j,ibox,ilev).eq.1.0) then + dem(j,ibox)= 1. - + & ( (1. - dem_wv(j,ilev)) * (1. - dem_s(j,ilev)) ) +cIM REAL else if (frac_out(j,ibox,ilev).eq.2) then + else if (frac_out(j,ibox,ilev).eq.2.0) then + dem(j,ibox)= 1. - + & ( (1. - dem_wv(j,ilev)) * (1. - dem_c(j,ilev)) ) + else + dem(j,ibox)= dem_wv(j,ilev) + end if + + + ! increase TOA flux by flux emitted from layer + ! times total transmittance in layers above + + fluxtop(j,ibox) = fluxtop(j,ibox) + & + dem(j,ibox) * bb(j) + & * trans_layers_above(j,ibox) + + ! update trans_layers_above with transmissivity + ! from this layer for next time around loop + + trans_layers_above(j,ibox)= + & trans_layers_above(j,ibox)*(1.-dem(j,ibox)) + + enddo ! j + enddo ! ibox + +cIM +c if (ncolprint.ne.0) then +c do j=1,npoints,1000 +c write (6,'(a)') 'ilev:' +c write (6,'(I2)') ilev + +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(a)') 'emiss_layer:' +c write (6,'(8f7.2)') (dem(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') '100.*bb(j):' +c write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint) + +c write (6,'(a)') '100.*f:' +c write (6,'(8f7.2)') +c & (100.*fluxtop(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'total_trans:' +c write (6,'(8f7.2)') +c & (trans_layers_above(j,ibox),ibox=1,ncolprint) +c enddo +c endif + + enddo ! ilev + + + do j=1,npoints + !add in surface emission + bb(j)=1/( exp(1307.27/skt(j)) - 1. ) + !bb(j)=5.67e-8*skt(j)**4 + end do + + do ibox=1,ncol + do j=1,npoints + + !add in surface emission + + fluxtop(j,ibox) = fluxtop(j,ibox) + & + emsfc_lw * bb(j) + & * trans_layers_above(j,ibox) + + end do + end do + +cIM +c if (ncolprint.ne.0) then + +c do j=1,npoints ,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(a)') 'id:' +c write (6,'(a)') 'surface' + +c write (6,'(a)') 'emiss_layer:' +c write (6,'(8f7.2)') (dem(1,ibox),ibox=1,ncolprint) + +c write (6,'(a)') '100.*bb(j):' +c write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint) + +c write (6,'(a)') '100.*f:' +c write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint) +c end do +c endif + + !now that you have the top of atmosphere radiance account + !for ISCCP procedures to determine cloud top temperature + + !account for partially transmitting cloud recompute flux + !ISCCP would see assuming a single layer cloud + !note choice here of 2.13, as it is primarily ice + !clouds which have partial emissivity and need the + !adjustment performed in this section + ! + !If it turns out that the cloud brightness temperature + !is greater than 260K, then the liquid cloud conversion + !factor of 2.56 is used. + ! + !Note that this is discussed on pages 85-87 of + !the ISCCP D level documentation (Rossow et al. 1996) + + do j=1,npoints + !compute minimum brightness temperature and optical depth + btcmin(j) = 1. / ( exp(1307.27/(attrop(j)-5.)) - 1. ) + enddo + do ibox=1,ncol + do j=1,npoints + transmax(j) = (fluxtop(j,ibox)-btcmin(j)) + & /(fluxtop_clrsky(j)-btcmin(j)) + !note that the initial setting of tauir(j) is needed so that + !tauir(j) has a realistic value should the next if block be + !bypassed + tauir(j) = tau(j,ibox) * rec2p13 + taumin(j) = -1. * log(max(min(transmax(j),0.9999999),0.001)) + + enddo + + if (top_height .eq. 1) then + do j=1,npoints + if (transmax(j) .gt. 0.001 .and. + & transmax(j) .le. 0.9999999) then + fluxtopinit(j) = fluxtop(j,ibox) + tauir(j) = tau(j,ibox) *rec2p13 + endif + enddo + do icycle=1,2 + do j=1,npoints + if (tau(j,ibox) .gt. (tauchk )) then + if (transmax(j) .gt. 0.001 .and. + & transmax(j) .le. 0.9999999) then + emcld(j,ibox) = 1. - exp(-1. * tauir(j) ) + fluxtop(j,ibox) = fluxtopinit(j) - + & ((1.-emcld(j,ibox))*fluxtop_clrsky(j)) + fluxtop(j,ibox)=max(1.E-06, + & (fluxtop(j,ibox)/emcld(j,ibox))) + tb(j,ibox)= 1307.27 + & / (log(1. + (1./fluxtop(j,ibox)))) + if (tb(j,ibox) .gt. 260.) then + tauir(j) = tau(j,ibox) / 2.56 + end if + end if + end if + enddo + enddo + + endif + + do j=1,npoints + if (tau(j,ibox) .gt. (tauchk )) then + !cloudy box + tb(j,ibox)= 1307.27/ (log(1. + (1./fluxtop(j,ibox)))) + if (top_height.eq.1.and.tauir(j).lt.taumin(j)) then + tb(j,ibox) = attrop(j) - 5. + tau(j,ibox) = 2.13*taumin(j) + end if + else + !clear sky brightness temperature + tb(j,ibox) = 1307.27/(log(1.+(1./fluxtop_clrsky(j)))) + end if + enddo ! j + enddo ! ibox + +cIM +c if (ncolprint.ne.0) then + +c do j=1,npoints,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j + +c write (6,'(a)') 'attrop:' +c write (6,'(8f7.2)') (attrop(j)) + +c write (6,'(a)') 'btcmin:' +c write (6,'(8f7.2)') (btcmin(j)) + +c write (6,'(a)') 'fluxtop_clrsky*100:' +c write (6,'(8f7.2)') +c & (100.*fluxtop_clrsky(j)) + +c write (6,'(a)') '100.*f_adj:' +c write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'transmax:' +c write (6,'(8f7.2)') (transmax(ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'tau:' +c write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'emcld:' +c write (6,'(8f7.2)') (emcld(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'total_trans:' +c write (6,'(8f7.2)') +c & (trans_layers_above(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'total_emiss:' +c write (6,'(8f7.2)') +c & (1.0-trans_layers_above(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'total_trans:' +c write (6,'(8f7.2)') +c & (trans_layers_above(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'ppout:' +c write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint) +c enddo ! j +c endif + + end if + +! ---------------------------------------------------! + +! +! ---------------------------------------------------! +! DETERMINE CLOUD TOP PRESSURE +! +! again the 2 methods differ according to whether +! or not you use the physical cloud top pressure (top_height = 2) +! or the radiatively determined cloud top pressure (top_height = 1 or 3) +! + + !compute cloud top pressure + do 30 ibox=1,ncol + !segregate according to optical thickness + if (top_height .eq. 1 .or. top_height .eq. 3) then + !find level whose temperature + !most closely matches brightness temperature + do j=1,npoints + nmatch(j)=0 + enddo + do 29 ilev=1,nlev-1 +!cdir nodep + do j=1,npoints + if ((at(j,ilev) .ge. tb(j,ibox) .and. + & at(j,ilev+1) .lt. tb(j,ibox)) .or. + & (at(j,ilev) .le. tb(j,ibox) .and. + & at(j,ilev+1) .gt. tb(j,ibox))) then + + nmatch(j)=nmatch(j)+1 + if(abs(at(j,ilev)-tb(j,ibox)) .lt. + & abs(at(j,ilev+1)-tb(j,ibox))) then + match(j,nmatch(j))=ilev + else + match(j,nmatch(j))=ilev+1 + end if + end if + enddo +29 continue + + do j=1,npoints + if (nmatch(j) .ge. 1) then + ptop(j,ibox)=pfull(j,match(j,nmatch(j))) + levmatch(j,ibox)=match(j,nmatch(j)) + else + if (tb(j,ibox) .lt. atmin(j)) then + ptop(j,ibox)=ptrop(j) + levmatch(j,ibox)=itrop(j) + end if + if (tb(j,ibox) .gt. atmax(j)) then + ptop(j,ibox)=pfull(j,nlev) + levmatch(j,ibox)=nlev + end if + end if + enddo ! j + + else ! if (top_height .eq. 1 .or. top_height .eq. 3) + + do j=1,npoints + ptop(j,ibox)=0. + enddo + do ilev=1,nlev + do j=1,npoints + if ((ptop(j,ibox) .eq. 0. ) +cIM & .and.(frac_out(j,ibox,ilev) .ne. 0)) then + & .and.(frac_out(j,ibox,ilev) .ne. 0.0)) then + ptop(j,ibox)=pfull(j,ilev) + levmatch(j,ibox)=ilev + end if + end do + end do + end if + + do j=1,npoints + if (tau(j,ibox) .le. (tauchk )) then + ptop(j,ibox)=0. + levmatch(j,ibox)=0 + endif + enddo + +30 continue + +! +! +! ---------------------------------------------------! + + +! +! ---------------------------------------------------! +! DETERMINE ISCCP CLOUD TYPE FREQUENCIES +! +! Now that ptop and tau have been determined, +! determine amount of each of the 49 ISCCP cloud +! types +! +! Also compute grid box mean cloud top pressure and +! optical thickness. The mean cloud top pressure and +! optical thickness are averages over the cloudy +! area only. The mean cloud top pressure is a linear +! average of the cloud top pressures. The mean cloud +! optical thickness is computed by converting optical +! thickness to an albedo, averaging in albedo units, +! then converting the average albedo back to a mean +! optical thickness. +! + + !compute isccp frequencies + + !reset frequencies + do 38 ilev=1,7 + do 38 ilev2=1,7 + do j=1,npoints ! + fq_isccp(j,ilev,ilev2)=0. + enddo +38 continue + + !reset variables need for averaging cloud properties + do j=1,npoints + totalcldarea(j) = 0. + meanalbedocld(j) = 0. + meanptop(j) = 0. + meantaucld(j) = 0. + enddo ! j + + boxarea = 1./real(ncol) + + !determine optical depth category +cIM do 39 j=1,npoints +cIM do ibox=1,ncol + do 39 ibox=1,ncol + do j=1,npoints + +cIM +c CALL CPU_time(t1) +cIM + + if (tau(j,ibox) .gt. (tauchk ) + & .and. ptop(j,ibox) .gt. 0.) then + box_cloudy(j,ibox)=.true. + endif + +cIM +c CALL CPU_time(t2) +c print*,'IF tau t2 - t1',t2 - t1 + +c CALL CPU_time(t1) +cIM + + if (box_cloudy(j,ibox)) then + + ! totalcldarea always diagnosed day or night + totalcldarea(j) = totalcldarea(j) + boxarea + + if (sunlit(j).eq.1) then + + ! tau diagnostics only with sunlight + + boxtau(j,ibox) = tau(j,ibox) + + !convert optical thickness to albedo + albedocld(j,ibox) + & =real(invtau(min(nint(100.*tau(j,ibox)),45000))) + + !contribute to averaging + meanalbedocld(j) = meanalbedocld(j) + & +albedocld(j,ibox)*boxarea + + endif + + endif + +cIM +c CALL CPU_time(t2) +c print*,'IF box_cloudy t2 - t1',t2 - t1 + +c CALL CPU_time(t1) +cIM BEG +cIM !convert ptop to millibars + ptop(j,ibox)=ptop(j,ibox) / 100. + +cIM !save for output cloud top pressure and optical thickness + boxptop(j,ibox) = ptop(j,ibox) +cIM END + +cIM BEG + !reset itau(j), ipres(j) + itau(j) = 0 + ipres(j) = 0 + + if (tau(j,ibox) .lt. isccp_taumin) then + itau(j)=1 + else if (tau(j,ibox) .ge. isccp_taumin + & + & .and. tau(j,ibox) .lt. 1.3) then + itau(j)=2 + else if (tau(j,ibox) .ge. 1.3 + & .and. tau(j,ibox) .lt. 3.6) then + itau(j)=3 + else if (tau(j,ibox) .ge. 3.6 + & .and. tau(j,ibox) .lt. 9.4) then + itau(j)=4 + else if (tau(j,ibox) .ge. 9.4 + & .and. tau(j,ibox) .lt. 23.) then + itau(j)=5 + else if (tau(j,ibox) .ge. 23. + & .and. tau(j,ibox) .lt. 60.) then + itau(j)=6 + else if (tau(j,ibox) .ge. 60.) then + itau(j)=7 + end if + + !determine cloud top pressure category + if ( ptop(j,ibox) .gt. 0. + & .and.ptop(j,ibox) .lt. 180.) then + ipres(j)=1 + else if(ptop(j,ibox) .ge. 180. + & .and.ptop(j,ibox) .lt. 310.) then + ipres(j)=2 + else if(ptop(j,ibox) .ge. 310. + & .and.ptop(j,ibox) .lt. 440.) then + ipres(j)=3 + else if(ptop(j,ibox) .ge. 440. + & .and.ptop(j,ibox) .lt. 560.) then + ipres(j)=4 + else if(ptop(j,ibox) .ge. 560. + & .and.ptop(j,ibox) .lt. 680.) then + ipres(j)=5 + else if(ptop(j,ibox) .ge. 680. + & .and.ptop(j,ibox) .lt. 800.) then + ipres(j)=6 + else if(ptop(j,ibox) .ge. 800.) then + ipres(j)=7 + end if +cIM END + + if (sunlit(j).eq.1 .or. top_height .eq. 3) then + +cIM !convert ptop to millibars +cIM ptop(j,ibox)=ptop(j,ibox) / 100. + +cIM !save for output cloud top pressure and optical thickness +cIM boxptop(j,ibox) = ptop(j,ibox) + + if (box_cloudy(j,ibox)) then + + meanptop(j) = meanptop(j) + ptop(j,ibox)*boxarea + +cIM !reset itau(j), ipres(j) +cIM itau(j) = 0 +cIM ipres(j) = 0 + +c if (tau(j,ibox) .lt. isccp_taumin) then +c itau(j)=1 +c else if (tau(j,ibox) .ge. isccp_taumin +c & +c & .and. tau(j,ibox) .lt. 1.3) then +c itau(j)=2 +c else if (tau(j,ibox) .ge. 1.3 +c & .and. tau(j,ibox) .lt. 3.6) then +c itau(j)=3 +c else if (tau(j,ibox) .ge. 3.6 +c & .and. tau(j,ibox) .lt. 9.4) then +c itau(j)=4 +c else if (tau(j,ibox) .ge. 9.4 +c & .and. tau(j,ibox) .lt. 23.) then +c itau(j)=5 +c else if (tau(j,ibox) .ge. 23. +c & .and. tau(j,ibox) .lt. 60.) then +c itau(j)=6 +c else if (tau(j,ibox) .ge. 60.) then +c itau(j)=7 +c end if + +c !determine cloud top pressure category +c if ( ptop(j,ibox) .gt. 0. +c & .and.ptop(j,ibox) .lt. 180.) then +c ipres(j)=1 +c else if(ptop(j,ibox) .ge. 180. +c & .and.ptop(j,ibox) .lt. 310.) then +c ipres(j)=2 +c else if(ptop(j,ibox) .ge. 310. +c & .and.ptop(j,ibox) .lt. 440.) then +c ipres(j)=3 +c else if(ptop(j,ibox) .ge. 440. +c & .and.ptop(j,ibox) .lt. 560.) then +c ipres(j)=4 +c else if(ptop(j,ibox) .ge. 560. +c & .and.ptop(j,ibox) .lt. 680.) then +c ipres(j)=5 +c else if(ptop(j,ibox) .ge. 680. +c & .and.ptop(j,ibox) .lt. 800.) then +c ipres(j)=6 +c else if(ptop(j,ibox) .ge. 800.) then +c ipres(j)=7 +c end if + + !update frequencies + if(ipres(j) .gt. 0.and.itau(j) .gt. 0) then + fq_isccp(j,itau(j),ipres(j))= + & fq_isccp(j,itau(j),ipres(j))+ boxarea + end if + +cIM calcul stats regime dynamique BEG +! iw(j) = int((w(j)-wmin)/pas_w) +1 +! pctj(itau(j),ipres(j),iw(j))=.FALSE. +! !update frequencies W500 +! if (pct_ocean(j)) then +! if (ipres(j) .gt. 0.and.itau(j) .gt. 0) then +! if (iw(j) .gt. int(wmin).and.iw(j) .le. iwmx) then +c print*,' ISCCP iw=',iw(j),j +! fq_dynreg(itau(j),ipres(j),iw(j))= +! & fq_dynreg(itau(j),ipres(j),iw(j))+ +! & boxarea +c & fq_isccp(j,itau(j),ipres(j)) +! pctj(itau(j),ipres(j),iw(j))=.TRUE. +c nfq_dynreg(itau(j),ipres(j),iw(j))= +c & nfq_dynreg(itau(j),ipres(j),iw(j))+1. +! end if +! end if +! end if +cIM calcul stats regime dynamique END + end if !IM boxcloudy + + end if !IM sunlit + +cIM +c CALL CPU_time(t2) +c print*,'IF sunlit boxcloudy t2 - t1',t2 - t1 +cIM + enddo !IM ibox/j + + +cIM ajout stats s/ W500 BEG +cIM ajout stats s/ W500 END + +c if(j.EQ.6722) then +c print*,' ISCCP',w(j),iw(j),ipres(j),itau(j) +c endif + +! if (pct_ocean(j)) then +! if (ipres(j) .gt. 0.and.itau(j) .gt. 0) then +! if (iw(j) .gt. int(wmin).and.iw(j) .le. iwmx) then +! if(pctj(itau(j),ipres(j),iw(j))) THEN +! nfq_dynreg(itau(j),ipres(j),iw(j))= +! & nfq_dynreg(itau(j),ipres(j),iw(j))+1. +c if(itau(j).EQ.4.AND.ipres(j).EQ.2.AND. +c & iw(j).EQ.10) then +c PRINT*,' isccp AVANT', +c & nfq_dynreg(itau(j),ipres(j),iw(j)), +c & fq_dynreg(itau(j),ipres(j),iw(j)) +c endif +! endif +! endif +! endif +! endif +39 continue !IM j/ibox + + !compute mean cloud properties + do j=1,npoints + if (totalcldarea(j) .gt. 0.) then + meanptop(j) = meanptop(j) / totalcldarea(j) + if (sunlit(j).eq.1) then + meanalbedocld(j) = meanalbedocld(j) / totalcldarea(j) + meantaucld(j) = tautab(min(255,max(1,nint(meanalbedocld(j))))) + end if + end if + enddo ! j +! +cIM ajout stats s/ W500 BEG +! do nw = 1, iwmx +! do l = 1, 7 +! do k = 1, 7 +! if (nfq_dynreg(k,l,nw).GT.0.) then +! fq_dynreg(k,l,nw) = fq_dynreg(k,l,nw)/nfq_dynreg(k,l,nw) +c if(k.EQ.4.AND.l.EQ.2.AND.nw.EQ.10) then +c print*,' isccp APRES',nfq_dynreg(k,l,nw), +c & fq_dynreg(k,l,nw) +c endif +! else +! if(fq_dynreg(k,l,nw).NE.0.) then +! print*,'nfq_dynreg = 0 tau,pc,nw',k,l,nw,fq_dynreg(k,l,nw) +! endif +c fq_dynreg(k,l,nw) = -1.E+20 +c nfq_dynreg(k,l,nw) = 1.E+20 +! end if +! enddo !k +! enddo !l +! enddo !nw +cIM ajout stats s/ W500 END +! ---------------------------------------------------! + +! ---------------------------------------------------! +! OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM +! +!cIM +c if (debugcol.ne.0) then +! +c do j=1,npoints,debugcol + +c !produce character output +c do ilev=1,nlev +c do ibox=1,ncol +c acc(ilev,ibox)=0 +c enddo +c enddo + +c do ilev=1,nlev +c do ibox=1,ncol +c acc(ilev,ibox)=frac_out(j,ibox,ilev)*2 +c if (levmatch(j,ibox) .eq. ilev) +c & acc(ilev,ibox)=acc(ilev,ibox)+1 +c enddo +c enddo + + !print test + +c write(ftn09,11) j +c11 format('ftn09.',i4.4) +c open(9, FILE=ftn09, FORM='FORMATTED') + +c write(9,'(a1)') ' ' +c write(9,'(10i5)') +c & (ilev,ilev=5,nlev,5) +c write(9,'(a1)') ' ' + +c do ibox=1,ncol +c write(9,'(40(a1),1x,40(a1))') +c & (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev) +c & ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev) +c end do +c close(9) +c +cIM +c if (ncolprint.ne.0) then +c write(6,'(a1)') ' ' +c write(6,'(a2,1X,5(a7,1X),a50)') +c & 'ilev', +c & 'pfull','at', +c & 'cc*100','dem_s','dtau_s', +c & 'cchar' + +! do 4012 ilev=1,nlev +! write(6,'(60i2)') (box(i,ilev),i=1,ncolprint) +! write(6,'(i2,1X,5(f7.2,1X),50(a1))') +! & ilev, +! & pfull(j,ilev)/100.,at(j,ilev), +! & cc(j,ilev)*100.0,dem_s(j,ilev),dtau_s(j,ilev) +! & ,(cchar(acc(ilev,ibox)+1),ibox=1,ncolprint) +!4012 continue +c write (6,'(a)') 'skt(j):' +c write (6,'(8f7.2)') skt(j) + +c write (6,'(8I7)') (ibox,ibox=1,ncolprint) + +c write (6,'(a)') 'tau:' +c write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'tb:' +c write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'ptop:' +c write (6,'(8f7.2)') (ptop(j,ibox),ibox=1,ncolprint) +c endif + +c enddo + +c end if + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/limit_read_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/limit_read_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/limit_read_mod.F90 (revision 1280) @@ -0,0 +1,337 @@ +! +! $Header$ +! +MODULE limit_read_mod +! +! This module reads the fichier "limit.nc" containing fields for surface forcing. +! +! Module subroutines : +! limit_read_frac : call limit_read_tot and return the fractions +! limit_read_rug_alb : return rugosity and albedo, if coupled ocean call limit_read_tot first +! limit_read_sst : return sea ice temperature +! limit_read_tot : read limit.nc and store the fields in local modules variables +! + IMPLICIT NONE + + REAL, ALLOCATABLE, DIMENSION(:,:), SAVE, PRIVATE :: pctsrf +!$OMP THREADPRIVATE(pctsrf) + REAL, ALLOCATABLE, DIMENSION(:), SAVE, PRIVATE :: rugos +!$OMP THREADPRIVATE(rugos) + REAL, ALLOCATABLE, DIMENSION(:), SAVE, PRIVATE :: albedo +!$OMP THREADPRIVATE(albedo) + REAL, ALLOCATABLE, DIMENSION(:), SAVE, PRIVATE :: sst +!$OMP THREADPRIVATE(sst) + LOGICAL,SAVE :: read_continents=.FALSE. +!$OMP THREADPRIVATE(read_continents) + +CONTAINS +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! +!! Public subroutines : +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE limit_read_frac(itime, dtime, jour, pctsrf_new, is_modified) +! +! This subroutine is called from "change_srf_frac" for case of +! ocean=force or from ocean_slab_frac for ocean=slab. +! The fraction for all sub-surfaces at actual time step is returned. + + USE dimphy + INCLUDE "indicesol.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime ! time step + INTEGER, INTENT(IN) :: jour ! current day + REAL , INTENT(IN) :: dtime ! length of time step + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon,nbsrf), INTENT(OUT) :: pctsrf_new ! sub surface fractions + LOGICAL, INTENT(OUT) :: is_modified ! true if pctsrf is modified at this time step + +! End declaration +!**************************************************************************************** + +! 1) Read file limit.nc + CALL limit_read_tot(itime, dtime, jour, is_modified) + +! 2) Return the fraction read in limit_read_tot + pctsrf_new(:,:) = pctsrf(:,:) + + END SUBROUTINE limit_read_frac + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE limit_read_rug_alb(itime, dtime, jour, & + knon, knindex, & + rugos_out, alb_out) +! +! This subroutine is called from surf_land_bucket. +! The flag "ok_veget" must can not be true. If coupled run, "ocean=couple" +! then this routine will call limit_read_tot. +! + USE dimphy + USE surface_data + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime ! numero du pas de temps courant + INTEGER, INTENT(IN) :: jour ! jour a lire dans l'annee + REAL , INTENT(IN) :: dtime ! pas de temps de la physique (en s) + INTEGER, INTENT(IN) :: knon ! nomber of points on compressed grid + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex ! grid point number for compressed grid +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: rugos_out + REAL, DIMENSION(klon), INTENT(OUT) :: alb_out + +! Local variables +!**************************************************************************************** + INTEGER :: i + LOGICAL :: is_modified +!**************************************************************************************** + + IF (type_ocean == 'couple') THEN + ! limit.nc has not yet been read. Do it now! + CALL limit_read_tot(itime, dtime, jour, is_modified) + END IF + + DO i=1,knon + rugos_out(i) = rugos(knindex(i)) + alb_out(i) = albedo(knindex(i)) + END DO + + END SUBROUTINE limit_read_rug_alb + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE limit_read_sst(knon, knindex, sst_out) +! +! This subroutine returns the sea surface temperature already read from limit.nc. +! + USE dimphy, ONLY : klon + + INTEGER, INTENT(IN) :: knon ! nomber of points on compressed grid + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex ! grid point number for compressed grid + REAL, DIMENSION(klon), INTENT(OUT) :: sst_out + + INTEGER :: i + + DO i = 1, knon + sst_out(i) = sst(knindex(i)) + END DO + + END SUBROUTINE limit_read_sst + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! +!! Private subroutine : +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE limit_read_tot(itime, dtime, jour, is_modified) +! +! Read everything needed from limit.nc +! +! 0) Initialize +! 1) Open the file limit.nc, if it is time +! 2) Read fraction, if not type_ocean=couple +! 3) Read sea surface temperature, if not type_ocean=couple +! 4) Read albedo and rugosity for land surface, only in case of no vegetation model +! 5) Close file and distribuate variables to all processus + + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE surface_data, ONLY : type_ocean, ok_veget + USE netcdf + + IMPLICIT NONE + + INCLUDE "indicesol.h" + +! In- and ouput arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime ! numero du pas de temps courant + INTEGER, INTENT(IN) :: jour ! jour a lire dans l'annee + REAL , INTENT(IN) :: dtime ! pas de temps de la physique (en s) + + LOGICAL, INTENT(OUT) :: is_modified ! true if pctsrf is modified at this time step + +! Locals variables with attribute SAVE +!**************************************************************************************** +! frequence de lecture des conditions limites (en pas de physique) + INTEGER,SAVE :: lmt_pas +!$OMP THREADPRIVATE(lmt_pas) + LOGICAL, SAVE :: first_call=.TRUE. +!$OMP THREADPRIVATE(first_call) +! Locals variables +!**************************************************************************************** + INTEGER :: nid, nvarid + INTEGER :: ii, ierr + INTEGER, DIMENSION(2) :: start, epais + REAL, DIMENSION(klon_glo,nbsrf) :: pct_glo ! fraction at global grid + REAL, DIMENSION(klon_glo) :: sst_glo ! sea-surface temperature at global grid + REAL, DIMENSION(klon_glo) :: rug_glo ! rugosity at global grid + REAL, DIMENSION(klon_glo) :: alb_glo ! albedo at global grid + CHARACTER(len=20) :: modname='limit_read_mod' + +! End declaration +!**************************************************************************************** + +!**************************************************************************************** +! 0) Initialization +! +!**************************************************************************************** + IF (first_call) THEN + ! calculate number of time steps for one day + lmt_pas = NINT(86400./dtime * 1.0) + + ! Allocate module save variables + IF ( type_ocean /= 'couple' ) THEN + ALLOCATE(pctsrf(klon,nbsrf), sst(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname, 'PB in allocating pctsrf and sst',1) + END IF + + IF ( .NOT. ok_veget ) THEN + ALLOCATE(rugos(klon), albedo(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname, 'PB in allocating rugos and albedo',1) + END IF + + first_call=.FALSE. + ENDIF + +!**************************************************************************************** +! 1) Open the file limit.nc if it is the right moment to read, once a day. +! The file is read only by the master thread of the master mpi process(is_mpi_root) +! +!**************************************************************************************** + + is_modified = .FALSE. + IF (MOD(itime-1, lmt_pas) == 0) THEN ! time to read + is_modified = .TRUE. +!$OMP MASTER ! Only master thread + IF (is_mpi_root) THEN ! Only master processus + + ierr = NF90_OPEN ('limit.nc', NF90_NOWRITE, nid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,& + 'Pb d''ouverture du fichier de conditions aux limites',1) + + ! La tranche de donnees a lire: + start(1) = 1 + start(2) = jour + epais(1) = klon_glo + epais(2) = 1 + + +!**************************************************************************************** +! 2) Read fraction if not type_ocean=couple +! +!**************************************************************************************** + + IF ( type_ocean /= 'couple') THEN +! +! Ocean fraction + ierr = NF90_INQ_VARID(nid, 'FOCE', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname, 'Le champ est absent',1) + + ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_oce),start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour ' ,1) +! +! Sea-ice fraction + ierr = NF90_INQ_VARID(nid, 'FSIC', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ est absent',1) + + ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_sic),start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour ' ,1) + + +! Read land and continentals fraction only if asked for + IF (read_continents .OR. itime == 1) THEN +! +! Land fraction + ierr = NF90_INQ_VARID(nid, 'FTER', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ est absent',1) + + ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_ter),start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour ',1) +! +! Continentale ice fraction + ierr = NF90_INQ_VARID(nid, 'FLIC', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ est absent',1) + + ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_lic),start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour ',1) + END IF + + END IF ! type_ocean /= couple + +!**************************************************************************************** +! 3) Read sea-surface temperature, if not coupled ocean +! +!**************************************************************************************** + IF ( type_ocean /= 'couple') THEN + + ierr = NF90_INQ_VARID(nid, 'SST', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ est absent',1) + + ierr = NF90_GET_VAR(nid,nvarid,sst_glo,start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour ',1) + + END IF + +!**************************************************************************************** +! 4) Read albedo and rugosity for land surface, only in case of no vegetation model +! +!**************************************************************************************** + + IF (.NOT. ok_veget) THEN +! +! Read albedo + ierr = NF90_INQ_VARID(nid, 'ALB', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ est absent',1) + + ierr = NF90_GET_VAR(nid,nvarid,alb_glo,start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour ',1) +! +! Read rugosity + ierr = NF90_INQ_VARID(nid, 'RUG', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ est absent',1) + + ierr = NF90_GET_VAR(nid,nvarid,rug_glo,start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour ',1) + + END IF + +!**************************************************************************************** +! 5) Close file and distribuate variables to all processus +! +!**************************************************************************************** + ierr = NF90_CLOSE(nid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Pb when closing file', 1) + ENDIF ! is_mpi_root + +!$OMP END MASTER +!$OMP BARRIER + + IF ( type_ocean /= 'couple') THEN + CALL Scatter(sst_glo,sst) + CALL Scatter(pct_glo(:,is_oce),pctsrf(:,is_oce)) + CALL Scatter(pct_glo(:,is_sic),pctsrf(:,is_sic)) + IF (read_continents .OR. itime == 1) THEN + CALL Scatter(pct_glo(:,is_ter),pctsrf(:,is_ter)) + CALL Scatter(pct_glo(:,is_lic),pctsrf(:,is_lic)) + END IF + END IF + + IF (.NOT. ok_veget) THEN + CALL Scatter(alb_glo, albedo) + CALL Scatter(rug_glo, rugos) + END IF + + ENDIF ! time to read + + END SUBROUTINE limit_read_tot + + +END MODULE limit_read_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/limit_slab.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/limit_slab.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/limit_slab.F90 (revision 1280) @@ -0,0 +1,122 @@ +! $Header$ + +SUBROUTINE limit_slab(itime, dtime, jour, lmt_bils, lmt_foce, diff_sst) + + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE netcdf + + IMPLICIT NONE + + INCLUDE "indicesol.h" + INCLUDE "temps.h" + INCLUDE "clesphys.h" + INCLUDE "dimensions.h" + +! In- and ouput arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime ! numero du pas de temps courant + INTEGER, INTENT(IN) :: jour ! jour a lire dans l'annee + REAL , INTENT(IN) :: dtime ! pas de temps de la physique (en s) + REAL, DIMENSION(klon), INTENT(OUT) :: lmt_bils, lmt_foce, diff_sst + +! Locals variables with attribute SAVE +!**************************************************************************************** + REAL, DIMENSION(:), ALLOCATABLE, SAVE :: bils_save, foce_save +!$OMP THREADPRIVATE(bils_save, foce_save) + +! Locals variables +!**************************************************************************************** + INTEGER :: lmt_pas + INTEGER :: nvarid, nid, ierr, i + INTEGER, DIMENSION(2) :: start, epais + REAL, DIMENSION(klon_glo):: bils_glo, foce_glo, sst_l_glo, sst_lp1_glo, diff_sst_glo + CHARACTER (len = 20) :: modname = 'limit_slab' + +! End declaration +!**************************************************************************************** + + ! calculate number of time steps for one day + lmt_pas = NINT(86400./dtime) + + IF (MOD(itime-1, lmt_pas) == 0) THEN ! time to read + !$OMP MASTER ! Only master thread + IF (is_mpi_root) THEN ! Only master processus + print*,'in limit_slab time to read, itime=',itime + + ierr = NF90_OPEN ('limit_slab.nc', NF90_NOWRITE, nid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,& + 'Pb in opening file limit_slab.nc',1) + + ! La tranche de donnees a lire: + start(1) = 1 + start(2) = jour + epais(1) = klon_glo + epais(2) = 1 + +!**************************************************************************************** +! 2) Read bils and ocean fraction +! +!**************************************************************************************** +! +! Read bils_glo + ierr = NF90_INQ_VARID(nid, 'BILS_OCE', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'The variable is abstent',1) + + ierr = NF90_GET_VAR(nid,nvarid,bils_glo,start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Reading of failed',1) +! +! Read foce_glo + ierr = NF90_INQ_VARID(nid, 'FOCE', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'The variable is abstent',1) + + ierr = NF90_GET_VAR(nid,nvarid,foce_glo,start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Reading of failed',1) +! +! Read sst_glo for this day + ierr = NF90_INQ_VARID(nid, 'SST', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'The variable is abstent',1) + + ierr = NF90_GET_VAR(nid,nvarid,sst_l_glo,start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Reading of failed',1) + +! Read sst_glo for one day ahead + start(2) = jour + 1 + IF (start(2) > 360) start(2)=1 + ierr = NF90_GET_VAR(nid,nvarid,sst_lp1_glo,start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Reading of day+1 failed',1) + +! Calculate difference in temperature between this day and one ahead + DO i=1, klon_glo-1 + diff_sst_glo(i) = sst_lp1_glo(i) - sst_l_glo(i) + END DO + diff_sst_glo(klon_glo) = sst_lp1_glo(klon_glo) - sst_l_glo(1) + +!**************************************************************************************** +! 5) Close file and distribuate variables to all processus +! +!**************************************************************************************** + ierr = NF90_CLOSE(nid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Pb when closing file', 1) + ENDIF ! is_mpi_root + +!$OMP END MASTER + + IF (.NOT. ALLOCATED(bils_save)) THEN + ALLOCATE(bils_save(klon), foce_save(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('limit_slab', 'pb in allocation',1) + END IF + + CALL Scatter(bils_glo, bils_save) + CALL Scatter(foce_glo, foce_save) + CALL Scatter(diff_sst_glo, diff_sst) + + ELSE ! not time to read + diff_sst(:) = 0. + ENDIF ! time to read + + lmt_bils(:) = bils_save(:) + lmt_foce(:) = foce_save(:) + +END SUBROUTINE limit_slab Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/lnblnk1.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/lnblnk1.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/lnblnk1.F (revision 1280) @@ -0,0 +1,47 @@ +! +! $Header$ +! + INTEGER FUNCTION lnblnk1 (letter) + +C-------------------------------------------------------- +C Fonction qui determine la longeur d'un string sans les +C blancs qui suivent. Le critere pour determiner la fin du +C string est, trois blancs de suite +C--------------------------------------------------------- +C ARGUMENTS +C +++++++++ +C letter: CHARACTER*xxx (xxx < imax) +C le string dont on determine la longuer +C lnblnk1: INTEGER +C le nombre de characteres +C +C PARAMETER +C +++++++++ +C imax : INTEGER +C le nombre maximale de character que peut contenir le string +C a traiter + + IMPLICIT NONE + INTEGER i,imax + PARAMETER (imax = 256) +c CHARACTER*256 letter + CHARACTER*4 letter + + i=0 + +10 i=i+1 +c IF (letter(i:i+1) . EQ . ' ') THEN + IF (letter(i:i) . EQ . ' ') THEN +c print*,'i=',i,'letter(i:i+1)=',letter(i:i+1) +c print*,'i=',i + GOTO 20 + ELSE + GOTO 10 + ENDIF + +20 lnblnk1=i-1 +c PRINT*,'lnblnk1=',lnblnk1 + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/minmaxqfi.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/minmaxqfi.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/minmaxqfi.F90 (revision 1280) @@ -0,0 +1,33 @@ +! +! $Id$ +! +SUBROUTINE minmaxqfi(zq,qmin,qmax,comment) + USE dimphy + IMPLICIT NONE + +! Entrees + REAL,DIMENSION(klon,klev), INTENT(IN) :: zq + REAL,INTENT(IN) :: qmin,qmax + CHARACTER(LEN=*),INTENT(IN) :: comment + +! Local + INTEGER,DIMENSION(klon) :: jadrs + INTEGER :: i, jbad, k + + DO k = 1, klev + jbad = 0 + DO i = 1, klon + IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN + jbad = jbad + 1 + jadrs(jbad) = i + ENDIF + ENDDO + IF (jbad.GT.0) THEN + WRITE(*,*)comment + DO i = 1, jbad + WRITE(*,*) "i,k,q=", jadrs(i),k,zq(jadrs(i),k) + ENDDO + ENDIF + ENDDO + +END SUBROUTINE minmaxqfi Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_grid_phy_lmdz.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_grid_phy_lmdz.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_grid_phy_lmdz.F90 (revision 1280) @@ -0,0 +1,447 @@ +! +!$Header$ +! +MODULE mod_grid_phy_lmdz + INTEGER,SAVE :: nbp_lon ! == iim + INTEGER,SAVE :: nbp_lat ! == jjmp1 + INTEGER,SAVE :: nbp_lev ! == llm + INTEGER,SAVE :: klon_glo + + INTERFACE grid1dTo2d_glo + MODULE PROCEDURE grid1dTo2d_glo_i,grid1dTo2d_glo_i1,grid1dTo2d_glo_i2,grid1dTo2d_glo_i3, & + grid1dTo2d_glo_r,grid1dTo2d_glo_r1,grid1dTo2d_glo_r2,grid1dTo2d_glo_r3, & + grid1dTo2d_glo_l,grid1dTo2d_glo_l1,grid1dTo2d_glo_l2,grid1dTo2d_glo_l3 + END INTERFACE + + INTERFACE grid2dTo1d_glo + MODULE PROCEDURE grid2dTo1d_glo_i,grid2dTo1d_glo_i1,grid2dTo1d_glo_i2,grid2dTo1d_glo_i3, & + grid2dTo1d_glo_r,grid2dTo1d_glo_r1,grid2dTo1d_glo_r2,grid2dTo1d_glo_r3, & + grid2dTo1d_glo_l,grid2dTo1d_glo_l1,grid2dTo1d_glo_l2,grid2dTo1d_glo_l3 + END INTERFACE + +CONTAINS + +!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! SUBROUTINE grid1dTo2d !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + SUBROUTINE Init_grid_phy_lmdz(iim,jjp1,llm) + IMPLICIT NONE + INTEGER, INTENT(in) :: iim + INTEGER, INTENT(in) :: jjp1 + INTEGER, INTENT(in) :: llm + + nbp_lon=iim + nbp_lat=jjp1 + nbp_lev=llm + klon_glo=(iim*jjp1)-2*(iim-1) + + END SUBROUTINE Init_grid_phy_lmdz + + + SUBROUTINE grid1dTo2d_glo_i(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid1dTo2d_glo_igen(VarIn,VarOut,1) + + END SUBROUTINE grid1dTo2d_glo_i + + + SUBROUTINE grid1dTo2d_glo_i1(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2)) + + END SUBROUTINE grid1dTo2d_glo_i1 + + SUBROUTINE grid1dTo2d_glo_i2(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)) + + END SUBROUTINE grid1dTo2d_glo_i2 + + SUBROUTINE grid1dTo2d_glo_i3(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid1dTo2d_glo_i3 + + + SUBROUTINE grid1dTo2d_glo_r(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid1dTo2d_glo_rgen(VarIn,VarOut,1) + + END SUBROUTINE grid1dTo2d_glo_r + + + SUBROUTINE grid1dTo2d_glo_r1(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2)) + + END SUBROUTINE grid1dTo2d_glo_r1 + + SUBROUTINE grid1dTo2d_glo_r2(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)) + + END SUBROUTINE grid1dTo2d_glo_r2 + + SUBROUTINE grid1dTo2d_glo_r3(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid1dTo2d_glo_r3 + + + + SUBROUTINE grid1dTo2d_glo_l(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid1dTo2d_glo_lgen(VarIn,VarOut,1) + + END SUBROUTINE grid1dTo2d_glo_l + + + SUBROUTINE grid1dTo2d_glo_l1(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2)) + + END SUBROUTINE grid1dTo2d_glo_l1 + + SUBROUTINE grid1dTo2d_glo_l2(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)) + + END SUBROUTINE grid1dTo2d_glo_l2 + + SUBROUTINE grid1dTo2d_glo_l3(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid1dTo2d_glo_l3 + + SUBROUTINE grid2dTo1d_glo_i(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL grid2dTo1d_glo_igen(VarIn,VarOut,1) + + END SUBROUTINE grid2dTo1d_glo_i + + + SUBROUTINE grid2dTo1d_glo_i1(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3)) + + END SUBROUTINE grid2dTo1d_glo_i1 + + SUBROUTINE grid2dTo1d_glo_i2(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid2dTo1d_glo_i2 + + SUBROUTINE grid2dTo1d_glo_i3(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5)) + + END SUBROUTINE grid2dTo1d_glo_i3 + + + + + SUBROUTINE grid2dTo1d_glo_r(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL grid2dTo1d_glo_rgen(VarIn,VarOut,1) + + END SUBROUTINE grid2dTo1d_glo_r + + + SUBROUTINE grid2dTo1d_glo_r1(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3)) + + END SUBROUTINE grid2dTo1d_glo_r1 + + SUBROUTINE grid2dTo1d_glo_r2(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid2dTo1d_glo_r2 + + SUBROUTINE grid2dTo1d_glo_r3(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5)) + + END SUBROUTINE grid2dTo1d_glo_r3 + + + + SUBROUTINE grid2dTo1d_glo_l(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL grid2dTo1d_glo_lgen(VarIn,VarOut,1) + + END SUBROUTINE grid2dTo1d_glo_l + + + SUBROUTINE grid2dTo1d_glo_l1(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3)) + + END SUBROUTINE grid2dTo1d_glo_l1 + + SUBROUTINE grid2dTo1d_glo_l2(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid2dTo1d_glo_l2 + + SUBROUTINE grid2dTo1d_glo_l3(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5)) + + END SUBROUTINE grid2dTo1d_glo_l3 + +END MODULE mod_grid_phy_lmdz + + + + SUBROUTINE grid1dTo2d_glo_igen(VarIn,VarOut,dimsize) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN) ,DIMENSION(klon_glo,dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarOut + INTEGER :: i,ij,Offset + + + Offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_glo + VarOut(ij+offset-1,i)=VarIn(ij,i) + ENDDO + ENDDO + + + DO i=1,dimsize + DO ij=1,nbp_lon + VarOut(ij,i)=VarIn(1,i) + ENDDO + ENDDO + + + DO i=1,dimsize + DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon + VarOut(ij,i)=VarIn(klon_glo,i) + ENDDO + ENDDO + + END SUBROUTINE grid1dTo2d_glo_igen + + + SUBROUTINE grid1dTo2d_glo_rgen(VarIn,VarOut,dimsize) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN) ,DIMENSION(klon_glo,dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarOut + INTEGER :: i,ij,Offset + + + Offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_glo + VarOut(ij+offset-1,i)=VarIn(ij,i) + ENDDO + ENDDO + + + DO i=1,dimsize + DO ij=1,nbp_lon + VarOut(ij,i)=VarIn(1,i) + ENDDO + ENDDO + + + DO i=1,dimsize + DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon + VarOut(ij,i)=VarIn(klon_glo,i) + ENDDO + ENDDO + + END SUBROUTINE grid1dTo2d_glo_rgen + + SUBROUTINE grid1dTo2d_glo_lgen(VarIn,VarOut,dimsize) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + LOGICAL,INTENT(IN) ,DIMENSION(klon_glo,dimsize) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarOut + INTEGER :: i,ij,Offset + + Offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_glo + VarOut(ij+offset-1,i)=VarIn(ij,i) + ENDDO + ENDDO + + + DO i=1,dimsize + DO ij=1,nbp_lon + VarOut(ij,i)=VarIn(1,i) + ENDDO + ENDDO + + + DO i=1,dimsize + DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon + VarOut(ij,i)=VarIn(klon_glo,i) + ENDDO + ENDDO + + END SUBROUTINE grid1dTo2d_glo_lgen + + + SUBROUTINE grid2dTo1d_glo_igen(VarIn,VarOut,dimsize) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut + INTEGER :: i,ij,offset + + offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_glo + VarOut(ij,i)=VarIn(ij+offset-1,i) + ENDDO + ENDDO + + DO i=1,dimsize + VarOut(1,i)=VarIn(1,i) + ENDDO + + END SUBROUTINE grid2dTo1d_glo_igen + + SUBROUTINE grid2dTo1d_glo_rgen(VarIn,VarOut,dimsize) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut + INTEGER :: i,ij,offset + + offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_glo + VarOut(ij,i)=VarIn(ij+offset-1,i) + ENDDO + ENDDO + + DO i=1,dimsize + VarOut(1,i)=VarIn(1,i) + ENDDO + + END SUBROUTINE grid2dTo1d_glo_rgen + + SUBROUTINE grid2dTo1d_glo_lgen(VarIn,VarOut,dimsize) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + LOGICAL,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut + INTEGER :: i,ij,offset + + offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_glo + VarOut(ij,i)=VarIn(ij+offset-1,i) + ENDDO + ENDDO + + DO i=1,dimsize + VarOut(1,i)=VarIn(1,i) + ENDDO + + END SUBROUTINE grid2dTo1d_glo_lgen Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_mpi_data.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_mpi_data.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_mpi_data.F90 (revision 1280) @@ -0,0 +1,203 @@ +! +!$Header$ +! +MODULE mod_phys_lmdz_mpi_data + USE mod_const_mpi + + INTEGER,SAVE :: ii_begin + INTEGER,SAVE :: ii_end + INTEGER,SAVE :: jj_begin + INTEGER,SAVE :: jj_end + INTEGER,SAVE :: jj_nb + INTEGER,SAVE :: ij_begin + INTEGER,SAVE :: ij_end + INTEGER,SAVE :: ij_nb + INTEGER,SAVE :: klon_mpi_begin + INTEGER,SAVE :: klon_mpi_end + INTEGER,SAVE :: klon_mpi + + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_nb + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_begin + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_end + + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ii_para_begin + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ii_para_end + + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_nb + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_begin + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_end + + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_nb + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_begin + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_end + + + INTEGER,SAVE :: mpi_rank + INTEGER,SAVE :: mpi_size + INTEGER,SAVE :: mpi_root + LOGICAL,SAVE :: is_mpi_root + LOGICAL,SAVE :: is_using_mpi + + + LOGICAL,SAVE :: is_north_pole + LOGICAL,SAVE :: is_south_pole + INTEGER,SAVE :: COMM_LMDZ_PHY + +CONTAINS + + SUBROUTINE Init_phys_lmdz_mpi_data(iim,jjp1,nb_proc,distrib) + USE mod_const_mpi, ONLY : COMM_LMDZ + IMPLICIT NONE + INTEGER,INTENT(in) :: iim + INTEGER,INTENT(in) :: jjp1 + INTEGER,INTENT(in) :: nb_proc + INTEGER,INTENT(in) :: distrib(0:nb_proc-1) + + INTEGER :: ierr + INTEGER :: klon_glo + INTEGER :: i + +#ifdef CPP_MPI + is_using_mpi=.TRUE. +#else + is_using_mpi=.FALSE. +#endif + + if (iim.eq.1) then + klon_glo=1 + else + klon_glo=iim*(jjp1-2)+2 + endif + + COMM_LMDZ_PHY=COMM_LMDZ + + IF (is_using_mpi) THEN +#ifdef CPP_MPI + CALL MPI_COMM_SIZE(COMM_LMDZ_PHY,mpi_size,ierr) + CALL MPI_COMM_RANK(COMM_LMDZ_PHY,mpi_rank,ierr) +#endif + ELSE + mpi_size=1 + mpi_rank=0 + ENDIF + + IF (mpi_rank == 0) THEN + mpi_root = 0 + is_mpi_root = .true. + ENDIF + + IF (mpi_rank == 0) THEN + is_north_pole = .TRUE. + ELSE + is_north_pole = .FALSE. + ENDIF + + IF (mpi_rank == mpi_size-1) THEN + is_south_pole = .TRUE. + ELSE + is_south_pole = .FALSE. + ENDIF + + ALLOCATE(jj_para_nb(0:mpi_size-1)) + ALLOCATE(jj_para_begin(0:mpi_size-1)) + ALLOCATE(jj_para_end(0:mpi_size-1)) + + ALLOCATE(ij_para_nb(0:mpi_size-1)) + ALLOCATE(ij_para_begin(0:mpi_size-1)) + ALLOCATE(ij_para_end(0:mpi_size-1)) + + ALLOCATE(ii_para_begin(0:mpi_size-1)) + ALLOCATE(ii_para_end(0:mpi_size-1)) + + ALLOCATE(klon_mpi_para_nb(0:mpi_size-1)) + ALLOCATE(klon_mpi_para_begin(0:mpi_size-1)) + ALLOCATE(klon_mpi_para_end(0:mpi_size-1)) + + + klon_mpi_para_nb(0:mpi_size-1)=distrib(0:nb_proc-1) + + DO i=0,mpi_size-1 + IF (i==0) THEN + klon_mpi_para_begin(i)=1 + ELSE + klon_mpi_para_begin(i)=klon_mpi_para_end(i-1)+1 + ENDIF + klon_mpi_para_end(i)=klon_mpi_para_begin(i)+klon_mpi_para_nb(i)-1 + ENDDO + + + DO i=0,mpi_size-1 + + IF (i==0) THEN + ij_para_begin(i) = 1 + ELSE + ij_para_begin(i) = klon_mpi_para_begin(i)+iim-1 + ENDIF + + jj_para_begin(i) = (ij_para_begin(i)-1)/iim + 1 + ii_para_begin(i) = MOD(ij_para_begin(i)-1,iim) + 1 + + + ij_para_end(i) = klon_mpi_para_end(i)+iim-1 + jj_para_end(i) = (ij_para_end(i)-1)/iim + 1 + ii_para_end(i) = MOD(ij_para_end(i)-1,iim) + 1 + + + ij_para_nb(i) = ij_para_end(i)-ij_para_begin(i)+1 + jj_para_nb(i) = jj_para_end(i)-jj_para_begin(i)+1 + + ENDDO + + ii_begin = ii_para_begin(mpi_rank) + ii_end = ii_para_end(mpi_rank) + jj_begin = jj_para_begin(mpi_rank) + jj_end = jj_para_end(mpi_rank) + jj_nb = jj_para_nb(mpi_rank) + ij_begin = ij_para_begin(mpi_rank) + ij_end = ij_para_end(mpi_rank) + ij_nb = ij_para_nb(mpi_rank) + klon_mpi_begin = klon_mpi_para_begin(mpi_rank) + klon_mpi_end = klon_mpi_para_end(mpi_rank) + klon_mpi = klon_mpi_para_nb(mpi_rank) + + CALL Print_module_data + + END SUBROUTINE Init_phys_lmdz_mpi_data + + SUBROUTINE print_module_data + IMPLICIT NONE + + + PRINT *, 'ii_begin =', ii_begin + PRINT *, 'ii_end =', ii_end + PRINT *, 'jj_begin =',jj_begin + PRINT *, 'jj_end =', jj_end + PRINT *, 'jj_nb =', jj_nb + PRINT *, 'ij_begin =', ij_begin + PRINT *, 'ij_end =', ij_end + PRINT *, 'ij_nb =', ij_nb + PRINT *, 'klon_mpi_begin =', klon_mpi_begin + PRINT *, 'klon_mpi_end =', klon_mpi_end + PRINT *, 'klon_mpi =', klon_mpi + PRINT *, 'jj_para_nb =', jj_para_nb + PRINT *, 'jj_para_begin =', jj_para_begin + PRINT *, 'jj_para_end =', jj_para_end + PRINT *, 'ii_para_begin =', ii_para_begin + PRINT *, 'ii_para_end =', ii_para_end + PRINT *, 'ij_para_nb =', ij_para_nb + PRINT *, 'ij_para_begin =', ij_para_begin + PRINT *, 'ij_para_end =', ij_para_end + PRINT *, 'klon_mpi_para_nb =', klon_mpi_para_nb + PRINT *, 'klon_mpi_para_begin =', klon_mpi_para_begin + PRINT *, 'klon_mpi_para_end =', klon_mpi_para_end + PRINT *, 'mpi_rank =', mpi_rank + PRINT *, 'mpi_size =', mpi_size + PRINT *, 'mpi_root =', mpi_root + PRINT *, 'is_mpi_root =', is_mpi_root + PRINT *, 'is_north_pole =', is_north_pole + PRINT *, 'is_south_pole =', is_south_pole + PRINT *, 'COMM_LMDZ_PHY =', COMM_LMDZ_PHY + + END SUBROUTINE print_module_data + +END MODULE mod_phys_lmdz_mpi_data Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_mpi_transfert.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_mpi_transfert.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_mpi_transfert.F90 (revision 1280) @@ -0,0 +1,1902 @@ +! +!$Header$ +! +MODULE mod_phys_lmdz_mpi_transfert + + + INTERFACE bcast_mpi + MODULE PROCEDURE bcast_mpi_c, & + bcast_mpi_i,bcast_mpi_i1,bcast_mpi_i2,bcast_mpi_i3,bcast_mpi_i4, & + bcast_mpi_r,bcast_mpi_r1,bcast_mpi_r2,bcast_mpi_r3,bcast_mpi_r4, & + bcast_mpi_l,bcast_mpi_l1,bcast_mpi_l2,bcast_mpi_l3,bcast_mpi_l4 + END INTERFACE + + INTERFACE scatter_mpi + MODULE PROCEDURE scatter_mpi_i,scatter_mpi_i1,scatter_mpi_i2,scatter_mpi_i3, & + scatter_mpi_r,scatter_mpi_r1,scatter_mpi_r2,scatter_mpi_r3, & + scatter_mpi_l,scatter_mpi_l1,scatter_mpi_l2,scatter_mpi_l3 + END INTERFACE + + + INTERFACE gather_mpi + MODULE PROCEDURE gather_mpi_i,gather_mpi_i1,gather_mpi_i2,gather_mpi_i3, & + gather_mpi_r,gather_mpi_r1,gather_mpi_r2,gather_mpi_r3, & + gather_mpi_l,gather_mpi_l1,gather_mpi_l2,gather_mpi_l3 + END INTERFACE + + INTERFACE scatter2D_mpi + MODULE PROCEDURE scatter2D_mpi_i,scatter2D_mpi_i1,scatter2D_mpi_i2,scatter2D_mpi_i3, & + scatter2D_mpi_r,scatter2D_mpi_r1,scatter2D_mpi_r2,scatter2D_mpi_r3, & + scatter2D_mpi_l,scatter2D_mpi_l1,scatter2D_mpi_l2,scatter2D_mpi_l3 + END INTERFACE + + INTERFACE gather2D_mpi + MODULE PROCEDURE gather2D_mpi_i,gather2D_mpi_i1,gather2D_mpi_i2,gather2D_mpi_i3, & + gather2D_mpi_r,gather2D_mpi_r1,gather2D_mpi_r2,gather2D_mpi_r3, & + gather2D_mpi_l,gather2D_mpi_l1,gather2D_mpi_l2,gather2D_mpi_l3 + END INTERFACE + + INTERFACE reduce_sum_mpi + MODULE PROCEDURE reduce_sum_mpi_i,reduce_sum_mpi_i1,reduce_sum_mpi_i2,reduce_sum_mpi_i3,reduce_sum_mpi_i4, & + reduce_sum_mpi_r,reduce_sum_mpi_r1,reduce_sum_mpi_r2,reduce_sum_mpi_r3,reduce_sum_mpi_r4 + END INTERFACE + + INTERFACE grid1dTo2d_mpi + MODULE PROCEDURE grid1dTo2d_mpi_i,grid1dTo2d_mpi_i1,grid1dTo2d_mpi_i2,grid1dTo2d_mpi_i3, & + grid1dTo2d_mpi_r,grid1dTo2d_mpi_r1,grid1dTo2d_mpi_r2,grid1dTo2d_mpi_r3, & + grid1dTo2d_mpi_l,grid1dTo2d_mpi_l1,grid1dTo2d_mpi_l2,grid1dTo2d_mpi_l3 + END INTERFACE + + INTERFACE grid2dTo1d_mpi + MODULE PROCEDURE grid2dTo1d_mpi_i,grid2dTo1d_mpi_i1,grid2dTo1d_mpi_i2,grid2dTo1d_mpi_i3, & + grid2dTo1d_mpi_r,grid2dTo1d_mpi_r1,grid2dTo1d_mpi_r2,grid2dTo1d_mpi_r3, & + grid2dTo1d_mpi_l,grid2dTo1d_mpi_l1,grid2dTo1d_mpi_l2,grid2dTo1d_mpi_l3 + END INTERFACE + +CONTAINS + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Broadcast --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!! -- Les chaine de charactère -- !! + + SUBROUTINE bcast_mpi_c(var1) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(INOUT) :: Var1 + + CALL bcast_mpi_cgen(Var1,len(Var1)) + + END SUBROUTINE bcast_mpi_c + +!! -- Les entiers -- !! + + SUBROUTINE bcast_mpi_i(var) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var + + INTEGER :: var_tmp(1) + + IF (is_mpi_root) var_tmp(1)=var + CALL bcast_mpi_igen(Var_tmp,1) + var=var_tmp(1) + + END SUBROUTINE bcast_mpi_i + + SUBROUTINE bcast_mpi_i1(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:) + + CALL bcast_mpi_igen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_i1 + + SUBROUTINE bcast_mpi_i2(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:) + + CALL bcast_mpi_igen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_i2 + + SUBROUTINE bcast_mpi_i3(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:,:) + + CALL bcast_mpi_igen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_i3 + + SUBROUTINE bcast_mpi_i4(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:,:,:) + + CALL bcast_mpi_igen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_i4 + + +!! -- Les reels -- !! + + SUBROUTINE bcast_mpi_r(var) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var + REAL :: var_tmp(1) + + IF (is_mpi_root) var_tmp(1)=var + CALL bcast_mpi_rgen(Var_tmp,1) + var=var_tmp(1) + + END SUBROUTINE bcast_mpi_r + + SUBROUTINE bcast_mpi_r1(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:) + + CALL bcast_mpi_rgen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_r1 + + SUBROUTINE bcast_mpi_r2(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:) + + CALL bcast_mpi_rgen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_r2 + + SUBROUTINE bcast_mpi_r3(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:,:) + + CALL bcast_mpi_rgen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_r3 + + SUBROUTINE bcast_mpi_r4(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:,:,:) + + CALL bcast_mpi_rgen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_r4 + +!! -- Les booleans -- !! + + SUBROUTINE bcast_mpi_l(var) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var + LOGICAL :: var_tmp(1) + + IF (is_mpi_root) var_tmp(1)=var + CALL bcast_mpi_lgen(Var_tmp,1) + var=var_tmp(1) + + END SUBROUTINE bcast_mpi_l + + SUBROUTINE bcast_mpi_l1(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:) + + CALL bcast_mpi_lgen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_l1 + + SUBROUTINE bcast_mpi_l2(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:) + + CALL bcast_mpi_lgen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_l2 + + SUBROUTINE bcast_mpi_l3(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:,:) + + CALL bcast_mpi_lgen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_l3 + + SUBROUTINE bcast_mpi_l4(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:,:,:) + + CALL bcast_mpi_lgen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_l4 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Scatter --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE scatter_mpi_i(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL scatter_mpi_igen(VarIn,Varout,1) + + END SUBROUTINE scatter_mpi_i + + SUBROUTINE scatter_mpi_i1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)) + + END SUBROUTINE scatter_mpi_i1 + + SUBROUTINE scatter_mpi_i2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)) + + END SUBROUTINE scatter_mpi_i2 + + SUBROUTINE scatter_mpi_i3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4)) + + END SUBROUTINE scatter_mpi_i3 + + + SUBROUTINE scatter_mpi_r(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL scatter_mpi_rgen(VarIn,Varout,1) + + END SUBROUTINE scatter_mpi_r + + SUBROUTINE scatter_mpi_r1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)) + + END SUBROUTINE scatter_mpi_r1 + + SUBROUTINE scatter_mpi_r2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)) + + END SUBROUTINE scatter_mpi_r2 + + SUBROUTINE scatter_mpi_r3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4)) + + END SUBROUTINE scatter_mpi_r3 + + + SUBROUTINE scatter_mpi_l(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL scatter_mpi_lgen(VarIn,Varout,1) + + END SUBROUTINE scatter_mpi_l + + SUBROUTINE scatter_mpi_l1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)) + + END SUBROUTINE scatter_mpi_l1 + + SUBROUTINE scatter_mpi_l2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)) + + END SUBROUTINE scatter_mpi_l2 + + SUBROUTINE scatter_mpi_l3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4)) + + END SUBROUTINE scatter_mpi_l3 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Gather --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!!!!! --> Les entiers + + SUBROUTINE gather_mpi_i(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL gather_mpi_igen(VarIn,VarOut,1) + + END SUBROUTINE gather_mpi_i + + +!!!!! + + SUBROUTINE gather_mpi_i1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)) + + END SUBROUTINE gather_mpi_i1 + +!!!!! + + SUBROUTINE gather_mpi_i2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)) + + END SUBROUTINE gather_mpi_i2 + +!!!!! + + SUBROUTINE gather_mpi_i3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4)) + + END SUBROUTINE gather_mpi_i3 + +!!!!! --> Les reels + + SUBROUTINE gather_mpi_r(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL gather_mpi_rgen(VarIn,VarOut,1) + + END SUBROUTINE gather_mpi_r + +!!!!! + + SUBROUTINE gather_mpi_r1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)) + + END SUBROUTINE gather_mpi_r1 + +!!!!! + + SUBROUTINE gather_mpi_r2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)) + + END SUBROUTINE gather_mpi_r2 + +!!!!! + + SUBROUTINE gather_mpi_r3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4)) + + END SUBROUTINE gather_mpi_r3 + +!!!!! --> Les booleen + + SUBROUTINE gather_mpi_l(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL gather_mpi_lgen(VarIn,VarOut,1) + + END SUBROUTINE gather_mpi_l + +!!!!! + + SUBROUTINE gather_mpi_l1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)) + + END SUBROUTINE gather_mpi_l1 + +!!!!! + + SUBROUTINE gather_mpi_l2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)) + + END SUBROUTINE gather_mpi_l2 + +!!!!! + + SUBROUTINE gather_mpi_l3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4)) + + END SUBROUTINE gather_mpi_l3 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Scatter2D --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE scatter2D_mpi_i(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + INTEGER,DIMENSION(klon_glo) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_i + + SUBROUTINE scatter2D_mpi_i1(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + INTEGER,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_i1 + + SUBROUTINE scatter2D_mpi_i2(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_i2 + + SUBROUTINE scatter2D_mpi_i3(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + INTEGER,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_i3 + + + + SUBROUTINE scatter2D_mpi_r(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + REAL,DIMENSION(klon_glo) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_R + + + SUBROUTINE scatter2D_mpi_r1(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + REAL,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_r1 + + + SUBROUTINE scatter2D_mpi_r2(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + REAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_r2 + + SUBROUTINE scatter2D_mpi_r3(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + REAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_r3 + + + SUBROUTINE scatter2D_mpi_l(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + LOGICAL,DIMENSION(klon_glo) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_l + + + SUBROUTINE scatter2D_mpi_l1(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + LOGICAL,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_l1 + + + SUBROUTINE scatter2D_mpi_l2(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + LOGICAL, DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_l2 + + SUBROUTINE scatter2D_mpi_l3(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_l3 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Gather2D --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE gather2D_mpi_i(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + INTEGER,DIMENSION(klon_glo) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_i + + SUBROUTINE gather2D_mpi_i1(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_i1 + + SUBROUTINE gather2D_mpi_i2(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_i2 + + SUBROUTINE gather2D_mpi_i3(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_i3 + + + + SUBROUTINE gather2D_mpi_r(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + REAL,DIMENSION(klon_glo) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_r + + SUBROUTINE gather2D_mpi_r1(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + REAL,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_r1 + + SUBROUTINE gather2D_mpi_r2(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + REAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_r2 + + SUBROUTINE gather2D_mpi_r3(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + REAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_r3 + + + + SUBROUTINE gather2D_mpi_l(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + LOGICAL,DIMENSION(klon_glo) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_l + + SUBROUTINE gather2D_mpi_l1(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_l1 + + SUBROUTINE gather2D_mpi_l2(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_l2 + + SUBROUTINE gather2D_mpi_l3(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_l3 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des reduce_sum --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE reduce_sum_mpi_i(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN) :: VarIn + INTEGER,INTENT(OUT) :: VarOut + INTEGER :: VarIn_tmp(1) + INTEGER :: VarOut_tmp(1) + + VarIn_tmp(1)=VarIn + CALL reduce_sum_mpi_igen(VarIn_tmp,Varout_tmp,1) + VarOut=VarOut_tmp(1) + + END SUBROUTINE reduce_sum_mpi_i + + SUBROUTINE reduce_sum_mpi_i1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn)) + + END SUBROUTINE reduce_sum_mpi_i1 + + SUBROUTINE reduce_sum_mpi_i2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn)) + + END SUBROUTINE reduce_sum_mpi_i2 + + SUBROUTINE reduce_sum_mpi_i3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn)) + + END SUBROUTINE reduce_sum_mpi_i3 + + SUBROUTINE reduce_sum_mpi_i4(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn)) + + END SUBROUTINE reduce_sum_mpi_i4 + + + SUBROUTINE reduce_sum_mpi_r(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN) :: VarIn + REAL,INTENT(OUT) :: VarOut + REAL :: VarIn_tmp(1) + REAL :: VarOut_tmp(1) + + VarIn_tmp(1)=VarIn + CALL reduce_sum_mpi_rgen(VarIn_tmp,Varout_tmp,1) + VarOut=VarOut_tmp(1) + + END SUBROUTINE reduce_sum_mpi_r + + SUBROUTINE reduce_sum_mpi_r1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn)) + + END SUBROUTINE reduce_sum_mpi_r1 + + SUBROUTINE reduce_sum_mpi_r2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn)) + + END SUBROUTINE reduce_sum_mpi_r2 + + SUBROUTINE reduce_sum_mpi_r3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn)) + + END SUBROUTINE reduce_sum_mpi_r3 + + SUBROUTINE reduce_sum_mpi_r4(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn)) + + END SUBROUTINE reduce_sum_mpi_r4 + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! SUBROUTINE grid1dTo2d !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + SUBROUTINE grid1dTo2d_mpi_i(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid1dTo2d_mpi_igen(VarIn,VarOut,1) + + END SUBROUTINE grid1dTo2d_mpi_i + + + SUBROUTINE grid1dTo2d_mpi_i1(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2)) + + END SUBROUTINE grid1dTo2d_mpi_i1 + + SUBROUTINE grid1dTo2d_mpi_i2(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)) + + END SUBROUTINE grid1dTo2d_mpi_i2 + + SUBROUTINE grid1dTo2d_mpi_i3(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid1dTo2d_mpi_i3 + + + SUBROUTINE grid1dTo2d_mpi_r(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,1) + + END SUBROUTINE grid1dTo2d_mpi_r + + + SUBROUTINE grid1dTo2d_mpi_r1(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2)) + + END SUBROUTINE grid1dTo2d_mpi_r1 + + SUBROUTINE grid1dTo2d_mpi_r2(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)) + + END SUBROUTINE grid1dTo2d_mpi_r2 + + SUBROUTINE grid1dTo2d_mpi_r3(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid1dTo2d_mpi_r3 + + + + SUBROUTINE grid1dTo2d_mpi_l(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,1) + + END SUBROUTINE grid1dTo2d_mpi_l + + + SUBROUTINE grid1dTo2d_mpi_l1(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2)) + + END SUBROUTINE grid1dTo2d_mpi_l1 + + SUBROUTINE grid1dTo2d_mpi_l2(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)) + + END SUBROUTINE grid1dTo2d_mpi_l2 + + SUBROUTINE grid1dTo2d_mpi_l3(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid1dTo2d_mpi_l3 + + + SUBROUTINE grid2dTo1d_mpi_i(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL grid2dTo1d_mpi_igen(VarIn,VarOut,1) + + END SUBROUTINE grid2dTo1d_mpi_i + + + SUBROUTINE grid2dTo1d_mpi_i1(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3)) + + END SUBROUTINE grid2dTo1d_mpi_i1 + + SUBROUTINE grid2dTo1d_mpi_i2(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid2dTo1d_mpi_i2 + + SUBROUTINE grid2dTo1d_mpi_i3(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5)) + + END SUBROUTINE grid2dTo1d_mpi_i3 + + + + + SUBROUTINE grid2dTo1d_mpi_r(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,1) + + END SUBROUTINE grid2dTo1d_mpi_r + + + SUBROUTINE grid2dTo1d_mpi_r1(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3)) + + END SUBROUTINE grid2dTo1d_mpi_r1 + + SUBROUTINE grid2dTo1d_mpi_r2(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid2dTo1d_mpi_r2 + + SUBROUTINE grid2dTo1d_mpi_r3(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5)) + + END SUBROUTINE grid2dTo1d_mpi_r3 + + + + SUBROUTINE grid2dTo1d_mpi_l(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,1) + + END SUBROUTINE grid2dTo1d_mpi_l + + + SUBROUTINE grid2dTo1d_mpi_l1(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3)) + + END SUBROUTINE grid2dTo1d_mpi_l1 + + + + SUBROUTINE grid2dTo1d_mpi_l2(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid2dTo1d_mpi_l2 + + + SUBROUTINE grid2dTo1d_mpi_l3(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5)) + + END SUBROUTINE grid2dTo1d_mpi_l3 + + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! DEFINITION DES FONCTIONS DE TRANSFERT GENERIQUES ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE bcast_mpi_cgen(var,nb) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + IMPLICIT NONE + + CHARACTER(LEN=*),INTENT(INOUT) :: Var + INTEGER,INTENT(IN) :: nb + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: ierr + + IF (.not.is_using_mpi) RETURN + +#ifdef CPP_MPI + CALL MPI_BCAST(Var,nb,MPI_CHARACTER,mpi_root_x,COMM_LMDZ_PHY,ierr) +#endif + + END SUBROUTINE bcast_mpi_cgen + + + + SUBROUTINE bcast_mpi_igen(var,nb) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + IMPLICIT NONE + + INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var + INTEGER,INTENT(IN) :: nb + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: ierr + + IF (.not.is_using_mpi) RETURN + +#ifdef CPP_MPI + CALL MPI_BCAST(Var,nb,MPI_INTEGER,mpi_root_x,COMM_LMDZ_PHY,ierr) +#endif + + END SUBROUTINE bcast_mpi_igen + + + + + SUBROUTINE bcast_mpi_rgen(var,nb) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + IMPLICIT NONE + + REAL,DIMENSION(nb),INTENT(INOUT) :: Var + INTEGER,INTENT(IN) :: nb + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: ierr + + IF (.not.is_using_mpi) RETURN + +#ifdef CPP_MPI + CALL MPI_BCAST(Var,nb,MPI_REAL_LMDZ,mpi_root_x,COMM_LMDZ_PHY,ierr) +#endif + + END SUBROUTINE bcast_mpi_rgen + + + + + SUBROUTINE bcast_mpi_lgen(var,nb) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + IMPLICIT NONE + + LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var + INTEGER,INTENT(IN) :: nb + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: ierr + + IF (.not.is_using_mpi) RETURN + +#ifdef CPP_MPI + CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_root_x,COMM_LMDZ_PHY,ierr) +#endif + + END SUBROUTINE bcast_mpi_lgen + + + + SUBROUTINE scatter_mpi_igen(VarIn, VarOut, dimsize) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER,DIMENSION(0:mpi_size-1) :: displs + INTEGER,DIMENSION(0:mpi_size-1) :: counts + INTEGER,DIMENSION(dimsize*klon_glo) :: VarTmp + INTEGER :: nb,i,index,rank + INTEGER :: ierr + + + IF (.not.is_using_mpi) THEN + VarOut(:,:)=VarIn(:,:) + RETURN + ENDIF + + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + displs(rank)=Index-1 + counts(rank)=nb*dimsize + DO i=1,dimsize + VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i) + Index=Index+nb + ENDDO + ENDDO + ENDIF + +#ifdef CPP_MPI + CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_INTEGER,VarOut,klon_mpi*dimsize, & + MPI_INTEGER,mpi_root_x, COMM_LMDZ_PHY,ierr) +#endif + + END SUBROUTINE scatter_mpi_igen + + SUBROUTINE scatter_mpi_rgen(VarIn, VarOut, dimsize) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + INTEGER,DIMENSION(0:mpi_size-1) :: displs + INTEGER,DIMENSION(0:mpi_size-1) :: counts + REAL,DIMENSION(dimsize*klon_glo) :: VarTmp + INTEGER :: nb,i,index,rank + INTEGER :: ierr + + IF (.not.is_using_mpi) THEN + VarOut(:,:)=VarIn(:,:) + RETURN + ENDIF + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + displs(rank)=Index-1 + counts(rank)=nb*dimsize + DO i=1,dimsize + VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i) + Index=Index+nb + ENDDO + ENDDO + ENDIF + +#ifdef CPP_MPI + CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_REAL_LMDZ,VarOut,klon_mpi*dimsize, & + MPI_REAL_LMDZ,mpi_root_x, COMM_LMDZ_PHY,ierr) + +#endif + + END SUBROUTINE scatter_mpi_rgen + + + SUBROUTINE scatter_mpi_lgen(VarIn, VarOut, dimsize) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + LOGICAL,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + INTEGER,DIMENSION(0:mpi_size-1) :: displs + INTEGER,DIMENSION(0:mpi_size-1) :: counts + LOGICAL,DIMENSION(dimsize*klon_glo) :: VarTmp + INTEGER :: nb,i,index,rank + INTEGER :: ierr + + IF (.not.is_using_mpi) THEN + VarOut(:,:)=VarIn(:,:) + RETURN + ENDIF + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + displs(rank)=Index-1 + counts(rank)=nb*dimsize + DO i=1,dimsize + VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i) + Index=Index+nb + ENDDO + ENDDO + ENDIF + +#ifdef CPP_MPI + CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_LOGICAL,VarOut,klon_mpi*dimsize, & + MPI_LOGICAL,mpi_root_x, COMM_LMDZ_PHY,ierr) +#endif + + END SUBROUTINE scatter_mpi_lgen + + + + + SUBROUTINE gather_mpi_igen(VarIn, VarOut, dimsize) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + USE mod_grid_phy_lmdz + IMPLICIT NONE + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut + + INTEGER,DIMENSION(0:mpi_size-1) :: displs + INTEGER,DIMENSION(0:mpi_size-1) :: counts + INTEGER,DIMENSION(dimsize*klon_glo) :: VarTmp + INTEGER :: nb,i,index,rank + INTEGER :: ierr + + IF (.not.is_using_mpi) THEN + VarOut(:,:)=VarIn(:,:) + RETURN + ENDIF + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + displs(rank)=Index-1 + counts(rank)=nb*dimsize + Index=Index+nb*dimsize + ENDDO + + ENDIF + +#ifdef CPP_MPI + CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_INTEGER,VarTmp,counts,displs, & + MPI_INTEGER,mpi_root_x, COMM_LMDZ_PHY,ierr) +#endif + + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + DO i=1,dimsize + VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1) + Index=Index+nb + ENDDO + ENDDO + ENDIF + + END SUBROUTINE gather_mpi_igen + + SUBROUTINE gather_mpi_rgen(VarIn, VarOut, dimsize) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + USE mod_grid_phy_lmdz + IMPLICIT NONE + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut + + INTEGER,DIMENSION(0:mpi_size-1) :: displs + INTEGER,DIMENSION(0:mpi_size-1) :: counts + REAL,DIMENSION(dimsize*klon_glo) :: VarTmp + INTEGER :: nb,i,index,rank + INTEGER :: ierr + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + displs(rank)=Index-1 + counts(rank)=nb*dimsize + Index=Index+nb*dimsize + ENDDO + ENDIF + + IF (.not.is_using_mpi) THEN + VarOut(:,:)=VarIn(:,:) + RETURN + ENDIF + +#ifdef CPP_MPI + CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_REAL_LMDZ,VarTmp,counts,displs, & + MPI_REAL_LMDZ,mpi_root_x, COMM_LMDZ_PHY,ierr) +#endif + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + DO i=1,dimsize + VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1) + Index=Index+nb + ENDDO + ENDDO + ENDIF + + END SUBROUTINE gather_mpi_rgen + + SUBROUTINE gather_mpi_lgen(VarIn, VarOut, dimsize) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + LOGICAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + INTEGER,DIMENSION(0:mpi_size-1) :: displs + INTEGER,DIMENSION(0:mpi_size-1) :: counts + LOGICAL,DIMENSION(dimsize*klon_glo) :: VarTmp + INTEGER :: nb,i,index,rank + INTEGER :: ierr + + IF (.not.is_using_mpi) THEN + VarOut(:,:)=VarIn(:,:) + RETURN + ENDIF + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + displs(rank)=Index-1 + counts(rank)=nb*dimsize + Index=Index+nb*dimsize + ENDDO + ENDIF + + +#ifdef CPP_MPI + CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_LOGICAL,VarTmp,counts,displs, & + MPI_LOGICAL,mpi_root_x, COMM_LMDZ_PHY,ierr) +#endif + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + DO i=1,dimsize + VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1) + Index=Index+nb + ENDDO + ENDDO + ENDIF + + END SUBROUTINE gather_mpi_lgen + + + + SUBROUTINE reduce_sum_mpi_igen(VarIn,VarOut,nb) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + USE mod_grid_phy_lmdz + IMPLICIT NONE + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + INTEGER,DIMENSION(nb),INTENT(IN) :: VarIn + INTEGER,DIMENSION(nb),INTENT(OUT) :: VarOut + INTEGER,INTENT(IN) :: nb + INTEGER :: ierr + + IF (.not.is_using_mpi) THEN + VarOut(:)=VarIn(:) + RETURN + ENDIF + + +#ifdef CPP_MPI + CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_INTEGER,MPI_SUM,mpi_root_x,COMM_LMDZ_PHY,ierr) +#endif + + END SUBROUTINE reduce_sum_mpi_igen + + SUBROUTINE reduce_sum_mpi_rgen(VarIn,VarOut,nb) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + USE mod_grid_phy_lmdz + + IMPLICIT NONE + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + REAL,DIMENSION(nb),INTENT(IN) :: VarIn + REAL,DIMENSION(nb),INTENT(OUT) :: VarOut + INTEGER,INTENT(IN) :: nb + INTEGER :: ierr + + IF (.not.is_using_mpi) THEN + VarOut(:)=VarIn(:) + RETURN + ENDIF + +#ifdef CPP_MPI + CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_REAL_LMDZ,MPI_SUM,mpi_root_x,COMM_LMDZ_PHY,ierr) +#endif + + END SUBROUTINE reduce_sum_mpi_rgen + + + + SUBROUTINE grid1dTo2d_mpi_igen(VarIn,VarOut,dimsize) + USE mod_phys_lmdz_mpi_data + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN) ,DIMENSION(klon_mpi,dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize) :: VarOut + INTEGER :: i,ij,Offset + + + VarOut(1:nbp_lon,:)=0 + VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=0 + + offset=ii_begin + IF (is_north_pole) Offset=nbp_lon + + + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij+offset-1,i)=VarIn(ij,i) + ENDDO + ENDDO + + + IF (is_north_pole) THEN + DO i=1,dimsize + DO ij=1,nbp_lon + VarOut(ij,i)=VarIn(1,i) + ENDDO + ENDDO + ENDIF + + IF (is_south_pole) THEN + DO i=1,dimsize + DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb + VarOut(ij,i)=VarIn(klon_mpi,i) + ENDDO + ENDDO + ENDIF + + END SUBROUTINE grid1dTo2d_mpi_igen + + + SUBROUTINE grid1dTo2d_mpi_rgen(VarIn,VarOut,dimsize) + USE mod_phys_lmdz_mpi_data + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN) ,DIMENSION(klon_mpi,dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize) :: VarOut + INTEGER :: i,ij,Offset + + + VarOut(1:nbp_lon,:)=0 + VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=0 + + offset=ii_begin + IF (is_north_pole) Offset=nbp_lon + + + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij+offset-1,i)=VarIn(ij,i) + ENDDO + ENDDO + + + IF (is_north_pole) THEN + DO i=1,dimsize + DO ij=1,nbp_lon + VarOut(ij,i)=VarIn(1,i) + ENDDO + ENDDO + ENDIF + + IF (is_south_pole) THEN + DO i=1,dimsize + DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb + VarOut(ij,i)=VarIn(klon_mpi,i) + ENDDO + ENDDO + ENDIF + + END SUBROUTINE grid1dTo2d_mpi_rgen + + + + SUBROUTINE grid1dTo2d_mpi_lgen(VarIn,VarOut,dimsize) + USE mod_phys_lmdz_mpi_data + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + LOGICAL,INTENT(IN) ,DIMENSION(klon_mpi,dimsize) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize) :: VarOut + INTEGER :: i,ij,Offset + + + VarOut(1:nbp_lon,:)=.FALSE. + VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=.FALSE. + + offset=ii_begin + IF (is_north_pole) Offset=nbp_lon + + + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij+offset-1,i)=VarIn(ij,i) + ENDDO + ENDDO + + + IF (is_north_pole) THEN + DO i=1,dimsize + DO ij=1,nbp_lon + VarOut(ij,i)=VarIn(1,i) + ENDDO + ENDDO + ENDIF + + IF (is_south_pole) THEN + DO i=1,dimsize + DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb + VarOut(ij,i)=VarIn(klon_mpi,i) + ENDDO + ENDDO + ENDIF + + END SUBROUTINE grid1dTo2d_mpi_lgen + + + + + SUBROUTINE grid2dTo1d_mpi_igen(VarIn,VarOut,dimsize) + USE mod_phys_lmdz_mpi_data + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + INTEGER :: i,ij,offset + + offset=ii_begin + IF (is_north_pole) offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij,i)=VarIn(ij+offset-1,i) + ENDDO + ENDDO + + IF (is_north_pole) THEN + DO i=1,dimsize + VarOut(1,i)=VarIn(1,i) + ENDDO + ENDIF + + + END SUBROUTINE grid2dTo1d_mpi_igen + + + + SUBROUTINE grid2dTo1d_mpi_rgen(VarIn,VarOut,dimsize) + USE mod_phys_lmdz_mpi_data + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + INTEGER :: i,ij,offset + + offset=ii_begin + IF (is_north_pole) offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij,i)=VarIn(ij+offset-1,i) + ENDDO + ENDDO + + IF (is_north_pole) THEN + DO i=1,dimsize + VarOut(1,i)=VarIn(1,i) + ENDDO + ENDIF + + + END SUBROUTINE grid2dTo1d_mpi_rgen + + + SUBROUTINE grid2dTo1d_mpi_lgen(VarIn,VarOut,dimsize) + USE mod_phys_lmdz_mpi_data + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + LOGICAL,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + INTEGER :: i,ij,offset + + offset=ii_begin + IF (is_north_pole) offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij,i)=VarIn(ij+offset-1,i) + ENDDO + ENDDO + + IF (is_north_pole) THEN + DO i=1,dimsize + VarOut(1,i)=VarIn(1,i) + ENDDO + ENDIF + + + END SUBROUTINE grid2dTo1d_mpi_lgen + +END MODULE mod_phys_lmdz_mpi_transfert Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_omp_data.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_omp_data.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_omp_data.F90 (revision 1280) @@ -0,0 +1,104 @@ +! +!$Header$ +! +MODULE mod_phys_lmdz_omp_data + + INTEGER,SAVE :: omp_size + INTEGER,SAVE :: omp_rank + LOGICAL,SAVE :: is_omp_root + LOGICAL,SAVE :: is_using_omp + + INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_nb + INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_begin + INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_end + + INTEGER,SAVE :: klon_omp + INTEGER,SAVE :: klon_omp_begin + INTEGER,SAVE :: klon_omp_end +!$OMP THREADPRIVATE(omp_rank,klon_omp,is_omp_root,klon_omp_begin,klon_omp_end) + +CONTAINS + + SUBROUTINE Init_phys_lmdz_omp_data(klon_mpi) + USE dimphy + IMPLICIT NONE + INTEGER, INTENT(in) :: klon_mpi + + INTEGER :: i + +#ifdef CPP_OMP + INTEGER :: OMP_GET_NUM_THREADS + EXTERNAL OMP_GET_NUM_THREADS + INTEGER :: OMP_GET_THREAD_NUM + EXTERNAL OMP_GET_THREAD_NUM +#endif + +#ifdef CPP_OMP +!$OMP MASTER + is_using_omp=.TRUE. + omp_size=OMP_GET_NUM_THREADS() +!$OMP END MASTER + omp_rank=OMP_GET_THREAD_NUM() +#else + is_using_omp=.FALSE. + omp_size=1 + omp_rank=0 +#endif + + is_omp_root=.FALSE. +!$OMP MASTER + IF (omp_rank==0) THEN + is_omp_root=.TRUE. + ELSE + PRINT *,'ANORMAL : OMP_MASTER /= 0' + STOP + ENDIF +!$OMP END MASTER + + +!$OMP MASTER + ALLOCATE(klon_omp_para_nb(0:omp_size-1)) + ALLOCATE(klon_omp_para_begin(0:omp_size-1)) + ALLOCATE(klon_omp_para_end(0:omp_size-1)) + + DO i=0,omp_size-1 + klon_omp_para_nb(i)=klon_mpi/omp_size + IF (i TASK ',omp_rank + PRINT *,'omp_size =',omp_size + PRINT *,'omp_rank =',omp_rank + PRINT *,'is_omp_root =',is_omp_root + PRINT *,'klon_omp_para_nb =',klon_omp_para_nb + PRINT *,'klon_omp_para_begin =',klon_omp_para_begin + PRINT *,'klon_omp_para_end =',klon_omp_para_end + PRINT *,'klon_omp =',klon_omp + PRINT *,'klon_omp_begin =',klon_omp_begin + PRINT *,'klon_omp_end =',klon_omp_end +!$OMP END CRITICAL + + END SUBROUTINE Print_module_data +END MODULE mod_phys_lmdz_omp_data Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_omp_transfert.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_omp_transfert.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_omp_transfert.F90 (revision 1280) @@ -0,0 +1,1057 @@ +! +!$Header$ +! +MODULE mod_phys_lmdz_omp_transfert + + PRIVATE + + INTEGER,PARAMETER :: grow_factor=1.5 + INTEGER,PARAMETER :: size_min=1024 + + CHARACTER(LEN=size_min),SAVE :: buffer_c +! INTEGER,SAVE :: size_c=0 + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: buffer_i + INTEGER,SAVE :: size_i=0 + REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: buffer_r + INTEGER,SAVE :: size_r=0 + LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:) :: buffer_l + INTEGER,SAVE :: size_l=0 + + + + + INTERFACE bcast_omp + MODULE PROCEDURE bcast_omp_c, & + bcast_omp_i,bcast_omp_i1,bcast_omp_i2,bcast_omp_i3,bcast_omp_i4, & + bcast_omp_r,bcast_omp_r1,bcast_omp_r2,bcast_omp_r3,bcast_omp_r4, & + bcast_omp_l,bcast_omp_l1,bcast_omp_l2,bcast_omp_l3,bcast_omp_l4 + END INTERFACE + + INTERFACE scatter_omp + MODULE PROCEDURE scatter_omp_i,scatter_omp_i1,scatter_omp_i2,scatter_omp_i3, & + scatter_omp_r,scatter_omp_r1,scatter_omp_r2,scatter_omp_r3, & + scatter_omp_l,scatter_omp_l1,scatter_omp_l2,scatter_omp_l3 + END INTERFACE + + + INTERFACE gather_omp + MODULE PROCEDURE gather_omp_i,gather_omp_i1,gather_omp_i2,gather_omp_i3, & + gather_omp_r,gather_omp_r1,gather_omp_r2,gather_omp_r3, & + gather_omp_l,gather_omp_l1,gather_omp_l2,gather_omp_l3 + END INTERFACE + + + INTERFACE reduce_sum_omp + MODULE PROCEDURE reduce_sum_omp_i,reduce_sum_omp_i1,reduce_sum_omp_i2,reduce_sum_omp_i3,reduce_sum_omp_i4, & + reduce_sum_omp_r,reduce_sum_omp_r1,reduce_sum_omp_r2,reduce_sum_omp_r3,reduce_sum_omp_r4 + END INTERFACE + + + PUBLIC bcast_omp,scatter_omp,gather_omp,reduce_sum_omp + +CONTAINS + + SUBROUTINE check_buffer_i(buff_size) + IMPLICIT NONE + INTEGER :: buff_size + +!$OMP BARRIER +!$OMP MASTER + IF (buff_size>size_i) THEN + IF (ALLOCATED(buffer_i)) DEALLOCATE(buffer_i) + size_i=MAX(size_min,INT(grow_factor*buff_size)) + ALLOCATE(buffer_i(size_i)) + ENDIF +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE check_buffer_i + + SUBROUTINE check_buffer_r(buff_size) + IMPLICIT NONE + INTEGER :: buff_size + +!$OMP BARRIER +!$OMP MASTER + IF (buff_size>size_r) THEN + IF (ALLOCATED(buffer_r)) DEALLOCATE(buffer_r) + size_r=MAX(size_min,INT(grow_factor*buff_size)) + ALLOCATE(buffer_r(size_r)) + ENDIF +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE check_buffer_r + + SUBROUTINE check_buffer_l(buff_size) + IMPLICIT NONE + INTEGER :: buff_size + +!$OMP BARRIER +!$OMP MASTER + IF (buff_size>size_l) THEN + IF (ALLOCATED(buffer_l)) DEALLOCATE(buffer_l) + size_l=MAX(size_min,INT(grow_factor*buff_size)) + ALLOCATE(buffer_l(size_l)) + ENDIF +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE check_buffer_l + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Broadcast --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!! -- Les chaine de charactère -- !! + + SUBROUTINE bcast_omp_c(var) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(INOUT) :: Var + + CALL bcast_omp_cgen(Var,len(Var),buffer_c) + + END SUBROUTINE bcast_omp_c + +!! -- Les entiers -- !! + + SUBROUTINE bcast_omp_i(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var + INTEGER :: Var_tmp(1) + + Var_tmp(1)=Var + CALL check_buffer_i(1) + CALL bcast_omp_igen(Var_tmp,1,buffer_i) + Var=Var_tmp(1) + + END SUBROUTINE bcast_omp_i + + + SUBROUTINE bcast_omp_i1(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:) + + CALL check_buffer_i(size(Var)) + CALL bcast_omp_igen(Var,size(Var),buffer_i) + + END SUBROUTINE bcast_omp_i1 + + + SUBROUTINE bcast_omp_i2(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:) + + CALL check_buffer_i(size(Var)) + CALL bcast_omp_igen(Var,size(Var),buffer_i) + + END SUBROUTINE bcast_omp_i2 + + + SUBROUTINE bcast_omp_i3(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:,:) + + CALL check_buffer_i(size(Var)) + CALL bcast_omp_igen(Var,size(Var),buffer_i) + + END SUBROUTINE bcast_omp_i3 + + + SUBROUTINE bcast_omp_i4(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:,:,:) + + CALL check_buffer_i(size(Var)) + CALL bcast_omp_igen(Var,size(Var),buffer_i) + + END SUBROUTINE bcast_omp_i4 + + +!! -- Les reels -- !! + + SUBROUTINE bcast_omp_r(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var + REAL :: Var_tmp(1) + + Var_tmp(1)=Var + CALL check_buffer_r(1) + CALL bcast_omp_rgen(Var_tmp,1,buffer_r) + Var=Var_tmp(1) + + END SUBROUTINE bcast_omp_r + + + SUBROUTINE bcast_omp_r1(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:) + + CALL check_buffer_r(size(Var)) + CALL bcast_omp_rgen(Var,size(Var),buffer_r) + + END SUBROUTINE bcast_omp_r1 + + + SUBROUTINE bcast_omp_r2(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:) + + CALL check_buffer_r(size(Var)) + CALL bcast_omp_rgen(Var,size(Var),buffer_r) + + END SUBROUTINE bcast_omp_r2 + + + SUBROUTINE bcast_omp_r3(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:,:) + + CALL check_buffer_r(size(Var)) + CALL bcast_omp_rgen(Var,size(Var),buffer_r) + + END SUBROUTINE bcast_omp_r3 + + + SUBROUTINE bcast_omp_r4(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:,:,:) + + CALL check_buffer_r(size(Var)) + CALL bcast_omp_rgen(Var,size(Var),buffer_r) + + END SUBROUTINE bcast_omp_r4 + + +!! -- Les booleans -- !! + + SUBROUTINE bcast_omp_l(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var + LOGICAL :: Var_tmp(1) + + Var_tmp(1)=Var + CALL check_buffer_l(1) + CALL bcast_omp_lgen(Var_tmp,1,buffer_l) + Var=Var_tmp(1) + + END SUBROUTINE bcast_omp_l + + + SUBROUTINE bcast_omp_l1(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:) + + CALL check_buffer_l(size(Var)) + CALL bcast_omp_lgen(Var,size(Var),buffer_l) + + END SUBROUTINE bcast_omp_l1 + + + SUBROUTINE bcast_omp_l2(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:) + + CALL check_buffer_l(size(Var)) + CALL bcast_omp_lgen(Var,size(Var),buffer_l) + + END SUBROUTINE bcast_omp_l2 + + + SUBROUTINE bcast_omp_l3(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:,:) + + CALL check_buffer_l(size(Var)) + CALL bcast_omp_lgen(Var,size(Var),buffer_l) + + END SUBROUTINE bcast_omp_l3 + + + SUBROUTINE bcast_omp_l4(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:,:,:) + + CALL check_buffer_l(size(Var)) + CALL bcast_omp_lgen(Var,size(Var),buffer_l) + + END SUBROUTINE bcast_omp_l4 + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Scatter --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE scatter_omp_i(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL Check_buffer_i(size(VarIn)) + CALL scatter_omp_igen(VarIn,Varout,1,buffer_i) + + END SUBROUTINE scatter_omp_i + + + SUBROUTINE scatter_omp_i1(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL Check_buffer_i(size(VarIn)) + CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2),buffer_i) + + END SUBROUTINE scatter_omp_i1 + + + SUBROUTINE scatter_omp_i2(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL Check_buffer_i(size(VarIn)) + CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_i) + + END SUBROUTINE scatter_omp_i2 + + + SUBROUTINE scatter_omp_i3(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL Check_buffer_i(size(VarIn)) + CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_i) + + END SUBROUTINE scatter_omp_i3 + + + + + SUBROUTINE scatter_omp_r(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL Check_buffer_r(size(VarIn)) + CALL scatter_omp_rgen(VarIn,Varout,1,buffer_r) + + END SUBROUTINE scatter_omp_r + + + SUBROUTINE scatter_omp_r1(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL Check_buffer_r(size(VarIn)) + CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2),buffer_r) + + END SUBROUTINE scatter_omp_r1 + + + SUBROUTINE scatter_omp_r2(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL Check_buffer_r(size(VarIn)) + CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_r) + + END SUBROUTINE scatter_omp_r2 + + + SUBROUTINE scatter_omp_r3(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL Check_buffer_r(size(VarIn)) + CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_r) + + END SUBROUTINE scatter_omp_r3 + + + + SUBROUTINE scatter_omp_l(VarIn, VarOut) + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL Check_buffer_l(size(VarIn)) + CALL scatter_omp_lgen(VarIn,Varout,1,buffer_l) + + END SUBROUTINE scatter_omp_l + + + SUBROUTINE scatter_omp_l1(VarIn, VarOut) + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL Check_buffer_l(size(VarIn)) + CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2),buffer_l) + + END SUBROUTINE scatter_omp_l1 + + + SUBROUTINE scatter_omp_l2(VarIn, VarOut) + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL Check_buffer_l(size(VarIn)) + CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_l) + + END SUBROUTINE scatter_omp_l2 + + + SUBROUTINE scatter_omp_l3(VarIn, VarOut) + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL Check_buffer_l(size(VarIn)) + CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_l) + + END SUBROUTINE scatter_omp_l3 + + + SUBROUTINE gather_omp_i(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL Check_buffer_i(size(VarOut)) + CALL gather_omp_igen(VarIn,Varout,1,buffer_i) + + END SUBROUTINE gather_omp_i + + + SUBROUTINE gather_omp_i1(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL Check_buffer_i(size(VarOut)) + CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2),buffer_i) + + END SUBROUTINE gather_omp_i1 + + + SUBROUTINE gather_omp_i2(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL Check_buffer_i(size(VarOut)) + CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_i) + + END SUBROUTINE gather_omp_i2 + + + SUBROUTINE gather_omp_i3(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL Check_buffer_i(size(VarOut)) + CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_i) + + END SUBROUTINE gather_omp_i3 + + + + SUBROUTINE gather_omp_r(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL Check_buffer_r(size(VarOut)) + CALL gather_omp_rgen(VarIn,Varout,1,buffer_r) + + END SUBROUTINE gather_omp_r + + + SUBROUTINE gather_omp_r1(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL Check_buffer_r(size(VarOut)) + CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2),buffer_r) + + END SUBROUTINE gather_omp_r1 + + + SUBROUTINE gather_omp_r2(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL Check_buffer_r(size(VarOut)) + CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_r) + + END SUBROUTINE gather_omp_r2 + + + SUBROUTINE gather_omp_r3(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL Check_buffer_r(size(VarOut)) + CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_r) + + END SUBROUTINE gather_omp_r3 + + + SUBROUTINE gather_omp_l(VarIn, VarOut) + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL Check_buffer_l(size(VarOut)) + CALL gather_omp_lgen(VarIn,Varout,1,buffer_l) + + END SUBROUTINE gather_omp_l + + + SUBROUTINE gather_omp_l1(VarIn, VarOut) + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL Check_buffer_l(size(VarOut)) + CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2),buffer_l) + + END SUBROUTINE gather_omp_l1 + + + SUBROUTINE gather_omp_l2(VarIn, VarOut) + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL Check_buffer_l(size(VarOut)) + CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_l) + + END SUBROUTINE gather_omp_l2 + + + SUBROUTINE gather_omp_l3(VarIn, VarOut) + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL Check_buffer_l(size(VarOut)) + CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_l) + + END SUBROUTINE gather_omp_l3 + + + + + SUBROUTINE reduce_sum_omp_i(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN) :: VarIn + INTEGER,INTENT(OUT) :: VarOut + INTEGER :: VarIn_tmp(1) + INTEGER :: VarOut_tmp(1) + + VarIn_tmp(1)=VarIn + CALL Check_buffer_i(1) + CALL reduce_sum_omp_igen(VarIn_tmp,Varout_tmp,1,buffer_i) + VarOut=VarOut_tmp(1) + + END SUBROUTINE reduce_sum_omp_i + + SUBROUTINE reduce_sum_omp_i1(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL Check_buffer_i(size(VarIn)) + CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) + + END SUBROUTINE reduce_sum_omp_i1 + + + SUBROUTINE reduce_sum_omp_i2(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL Check_buffer_i(size(VarIn)) + CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) + + END SUBROUTINE reduce_sum_omp_i2 + + + SUBROUTINE reduce_sum_omp_i3(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL Check_buffer_i(size(VarIn)) + CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) + + END SUBROUTINE reduce_sum_omp_i3 + + + SUBROUTINE reduce_sum_omp_i4(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL Check_buffer_i(size(VarIn)) + CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) + + END SUBROUTINE reduce_sum_omp_i4 + + + SUBROUTINE reduce_sum_omp_r(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN) :: VarIn + REAL,INTENT(OUT) :: VarOut + REAL :: VarIn_tmp(1) + REAL :: VarOut_tmp(1) + + VarIn_tmp(1)=VarIn + CALL Check_buffer_r(1) + CALL reduce_sum_omp_rgen(VarIn_tmp,Varout_tmp,1,buffer_r) + VarOut=VarOut_tmp(1) + + END SUBROUTINE reduce_sum_omp_r + + SUBROUTINE reduce_sum_omp_r1(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL Check_buffer_r(size(VarIn)) + CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) + + END SUBROUTINE reduce_sum_omp_r1 + + + SUBROUTINE reduce_sum_omp_r2(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL Check_buffer_r(size(VarIn)) + CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) + + END SUBROUTINE reduce_sum_omp_r2 + + + SUBROUTINE reduce_sum_omp_r3(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL Check_buffer_r(size(VarIn)) + CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) + + END SUBROUTINE reduce_sum_omp_r3 + + + SUBROUTINE reduce_sum_omp_r4(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL Check_buffer_r(size(VarIn)) + CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) + + END SUBROUTINE reduce_sum_omp_r4 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! LES ROUTINES GENERIQUES ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE bcast_omp_cgen(Var,Nb,Buff) + IMPLICIT NONE + + CHARACTER(LEN=*),INTENT(INOUT) :: Var + CHARACTER(LEN=*),INTENT(INOUT) :: Buff + INTEGER,INTENT(IN) :: Nb + + INTEGER :: i + + !$OMP MASTER + Buff=Var + !$OMP END MASTER + !$OMP BARRIER + + DO i=1,Nb + Var=Buff + ENDDO + !$OMP BARRIER + + END SUBROUTINE bcast_omp_cgen + + + + SUBROUTINE bcast_omp_igen(Var,Nb,Buff) + IMPLICIT NONE + + INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Var + INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Buff + INTEGER,INTENT(IN) :: Nb + + INTEGER :: i + + !$OMP MASTER + DO i=1,Nb + Buff(i)=Var(i) + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + DO i=1,Nb + Var(i)=Buff(i) + ENDDO + !$OMP BARRIER + + END SUBROUTINE bcast_omp_igen + + + SUBROUTINE bcast_omp_rgen(Var,Nb,Buff) + IMPLICIT NONE + + REAL,DIMENSION(Nb),INTENT(INOUT) :: Var + REAL,DIMENSION(Nb),INTENT(INOUT) :: Buff + INTEGER,INTENT(IN) :: Nb + + INTEGER :: i + + !$OMP MASTER + DO i=1,Nb + Buff(i)=Var(i) + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + DO i=1,Nb + Var(i)=Buff(i) + ENDDO + !$OMP BARRIER + + END SUBROUTINE bcast_omp_rgen + + SUBROUTINE bcast_omp_lgen(Var,Nb,Buff) + IMPLICIT NONE + + LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Var + LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Buff + INTEGER,INTENT(IN) :: Nb + + INTEGER :: i + + !$OMP MASTER + DO i=1,Nb + Buff(i)=Var(i) + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + DO i=1,Nb + Var(i)=Buff(i) + ENDDO + !$OMP BARRIER + + END SUBROUTINE bcast_omp_lgen + + + SUBROUTINE scatter_omp_igen(VarIn,VarOut,dimsize,Buff) + USE mod_phys_lmdz_omp_data + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut + INTEGER,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff + + INTEGER :: i,ij + + !$OMP MASTER + DO i=1,dimsize + DO ij=1,klon_mpi + Buff(ij,i)=VarIn(ij,i) + ENDDO + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + DO i=1,dimsize + DO ij=1,klon_omp + VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i) + ENDDO + ENDDO + !$OMP BARRIER + + END SUBROUTINE scatter_omp_igen + + + SUBROUTINE scatter_omp_rgen(VarIn,VarOut,dimsize,Buff) + USE mod_phys_lmdz_omp_data + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut + REAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff + + INTEGER :: i,ij + + !$OMP MASTER + DO i=1,dimsize + DO ij=1,klon_mpi + Buff(ij,i)=VarIn(ij,i) + ENDDO + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + DO i=1,dimsize + DO ij=1,klon_omp + VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i) + ENDDO + ENDDO + !$OMP BARRIER + + END SUBROUTINE scatter_omp_rgen + + + SUBROUTINE scatter_omp_lgen(VarIn,VarOut,dimsize,Buff) + USE mod_phys_lmdz_omp_data + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + LOGICAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut + LOGICAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff + + INTEGER :: i,ij + + !$OMP MASTER + DO i=1,dimsize + DO ij=1,klon_mpi + Buff(ij,i)=VarIn(ij,i) + ENDDO + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + DO i=1,dimsize + DO ij=1,klon_omp + VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i) + ENDDO + ENDDO + !$OMP BARRIER + + END SUBROUTINE scatter_omp_lgen + + + + + + SUBROUTINE gather_omp_igen(VarIn,VarOut,dimsize,Buff) + USE mod_phys_lmdz_omp_data + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + INTEGER,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff + + INTEGER :: i,ij + + DO i=1,dimsize + DO ij=1,klon_omp + Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i) + ENDDO + ENDDO + !$OMP BARRIER + + + !$OMP MASTER + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij,i)=Buff(ij,i) + ENDDO + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + END SUBROUTINE gather_omp_igen + + + SUBROUTINE gather_omp_rgen(VarIn,VarOut,dimsize,Buff) + USE mod_phys_lmdz_omp_data + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + REAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff + + INTEGER :: i,ij + + DO i=1,dimsize + DO ij=1,klon_omp + Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i) + ENDDO + ENDDO + !$OMP BARRIER + + + !$OMP MASTER + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij,i)=Buff(ij,i) + ENDDO + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + END SUBROUTINE gather_omp_rgen + + + SUBROUTINE gather_omp_lgen(VarIn,VarOut,dimsize,Buff) + USE mod_phys_lmdz_omp_data + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + LOGICAL,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + LOGICAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff + + INTEGER :: i,ij + + DO i=1,dimsize + DO ij=1,klon_omp + Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i) + ENDDO + ENDDO + !$OMP BARRIER + + + !$OMP MASTER + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij,i)=Buff(ij,i) + ENDDO + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + END SUBROUTINE gather_omp_lgen + + + SUBROUTINE reduce_sum_omp_igen(VarIn,VarOut,dimsize,Buff) + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN),DIMENSION(dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(dimsize) :: VarOut + INTEGER,INTENT(INOUT),DIMENSION(dimsize) :: Buff + + INTEGER :: i + + !$OMP MASTER + Buff(:)=0 + !$OMP END MASTER + !$OMP BARRIER + + !$OMP CRITICAL + DO i=1,dimsize + Buff(i)=Buff(i)+VarIn(i) + ENDDO + !$OMP END CRITICAL + !$OMP BARRIER + + !$OMP MASTER + DO i=1,dimsize + VarOut(i)=Buff(i) + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + END SUBROUTINE reduce_sum_omp_igen + + SUBROUTINE reduce_sum_omp_rgen(VarIn,VarOut,dimsize,Buff) + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN),DIMENSION(dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(dimsize) :: VarOut + REAL,INTENT(INOUT),DIMENSION(dimsize) :: Buff + + INTEGER :: i + + !$OMP MASTER + Buff(:)=0 + !$OMP END MASTER + !$OMP BARRIER + + !$OMP CRITICAL + DO i=1,dimsize + Buff(i)=Buff(i)+VarIn(i) + ENDDO + !$OMP END CRITICAL + !$OMP BARRIER + + !$OMP MASTER + DO i=1,dimsize + VarOut(i)=Buff(i) + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + END SUBROUTINE reduce_sum_omp_rgen + +END MODULE mod_phys_lmdz_omp_transfert Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_para.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_para.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_para.F90 (revision 1280) @@ -0,0 +1,106 @@ +! +!$Header$ +! +MODULE mod_phys_lmdz_para + USE mod_phys_lmdz_transfert_para + USE mod_phys_lmdz_mpi_data + USE mod_phys_lmdz_omp_data + + INTEGER,SAVE :: klon_loc + LOGICAL,SAVE :: is_sequential + LOGICAL,SAVE :: is_parallel + +!$OMP THREADPRIVATE(klon_loc) + +CONTAINS + + SUBROUTINE Init_phys_lmdz_para(iim,jjp1,nb_proc,distrib) + IMPLICIT NONE + INTEGER,INTENT(in) :: iim + INTEGER,INTENT(in) :: jjp1 + INTEGER,INTENT(in) :: nb_proc + INTEGER,INTENT(in) :: distrib(0:nb_proc-1) + + CALL Init_phys_lmdz_mpi_data(iim,jjp1,nb_proc,distrib) +!$OMP PARALLEL + CALL Init_phys_lmdz_omp_data(klon_mpi) + klon_loc=klon_omp + CALL Test_transfert +!$OMP END PARALLEL + IF (is_using_mpi .OR. is_using_omp) THEN + is_sequential=.FALSE. + is_parallel=.TRUE. + ELSE + is_sequential=.TRUE. + is_parallel=.FALSE. + ENDIF + + END SUBROUTINE Init_phys_lmdz_para + + SUBROUTINE Test_transfert + USE mod_grid_phy_lmdz + IMPLICIT NONE + + REAL :: Test_Field1d_glo(klon_glo,nbp_lev) + REAL :: tmp1d_glo(klon_glo,nbp_lev) + REAL :: Test_Field2d_glo(nbp_lon,nbp_lat,nbp_lev) + REAL :: tmp2d_glo(nbp_lon,nbp_lat,nbp_lev) + REAL :: Test_Field1d_loc(klon_loc,nbp_lev) + REAL :: Test_Field2d_loc(nbp_lon,jj_nb,nbp_lev) + REAL :: CheckSum + + INTEGER :: i,l + + Test_Field1d_glo = 0. + Test_Field2d_glo = 0. + Test_Field1d_loc = 0. + Test_Field2d_loc = 0. + + IF (is_mpi_root) THEN +!$OMP MASTER + DO l=1,nbp_lev + DO i=1,klon_glo +! Test_Field1d_glo(i,l)=MOD(i,10)+10*(l-1) + Test_Field1d_glo(i,l)=1 + ENDDO + ENDDO +!$OMP END MASTER + ENDIF + + CALL Scatter(Test_Field1d_glo,Test_Field1d_loc) + CALL Gather(Test_Field1d_loc,tmp1d_glo) + + IF (is_mpi_root) THEN +!$OMP MASTER + Checksum=sum(Test_Field1d_glo-tmp1d_glo) + PRINT *, "------> Checksum =",Checksum," MUST BE 0" +!$OMP END MASTER + ENDIF + + CALL grid1dTo2d_glo(Test_Field1d_glo,Test_Field2d_glo) + CALL scatter2D(Test_Field2d_glo,Test_Field1d_loc) + CALL gather2d(Test_Field1d_loc,Test_Field2d_glo) + CALL grid2dTo1d_glo(Test_Field2d_glo,tmp1d_glo) + + IF (is_mpi_root) THEN +!$OMP MASTER + Checksum=sum(Test_Field1d_glo-tmp1d_glo) + PRINT *, "------> Checksum =",Checksum," MUST BE 0" +!$OMP END MASTER + ENDIF + + CALL bcast(Test_Field1d_glo) + CALL reduce_sum(Test_Field1d_glo,tmp1d_glo) + + IF (is_mpi_root) THEN +!$OMP MASTER + Checksum=sum(Test_Field1d_glo*omp_size*mpi_size-tmp1d_glo) + PRINT *, "------> Checksum =",Checksum," MUST BE 0" +!$OMP END MASTER + ENDIF + + + END SUBROUTINE Test_transfert + +END MODULE mod_phys_lmdz_para + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_transfert_para.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_transfert_para.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_phys_lmdz_transfert_para.F90 (revision 1280) @@ -0,0 +1,1275 @@ +! +!$Header$ +! +MODULE mod_phys_lmdz_transfert_para + + USE mod_phys_lmdz_mpi_transfert + USE mod_phys_lmdz_omp_transfert + + + + INTERFACE bcast + MODULE PROCEDURE bcast_c, & + bcast_i,bcast_i1,bcast_i2,bcast_i3,bcast_i4, & + bcast_r,bcast_r1,bcast_r2,bcast_r3,bcast_r4, & + bcast_l,bcast_l1,bcast_l2,bcast_l3,bcast_l4 + END INTERFACE + + INTERFACE scatter + MODULE PROCEDURE scatter_i,scatter_i1,scatter_i2,scatter_i3, & + scatter_r,scatter_r1,scatter_r2,scatter_r3, & + scatter_l,scatter_l1,scatter_l2,scatter_l3 + END INTERFACE + + + INTERFACE gather + MODULE PROCEDURE gather_i,gather_i1,gather_i2,gather_i3, & + gather_r,gather_r1,gather_r2,gather_r3, & + gather_l,gather_l1,gather_l2,gather_l3 + END INTERFACE + + INTERFACE scatter2D + MODULE PROCEDURE scatter2D_i,scatter2D_i1,scatter2D_i2,scatter2D_i3, & + scatter2D_r,scatter2D_r1,scatter2D_r2,scatter2D_r3, & + scatter2D_l,scatter2D_l1,scatter2D_l2,scatter2D_l3 + END INTERFACE + + INTERFACE gather2D + MODULE PROCEDURE gather2D_i,gather2D_i1,gather2D_i2,gather2D_i3, & + gather2D_r,gather2D_r1,gather2D_r2,gather2D_r3, & + gather2D_l,gather2D_l1,gather2D_l2,gather2D_l3 + END INTERFACE + + INTERFACE reduce_sum + MODULE PROCEDURE reduce_sum_i,reduce_sum_i1,reduce_sum_i2,reduce_sum_i3,reduce_sum_i4, & + reduce_sum_r,reduce_sum_r1,reduce_sum_r2,reduce_sum_r3,reduce_sum_r4 + END INTERFACE + + +CONTAINS + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Broadcast --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!! -- Les chaine de charactère -- !! + + SUBROUTINE bcast_c(var) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(INOUT) :: Var + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_c + +!! -- Les entiers -- !! + + SUBROUTINE bcast_i(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_i + + SUBROUTINE bcast_i1(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_i1 + + + SUBROUTINE bcast_i2(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_i2 + + + SUBROUTINE bcast_i3(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_i3 + + + SUBROUTINE bcast_i4(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:,:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_i4 + + +!! -- Les reels -- !! + + SUBROUTINE bcast_r(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_r + + SUBROUTINE bcast_r1(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_r1 + + + SUBROUTINE bcast_r2(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_r2 + + + SUBROUTINE bcast_r3(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_r3 + + + SUBROUTINE bcast_r4(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:,:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_r4 + + +!! -- Les booleens -- !! + + SUBROUTINE bcast_l(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_l + + SUBROUTINE bcast_l1(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_l1 + + + SUBROUTINE bcast_l2(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_l2 + + + SUBROUTINE bcast_l3(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_l3 + + + SUBROUTINE bcast_l4(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:,:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_l4 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Scatter --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE scatter_i(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + INTEGER,DIMENSION(klon_mpi) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_i + + + SUBROUTINE scatter_i1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_i1 + + + SUBROUTINE scatter_i2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_i2 + + + SUBROUTINE scatter_i3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter_i3 + + + SUBROUTINE scatter_r(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + REAL,DIMENSION(klon_mpi) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_r + + + SUBROUTINE scatter_r1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_r1 + + + SUBROUTINE scatter_r2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_r2 + + + SUBROUTINE scatter_r3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter_r3 + + + + SUBROUTINE scatter_l(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_l + + + SUBROUTINE scatter_l1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_l1 + + + SUBROUTINE scatter_l2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_l2 + + + SUBROUTINE scatter_l3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter_l3 + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Gather --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!!!!! --> Les entiers + + SUBROUTINE gather_i(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + INTEGER, DIMENSION(klon_mpi) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,Varout) +!$OMP END MASTER + + END SUBROUTINE gather_i + + + SUBROUTINE gather_i1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,Varout) +!$OMP END MASTER + + END SUBROUTINE gather_i1 + + + SUBROUTINE gather_i2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_i2 + + + SUBROUTINE gather_i3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_i3 + + +!!!!! --> Les reels + + SUBROUTINE gather_r(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + REAL, DIMENSION(klon_mpi) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_r + + + SUBROUTINE gather_r1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + REAL, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_r1 + + + SUBROUTINE gather_r2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + REAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_r2 + + + SUBROUTINE gather_r3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + REAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_r3 + + +!!!!! --> Les booleens + + SUBROUTINE gather_l(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + LOGICAL, DIMENSION(klon_mpi) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_l + + + SUBROUTINE gather_l1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_l1 + + + SUBROUTINE gather_l2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_l2 + + + SUBROUTINE gather_l3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_l3 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Scatter2D --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + +!!!!! --> Les entiers + + SUBROUTINE scatter2D_i(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + INTEGER,DIMENSION(klon_mpi) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_i + + + SUBROUTINE scatter2D_i1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_i1 + + + SUBROUTINE scatter2D_i2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_i2 + + + SUBROUTINE scatter2D_i3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_i3 + + +!!!!! --> Les reels + + SUBROUTINE scatter2D_r(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + REAL,DIMENSION(klon_mpi) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_r + + + SUBROUTINE scatter2D_r1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_r1 + + + SUBROUTINE scatter2D_r2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_r2 + + + SUBROUTINE scatter2D_r3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_r3 + + +!!!!! --> Les booleens + + + SUBROUTINE scatter2D_l(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_l + + + SUBROUTINE scatter2D_l1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_l1 + + + SUBROUTINE scatter2D_l2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_l2 + + + SUBROUTINE scatter2D_l3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_l3 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Gather2D --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!!!!! --> Les entiers + + SUBROUTINE gather2D_i(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_i + + + SUBROUTINE gather2D_i1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_i1 + + + SUBROUTINE gather2D_i2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_i2 + + + SUBROUTINE gather2D_i3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_i3 + + +!!!!! --> Les reels + + SUBROUTINE gather2D_r(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + REAL,DIMENSION(klon_mpi) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_r + + + SUBROUTINE gather2D_r1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_r1 + + + SUBROUTINE gather2D_r2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_r2 + + + SUBROUTINE gather2D_r3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_r3 + + +!!!!! --> Les booleens + + SUBROUTINE gather2D_l(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_l + + + SUBROUTINE gather2D_l1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_l1 + + + SUBROUTINE gather2D_l2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_l2 + + + SUBROUTINE gather2D_l3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_l3 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des reduce_sum --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! Les entiers + + SUBROUTINE reduce_sum_i(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN) :: VarIn + INTEGER,INTENT(OUT) :: VarOut + + INTEGER :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_i + + + SUBROUTINE reduce_sum_i1(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + INTEGER,DIMENSION(SIZE(VarIn)) :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_i1 + + + SUBROUTINE reduce_sum_i2(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_i2 + + + SUBROUTINE reduce_sum_i3(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_i3 + + + SUBROUTINE reduce_sum_i4(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_i4 + + +! Les reels + + SUBROUTINE reduce_sum_r(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN) :: VarIn + REAL,INTENT(OUT) :: VarOut + + REAL :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_r + + + SUBROUTINE reduce_sum_r1(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + REAL,DIMENSION(SIZE(VarIn)) :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_r1 + + + SUBROUTINE reduce_sum_r2(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_r2 + + + SUBROUTINE reduce_sum_r3(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_r3 + + + SUBROUTINE reduce_sum_r4(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_r4 + + +END MODULE mod_phys_lmdz_transfert_para + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_surf_para.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_surf_para.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_surf_para.F90 (revision 1280) @@ -0,0 +1,350 @@ +MODULE mod_surf_para + IMPLICIT NONE + + INTERFACE gather_surf + MODULE PROCEDURE gather_surf_i,gather_surf_r + END INTERFACE gather_surf + + INTERFACE gather_surf_omp + MODULE PROCEDURE gather_surf_omp_i,gather_surf_omp_r + END INTERFACE gather_surf_omp + + INTERFACE gather_surf_mpi + MODULE PROCEDURE gather_surf_mpi_i,gather_surf_mpi_r + END INTERFACE gather_surf_mpi + + INTERFACE scatter_surf + MODULE PROCEDURE scatter_surf_i,scatter_surf_r + END INTERFACE scatter_surf + + INTERFACE scatter_surf_omp + MODULE PROCEDURE scatter_surf_omp_i,scatter_surf_omp_r + END INTERFACE scatter_surf_omp + + INTERFACE scatter_surf_mpi + MODULE PROCEDURE scatter_surf_mpi_i,scatter_surf_mpi_r + END INTERFACE scatter_surf_mpi + + + INTEGER,SAVE :: knon_omp + INTEGER,SAVE :: knon_omp_begin + INTEGER,SAVE :: knon_omp_end +!$OMP THREADPRIVATE(knon_omp,knon_omp_begin,knon_omp_end) + INTEGER,ALLOCATABLE,SAVE :: knon_omp_para(:) + INTEGER,ALLOCATABLE,SAVE :: knon_omp_begin_para(:) + INTEGER,ALLOCATABLE,SAVE :: knon_omp_end_para(:) + + INTEGER,SAVE :: knon_mpi + INTEGER,ALLOCATABLE,SAVE :: knon_mpi_para(:) + INTEGER,ALLOCATABLE,SAVE :: knon_mpi_begin_para(:) + INTEGER,ALLOCATABLE,SAVE :: knon_mpi_end_para(:) + + INTEGER,SAVE :: knon_glo + INTEGER,SAVE,ALLOCATABLE :: knon_glo_para(:) + INTEGER,ALLOCATABLE,SAVE :: knon_glo_begin_para(:) + INTEGER,ALLOCATABLE,SAVE :: knon_glo_end_para(:) + + +CONTAINS + + SUBROUTINE Init_surf_para(knon) + USE mod_phys_lmdz_para, mpi_rank_root=>mpi_root +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: knon + INTEGER :: i,ierr + + knon_omp=knon + IF (is_omp_root) THEN + ALLOCATE(knon_omp_para(0:omp_size-1)) + ALLOCATE(knon_omp_begin_para(0:omp_size-1)) + ALLOCATE(knon_omp_end_para(0:omp_size-1)) + ENDIF +!$OMP BARRIER + knon_omp_para(omp_rank)=knon +!$OMP BARRIER + IF (is_omp_root) THEN + knon_omp_begin_para(0)=1 + knon_omp_end_para(0)=knon_omp_para(0) + DO i=1,omp_size-1 + knon_omp_begin_para(i)=knon_omp_end_para(i-1)+1 + knon_omp_end_para(i)=knon_omp_begin_para(i)+knon_omp_para(i)-1 + ENDDO + ENDIF +!$OMP BARRIER + knon_omp_begin=knon_omp_begin_para(omp_rank) + knon_omp_end=knon_omp_end_para(omp_rank) +!$OMP BARRIER + IF (is_omp_root) THEN + knon_mpi=sum(knon_omp_para) + ALLOCATE(knon_mpi_para(0:mpi_size-1)) + ALLOCATE(knon_mpi_begin_para(0:mpi_size-1)) + ALLOCATE(knon_mpi_end_para(0:mpi_size-1)) + + ALLOCATE(knon_glo_para(0:mpi_size*omp_size-1)) + ALLOCATE(knon_glo_begin_para(0:mpi_size*omp_size-1)) + ALLOCATE(knon_glo_end_para(0:mpi_size*omp_size-1)) + + IF (is_using_mpi) THEN +#ifdef CPP_MPI + CALL MPI_ALLGather(knon_mpi,1,MPI_INTEGER,knon_mpi_para,1,MPI_INTEGER,COMM_LMDZ_PHY,ierr) + CALL MPI_ALLGather(knon_omp_para,omp_size,MPI_INTEGER,knon_glo_para,omp_size,MPI_INTEGER,COMM_LMDZ_PHY,ierr) +#endif + ELSE + knon_mpi_para(:)=knon_mpi + knon_glo_para(:)=knon_omp_para(:) + ENDIF + + knon_glo=sum(knon_mpi_para(:)) + + knon_mpi_begin_para(0)=1 + knon_mpi_end_para(0)=knon_mpi_para(0) + DO i=1,mpi_size-1 + knon_mpi_begin_para(i)=knon_mpi_end_para(i-1)+1 + knon_mpi_end_para(i)=knon_mpi_begin_para(i)+knon_mpi_para(i)-1 + ENDDO + + knon_glo_begin_para(0)=1 + knon_glo_end_para(0)=knon_glo_para(0) + DO i=1,mpi_size*omp_size-1 + knon_glo_begin_para(i)=knon_glo_end_para(i-1)+1 + knon_glo_end_para(i)= knon_glo_begin_para(i)+knon_glo_para(i)-1 + ENDDO + ENDIF +!$OMP BARRIER + + END SUBROUTINE Init_surf_para + + + SUBROUTINE Finalize_surf_para + USE mod_phys_lmdz_para + +!$OMP BARRIER + IF (is_omp_root) THEN + DEALLOCATE(knon_omp_para) + DEALLOCATE(knon_omp_begin_para) + DEALLOCATE(knon_omp_end_para) + DEALLOCATE(knon_mpi_para) + DEALLOCATE(knon_mpi_begin_para) + DEALLOCATE(knon_mpi_end_para) + DEALLOCATE(knon_glo_para) + DEALLOCATE(knon_glo_begin_para) + DEALLOCATE(knon_glo_end_para) + ENDIF + + END SUBROUTINE Finalize_surf_para + + + SUBROUTINE gather_surf_i(FieldIn, FieldOut) + USE mod_phys_lmdz_para + INTEGER :: FieldIn(:) + INTEGER :: FieldOut(:) + INTEGER :: FieldTmp(knon_mpi) + + CALL gather_surf_omp_i(FieldIn,FieldTmp) + IF (is_omp_root) CALL gather_surf_mpi_i(FieldTmp,FieldOut) + + END SUBROUTINE gather_surf_i + + + SUBROUTINE gather_surf_omp_i(FieldIn,FieldOut) + USE mod_phys_lmdz_para + INTEGER :: FieldIn(:) + INTEGER :: FieldOut(:) + + INTEGER,SAVE,ALLOCATABLE :: Field_tmp(:) + + IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi)) +!$OMP BARRIER + Field_tmp(knon_omp_begin:knon_omp_end)=FieldIn(:) +!$OMP BARRIER + IF (is_omp_root) FieldOut(:)=Field_tmp(:) +!$OMP BARRIER + IF (is_omp_root) DEALLOCATE(Field_tmp) + + END SUBROUTINE gather_surf_omp_i + + + SUBROUTINE gather_surf_mpi_i(FieldIn,FieldOut) + USE mod_phys_lmdz_para, mpi_rank_root => mpi_root +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: FieldIn(:) + INTEGER :: FieldOut(:) + INTEGER :: ierr + + IF (is_using_mpi) THEN +#ifdef CPP_MPI + CALL MPI_Gatherv(FieldIn,knon_mpi,MPI_INTEGER, & + FieldOut,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_INTEGER, & + mpi_rank_root,COMM_LMDZ_PHY,ierr) +#endif + ELSE + FieldOut(:)=FieldIn(:) + ENDIF + + END SUBROUTINE gather_surf_mpi_i + + + + + + SUBROUTINE gather_surf_r(FieldIn, FieldOut) + USE mod_phys_lmdz_para + REAL :: FieldIn(:) + REAL :: FieldOut(:) + REAL :: FieldTmp(knon_mpi) + + CALL gather_surf_omp_r(FieldIn,FieldTmp) + IF (is_omp_root) CALL gather_surf_mpi_r(FieldTmp,FieldOut) + + END SUBROUTINE gather_surf_r + + + SUBROUTINE gather_surf_omp_r(FieldIn,FieldOut) + USE mod_phys_lmdz_para + REAL :: FieldIn(:) + REAL :: FieldOut(:) + + REAL,SAVE,ALLOCATABLE :: Field_tmp(:) + + IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi)) +!$OMP BARRIER + Field_tmp(knon_omp_begin:knon_omp_end)=FieldIn(:) +!$OMP BARRIER + IF (is_omp_root) FieldOut(:)=Field_tmp(:) +!$OMP BARRIER + IF (is_omp_root) DEALLOCATE(Field_tmp) + + END SUBROUTINE gather_surf_omp_r + + + SUBROUTINE gather_surf_mpi_r(FieldIn,FieldOut) + USE mod_phys_lmdz_para, mpi_rank_root => mpi_root +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + REAL :: FieldIn(:) + REAL :: FieldOut(:) + REAL :: ierr + + IF (is_using_mpi) THEN +#ifdef CPP_MPI + CALL MPI_Gatherv(FieldIn,knon_mpi,MPI_REAL_LMDZ, & + FieldOut,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_REAL_LMDZ, & + mpi_rank_root,COMM_LMDZ_PHY,ierr) +#endif + ELSE + FieldOut(:)=FieldIn(:) + ENDIF + + END SUBROUTINE gather_surf_mpi_r + + + + + SUBROUTINE scatter_surf_i(FieldIn, FieldOut) + USE mod_phys_lmdz_para + INTEGER :: FieldIn(:) + INTEGER :: FieldOut(:) + INTEGER :: FieldTmp(knon_mpi) + + IF (is_omp_root) CALL scatter_surf_mpi_i(FieldIn,FieldTmp) + CALL scatter_surf_omp_i(FieldTmp,FieldOut) + + END SUBROUTINE scatter_surf_i + + + SUBROUTINE scatter_surf_omp_i(FieldIn,FieldOut) + USE mod_phys_lmdz_para + INTEGER :: FieldIn(:) + INTEGER :: FieldOut(:) + + INTEGER,SAVE,ALLOCATABLE :: Field_tmp(:) + + IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi)) + IF (is_omp_root) Field_tmp(:)=FieldIn(:) +!$OMP BARRIER + FieldOut(:)=Field_tmp(knon_omp_begin:knon_omp_end) +!$OMP BARRIER + IF (is_omp_root) DEALLOCATE(Field_tmp) + + END SUBROUTINE scatter_surf_omp_i + + + SUBROUTINE scatter_surf_mpi_i(FieldIn,FieldOut) + USE mod_phys_lmdz_para, mpi_rank_root => mpi_root +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: FieldIn(:) + INTEGER :: FieldOut(:) + INTEGER :: ierr + + IF (is_using_mpi) THEN +#ifdef CPP_MPI + CALL MPI_Scatterv(FieldIn,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_INTEGER, & + FieldOut,knon_mpi,MPI_INTEGER, & + mpi_rank_root,COMM_LMDZ_PHY,ierr) +#endif + ELSE + FieldOut(:)=FieldIn(:) + ENDIF + + END SUBROUTINE scatter_surf_mpi_i + + + + SUBROUTINE scatter_surf_r(FieldIn, FieldOut) + USE mod_phys_lmdz_para + REAL :: FieldIn(:) + REAL :: FieldOut(:) + REAL :: FieldTmp(knon_mpi) + + IF (is_omp_root) CALL scatter_surf_mpi_r(FieldIn,FieldTmp) + CALL scatter_surf_omp_r(FieldTmp,FieldOut) + + END SUBROUTINE scatter_surf_r + + + SUBROUTINE scatter_surf_omp_r(FieldIn,FieldOut) + USE mod_phys_lmdz_para + REAL :: FieldIn(:) + REAL :: FieldOut(:) + + INTEGER,SAVE,ALLOCATABLE :: Field_tmp(:) + + IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi)) + IF (is_omp_root) Field_tmp(:)=FieldIn(:) +!$OMP BARRIER + FieldOut(:)=Field_tmp(knon_omp_begin:knon_omp_end) +!$OMP BARRIER + IF (is_omp_root) DEALLOCATE(Field_tmp) + + END SUBROUTINE scatter_surf_omp_r + + + SUBROUTINE scatter_surf_mpi_r(FieldIn,FieldOut) + USE mod_phys_lmdz_para, mpi_rank_root => mpi_root +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + REAL :: FieldIn(:) + REAL :: FieldOut(:) + INTEGER :: ierr + + IF (is_using_mpi) THEN +#ifdef CPP_MPI + CALL MPI_Scatterv(FieldIn,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_INTEGER, & + FieldOut,knon_mpi,MPI_INTEGER, & + mpi_rank_root,COMM_LMDZ_PHY,ierr) +#endif + ELSE + FieldOut(:)=FieldIn(:) + ENDIF + + END SUBROUTINE scatter_surf_mpi_r + +END MODULE mod_surf_para Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_synchro_omp.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_synchro_omp.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/mod_synchro_omp.F90 (revision 1280) @@ -0,0 +1,34 @@ +MODULE mod_synchro_omp + + LOGICAL,SAVE,ALLOCATABLE :: flag_omp(:) + +CONTAINS + + SUBROUTINE Init_synchro_omp + USE mod_phys_lmdz_para + IMPLICIT NONE + + IF (is_omp_root) THEN + ALLOCATE(flag_omp(0:omp_size-1)) + flag_omp(:)=.FALSE. + ENDIF +!$OMP BARRIER + + END SUBROUTINE Init_Synchro_omp + + SUBROUTINE Synchro_omp + USE mod_phys_lmdz_para + IMPLICIT NONE + + flag_omp(omp_rank)=.TRUE. +!$OMP BARRIER + DO WHILE (.NOT. ALL(flag_omp)) +!$OMP BARRIER + ENDDO +!$OMP BARRIER + flag_omp(omp_rank)=.FALSE. +!$OMP BARRIER + + END SUBROUTINE Synchro_omp + +END MODULE mod_synchro_omp Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/moy_undefSTD.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/moy_undefSTD.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/moy_undefSTD.F (revision 1280) @@ -0,0 +1,89 @@ +! +! $Header$ +! + SUBROUTINE moy_undefSTD(nlevSTD,itap, + $ dtime,ecrit_day,ecrit_mth,ecrit_hf2mth, + $ tnondef,tsumSTD) + USE netcdf + USE dimphy + IMPLICIT none +c +c==================================================================== +c +c I. Musat : 09.2004 +c +c Moyenne - a des frequences differentes - des valeurs bien definies +c (.NE.1.E+20) des variables interpolees a un niveau de +c pression. +c 1) les variables de type "day" (nout=1) ou "mth" (nout=2) sont sommees +c tous les pas de temps de la physique +c +c 2) les variables de type "NMC" (nout=3) sont calculees a partir +c des valeurs instantannees toutes les 6 heures +c +c +c NB: mettre "inst(X)" dans le write_histXXX.h ! +c==================================================================== +cym#include "dimensions.h" +cym integer jjmp1 +cym parameter (jjmp1=jjm+1-1/jjm) +cym#include "dimphy.h" +c +c +c variables Input + INTEGER nlevSTD, klevSTD, itap + PARAMETER(klevSTD=17) + REAL dtime, ecrit_day, ecrit_mth, ecrit_hf2mth +c +c variables locales + INTEGER i, k, nout + PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC +c +c variables Output + REAL tnondef(klon,klevSTD,nout) + REAL tsumSTD(klon,klevSTD,nout) +c + REAL missing_val +c + missing_val=nf90_fill_real +c +c calcul 1 fois par jour +c + IF(MOD(itap,NINT(ecrit_day/dtime)).EQ.0) THEN + DO k=1, nlevSTD + DO i=1, klon + IF (NINT(tnondef(i,k,1)).NE.NINT(ecrit_day/dtime)) THEN + tsumSTD(i,k,1)=tsumSTD(i,k,1)/ + $ (ecrit_day/dtime-tnondef(i,k,1)) + ELSE + tsumSTD(i,k,1)=missing_val + ENDIF !tnondef + ENDDO !i + ENDDO !k + ENDIF !MOD(itap,ecrit_day).EQ.0 +c +c calcul 1 fois par mois +c + IF(MOD(itap,NINT(ecrit_mth/dtime)).EQ.0) THEN + DO k=1, nlevSTD + DO i=1, klon + IF(tnondef(i,k,2).NE.ecrit_mth/dtime) THEN + tsumSTD(i,k,2)=tsumSTD(i,k,2)/ + $ (ecrit_mth/dtime-tnondef(i,k,2)) + ELSE + tsumSTD(i,k,2)=missing_val + ENDIF !tnondef +c + IF(tnondef(i,k,3).NE.NINT(ecrit_hf2mth)) THEN + tsumSTD(i,k,3)=tsumSTD(i,k,3)/ + $ (ecrit_hf2mth-tnondef(i,k,3)) + ELSE + tsumSTD(i,k,3)=missing_val + ENDIF !tnondef +c + ENDDO !i + ENDDO !k + ENDIF !MOD +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/moyglo_aire.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/moyglo_aire.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/moyglo_aire.F (revision 1280) @@ -0,0 +1,161 @@ +! +! $Header$ +! + SUBROUTINE moyglo_pondaire(nhori, champ, aire, + . ok_msk, msk, moyglo) +c + USE dimphy + IMPLICIT none +c +c ================================================================== +c I. Musat, 07.2004 +c +c Calcul moyenne globale ponderee par l'aire totale, avec ou sans masque +c +c moyenne = Somme_(champ* aire)/Somme_aire +c +c ================================================================== +c +#include "dimensions.h" +cym#include "dimphy.h" + INTEGER i, nhori + REAL champ(klon), aire(klon), msk(klon) + LOGICAL ok_msk + REAL moyglo +c +c var locale + REAL airetot +c +c PRINT*,'moyglo_pondaire nhori',nhori +c + airetot=0. + moyglo=0. +c + IF(ok_msk) THEN + DO i=1, nhori +c IF(msk(i).EQ.1.) THEN + IF(msk(i).GT.0.) THEN +c +c aire totale + airetot=airetot+aire(i)*msk(i) +c +c ponderation par la masse + moyglo=moyglo+champ(i)* aire(i)*msk(i) + ENDIF + ENDDO +c + ELSE !ok_msk + DO i=1, nhori +c +c aire totale + airetot=airetot+aire(i) +c +c ponderation par la masse + moyglo=moyglo+champ(i)* aire(i) + ENDDO +c + ENDIF +c +c moyenne ponderee par l'aire + moyglo=moyglo/airetot +c + RETURN + END +c + SUBROUTINE moyglo_pondaima(nhori, nvert, champ, + . aire, pbord, moyglo) + USE dimphy + IMPLICIT none +c ================================================================== +c I. Musat, 07.2004 +c +c Calcul moyenne globale ponderee par la masse d'air, divisee par l'aire +c totale avec ou sans masque +c +c moyenne = Somme_(champ* masse_dair)/Somme_aire +c +c ================================================================== +#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" + INTEGER i, k, nhori, nvert + REAL champ(klon,klev), aire(klon) + REAL pbord(klon,klev+1) + REAL moyglo +c +c var locale + REAL airetot +c +c PRINT*,'moyglo_pondaima RG, nhori, nvert',RG,nhori,nvert +c +c ponderation par la masse + moyglo=0. + DO k=1, nvert + DO i=1, nhori + moyglo=moyglo+ + . champ(i,k)*(pbord(i,k)-pbord(i,k+1))/RG*aire(i) + ENDDO + ENDDO +c +c aire totale + airetot=0. + DO i=1, nhori + airetot=airetot+aire(i) + ENDDO +c +c moyenne par mettre carre avec ponderation par la masse + moyglo=moyglo/airetot +c + RETURN + END +c + SUBROUTINE moyglo_pondmass(nhori, nvert, champ, + . aire, pbord, moyglo) + USE dimphy + IMPLICIT none +c ================================================================== +c I. Musat, 07.2004 +c +c Calcul moyenne globale ponderee par la masse d'air, divisee par la +c masse totale d'air, avec ou sans masque +c +c moyenne = Somme_(champ* masse_dair)/Somme_(masse_dair) +c +c ================================================================== +#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" + INTEGER i, k, nhori, nvert + REAL champ(klon,klev), aire(klon) + REAL pbord(klon,klev+1) + REAL moyglo +c +c var locale + REAL massetot +c +c PRINT*,'moyglo_pondmass RG, nhori, nvert',RG,nhori,nvert +c +c ponderation par la masse + moyglo=0. + DO k=1, nvert + DO i=1, nhori + moyglo=moyglo+ + . champ(i,k)*(pbord(i,k)-pbord(i,k+1))/RG*aire(i) + ENDDO + ENDDO +c +c masse totale + massetot=0. + DO k=1, nvert + DO i=1, nhori + massetot=massetot+ + . (pbord(i,k)-pbord(i,k+1))/RG*aire(i) + ENDDO + ENDDO +c +c moyenne par mettre carre avec ponderation par la masse + moyglo=moyglo/massetot +c + RETURN + END +c Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/newmicro.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/newmicro.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/newmicro.F (revision 1280) @@ -0,0 +1,473 @@ +! $Id$ +! + SUBROUTINE newmicro (paprs, pplay,ok_newmicro, + . t, pqlwp, pclc, pcltau, pclemi, + . pch, pcl, pcm, pct, pctlwp, + s xflwp, xfiwp, xflwc, xfiwc, + e ok_aie, + e mass_solu_aero, mass_solu_aero_pi, + e bl95_b0, bl95_b1, + s cldtaupi, re, fl, reliq, reice) + + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910 +c Objet: Calculer epaisseur optique et emmissivite des nuages +c====================================================================== +c Arguments: +c t-------input-R-temperature +c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg) +c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1) +c +c ok_aie--input-L-apply aerosol indirect effect or not +c mass_solu_aero-----input-R-total mass concentration for all soluble aerosols[ug/m^3] +c mass_solu_aero_pi--input-R-dito, pre-industrial value +c bl95_b0-input-R-a parameter, may be varied for tests (s-sea, l-land) +c bl95_b1-input-R-a parameter, may be varied for tests ( -"- ) +c +c cldtaupi-output-R-pre-industrial value of cloud optical thickness, +c needed for the diagnostics of the aerosol indirect +c radiative forcing (see radlwsw) +c re------output-R-Cloud droplet effective radius multiplied by fl [um] +c fl------output-R-Denominator to re, introduced to avoid problems in +c the averaging of the output. fl is the fraction of liquid +c water clouds within a grid cell +c pcltau--output-R-epaisseur optique des nuages +c pclemi--output-R-emissivite des nuages (0 a 1) +c====================================================================== +C +#include "YOMCST.h" +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "nuage.h" +cIM cf. CR: include pour NOVLP et ZEPSEC +#include "radepsi.h" +#include "radopt.h" + REAL paprs(klon,klev+1), pplay(klon,klev) + REAL t(klon,klev) +c + REAL pclc(klon,klev) + REAL pqlwp(klon,klev) + REAL pcltau(klon,klev), pclemi(klon,klev) +c + REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon) +c + LOGICAL lo +c + REAL cetahb, cetamb + PARAMETER (cetahb = 0.45, cetamb = 0.80) +C + INTEGER i, k +cIM: 091003 REAL zflwp, zradef, zfice, zmsac + REAL zflwp(klon), zradef, zfice, zmsac +cIM: 091003 rajout + REAL xflwp(klon), xfiwp(klon) + REAL xflwc(klon,klev), xfiwc(klon,klev) +c + REAL radius, rad_chaud +cc PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0) +ccc PARAMETER (rad_chaud=15.0, rad_froid=35.0) +c sintex initial PARAMETER (rad_chaud=10.0, rad_froid=30.0) + REAL coef, coef_froi, coef_chau + PARAMETER (coef_chau=0.13, coef_froi=0.09) + REAL seuil_neb, t_glace + PARAMETER (seuil_neb=0.001, t_glace=273.0-15.0) + INTEGER nexpo ! exponentiel pour glace/eau + PARAMETER (nexpo=6) +ccc PARAMETER (nexpo=1) + +c -- sb: + logical ok_newmicro +c parameter (ok_newmicro=.FALSE.) +cIM: 091003 real rel, tc, rei, zfiwp + real rel, tc, rei, zfiwp(klon) + real k_liq, k_ice0, k_ice, DF + parameter (k_liq=0.0903, k_ice0=0.005) ! units=m2/g + parameter (DF=1.66) ! diffusivity factor +c sb -- +cjq for the aerosol indirect effect +cjq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003 +cjq + LOGICAL ok_aie ! Apply AIE or not? + LOGICAL ok_a1lwpdep ! a1 LWP dependent? + + REAL mass_solu_aero(klon, klev) ! total mass concentration for all soluble aerosols [ug m-3] + REAL mass_solu_aero_pi(klon, klev) ! - " - (pre-industrial value) + REAL cdnc(klon, klev) ! cloud droplet number concentration [m-3] + REAL re(klon, klev) ! cloud droplet effective radius [um] + REAL cdnc_pi(klon, klev) ! cloud droplet number concentration [m-3] (pi value) + REAL re_pi(klon, klev) ! cloud droplet effective radius [um] (pi value) + + REAL fl(klon, klev) ! xliq * rneb (denominator to re; fraction of liquid water clouds within the grid cell) + + REAL bl95_b0, bl95_b1 ! Parameter in B&L 95-Formula + + REAL cldtaupi(klon, klev) ! pre-industrial cloud opt thickness for diag +cjq-end +cIM cf. CR:parametres supplementaires + REAL zclear(klon) + REAL zcloud(klon) + +c ************************** +c * * +c * DEBUT PARTIE OPTIMISEE * +c * * +c ************************** + + REAL diff_paprs(klon, klev), zfice1, zfice2(klon, klev) + REAL rad_chaud_tab(klon, klev), zflwp_var, zfiwp_var + +! Abderrahmane oct 2009 + Real reliq(klon, klev), reice(klon, klev) + +c +c Calculer l'epaisseur optique et l'emmissivite des nuages +c +c IM inversion des DO + xflwp = 0.d0 + xfiwp = 0.d0 + xflwc = 0.d0 + xfiwc = 0.d0 + + DO k = 1, klev + DO i = 1, klon + diff_paprs(i,k) = (paprs(i,k)-paprs(i,k+1))/RG + ENDDO + ENDDO + + IF (ok_newmicro) THEN + + + DO k = 1, klev + DO i = 1, klon + zfice2(i,k) = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace) + zfice2(i,k) = MIN(MAX(zfice2(i,k),0.0),1.0) +c IM Total Liquid/Ice water content + xflwc(i,k) = (1.-zfice2(i,k))*pqlwp(i,k) + xfiwc(i,k) = zfice2(i,k)*pqlwp(i,k) +c IM In-Cloud Liquid/Ice water content +c xflwc(i,k) = xflwc(i,k)+(1.-zfice)*pqlwp(i,k)/pclc(i,k) +c xfiwc(i,k) = xfiwc(i,k)+zfice*pqlwp(i,k)/pclc(i,k) + ENDDO + ENDDO + + IF (ok_aie) THEN + DO k = 1, klev + DO i = 1, klon + ! Formula "D" of Boucher and Lohmann, Tellus, 1995 + ! + cdnc(i,k) = 10.**(bl95_b0+bl95_b1* + & log(MAX(mass_solu_aero(i,k),1.e-4))/log(10.))*1.e6 !-m-3 + ! Cloud droplet number concentration (CDNC) is restricted + ! to be within [20, 1000 cm^3] + ! + cdnc(i,k)=MIN(1000.e6,MAX(20.e6,cdnc(i,k))) + ! + ! + cdnc_pi(i,k) = 10.**(bl95_b0+bl95_b1* + & log(MAX(mass_solu_aero_pi(i,k),1.e-4))/log(10.))*1.e6 !-m-3 + cdnc_pi(i,k)=MIN(1000.e6,MAX(20.e6,cdnc_pi(i,k))) + ENDDO + ENDDO + DO k = 1, klev + DO i = 1, klon +! rad_chaud_tab(i,k) = +! & MAX(1.1e6 +! & *((pqlwp(i,k)*pplay(i,k)/(RD * T(i,k))) +! & /(4./3*RPI*1000.*cdnc(i,k)) )**(1./3.),5.) + rad_chaud_tab(i,k) = + & 1.1 + & *((pqlwp(i,k)*pplay(i,k)/(RD * T(i,k))) + & /(4./3*RPI*1000.*cdnc(i,k)) )**(1./3.) + rad_chaud_tab(i,k) = MAX(rad_chaud_tab(i,k) * 1e6, 5.) + ENDDO + ENDDO + ELSE + DO k = 1, MIN(3,klev) + DO i = 1, klon + rad_chaud_tab(i,k) = rad_chau2 + ENDDO + ENDDO + DO k = MIN(3,klev)+1, klev + DO i = 1, klon + rad_chaud_tab(i,k) = rad_chau1 + ENDDO + ENDDO + + ENDIF + + DO k = 1, klev +! IF(.not.ok_aie) THEN + rad_chaud = rad_chau1 + IF (k.LE.3) rad_chaud = rad_chau2 +! ENDIF + DO i = 1, klon + IF (pclc(i,k) .LE. seuil_neb) THEN + +c -- effective cloud droplet radius (microns): + +c for liquid water clouds: + ! For output diagnostics + ! + ! Cloud droplet effective radius [um] + ! + ! we multiply here with f * xl (fraction of liquid water + ! clouds in the grid cell) to avoid problems in the + ! averaging of the output. + ! In the output of IOIPSL, derive the real cloud droplet + ! effective radius as re/fl + ! + + fl(i,k) = seuil_neb*(1.-zfice2(i,k)) + re(i,k) = rad_chaud_tab(i,k)*fl(i,k) + + rel = 0. + rei = 0. + pclc(i,k) = 0.0 + pcltau(i,k) = 0.0 + pclemi(i,k) = 0.0 + cldtaupi(i,k) = 0.0 + ELSE + +c -- liquid/ice cloud water paths: + + zflwp_var= 1000.*(1.-zfice2(i,k))*pqlwp(i,k)/pclc(i,k) + & *diff_paprs(i,k) + zfiwp_var= 1000.*zfice2(i,k)*pqlwp(i,k)/pclc(i,k) + & *diff_paprs(i,k) + +c -- effective cloud droplet radius (microns): + +c for liquid water clouds: + + IF (ok_aie) THEN + radius = + & 1.1 + & *((pqlwp(i,k)*pplay(i,k)/(RD * T(i,k))) + & /(4./3.*RPI*1000.*cdnc_pi(i,k)))**(1./3.) + radius = MAX(radius*1e6, 5.) + + tc = t(i,k)-273.15 + rei = 0.71*tc + 61.29 + if (tc.le.-81.4) rei = 3.5 + if (zflwp_var.eq.0.) radius = 1. + if (zfiwp_var.eq.0. .or. rei.le.0.) rei = 1. + cldtaupi(i,k) = 3.0/2.0 * zflwp_var / radius + & + zfiwp_var * (3.448e-03 + 2.431/rei) + + ENDIF ! ok_aie + ! For output diagnostics + ! + ! Cloud droplet effective radius [um] + ! + ! we multiply here with f * xl (fraction of liquid water + ! clouds in the grid cell) to avoid problems in the + ! averaging of the output. + ! In the output of IOIPSL, derive the real cloud droplet + ! effective radius as re/fl + ! + + fl(i,k) = pclc(i,k)*(1.-zfice2(i,k)) + re(i,k) = rad_chaud_tab(i,k)*fl(i,k) + + rel = rad_chaud_tab(i,k) +c for ice clouds: as a function of the ambiant temperature +c [formula used by Iacobellis and Somerville (2000), with an +c asymptotical value of 3.5 microns at T<-81.4 C added to be +c consistent with observations of Heymsfield et al. 1986]: + tc = t(i,k)-273.15 + rei = 0.71*tc + 61.29 + if (tc.le.-81.4) rei = 3.5 +c -- cloud optical thickness : + +c [for liquid clouds, traditional formula, +c for ice clouds, Ebert & Curry (1992)] + + if (zflwp_var.eq.0.) rel = 1. + if (zfiwp_var.eq.0. .or. rei.le.0.) rei = 1. + pcltau(i,k) = 3.0/2.0 * ( zflwp_var/rel ) + & + zfiwp_var * (3.448e-03 + 2.431/rei) +c -- cloud infrared emissivity: + +c [the broadband infrared absorption coefficient is parameterized +c as a function of the effective cld droplet radius] + +c Ebert and Curry (1992) formula as used by Kiehl & Zender (1995): + k_ice = k_ice0 + 1.0/rei + + pclemi(i,k) = 1.0 + & - EXP( -coef_chau*zflwp_var - DF*k_ice*zfiwp_var) + + ENDIF + reliq(i,k)=rel + reice(i,k)=rei +! if (i.eq.1) then +! print*,'Dans newmicro rel, rei :',rel, rei +! print*,'Dans newmicro reliq, reice :', +! $ reliq(i,k),reice(i,k) +! endif + + ENDDO + ENDDO + + DO k = 1, klev + DO i = 1, klon + xflwp(i) = xflwp(i)+ xflwc(i,k) * diff_paprs(i,k) + xfiwp(i) = xfiwp(i)+ xfiwc(i,k) * diff_paprs(i,k) + ENDDO + ENDDO + + ELSE + DO k = 1, klev + rad_chaud = rad_chau1 + IF (k.LE.3) rad_chaud = rad_chau2 + DO i = 1, klon + + IF (pclc(i,k) .LE. seuil_neb) THEN + + pclc(i,k) = 0.0 + pcltau(i,k) = 0.0 + pclemi(i,k) = 0.0 + cldtaupi(i,k) = 0.0 + + ELSE + + zflwp_var = 1000.*pqlwp(i,k)*diff_paprs(i,k) + & /pclc(i,k) + + zfice1 = MIN( + & MAX( 1.0 - (t(i,k)-t_glace) / (273.13-t_glace) + & ,0.0),1.0)**nexpo + + radius = rad_chaud * (1.-zfice1) + rad_froid * zfice1 + coef = coef_chau * (1.-zfice1) + coef_froi * zfice1 + + pcltau(i,k) = 3.0 * zflwp_var / (2.0 * radius) + pclemi(i,k) = 1.0 - EXP( - coef * zflwp_var) + + ENDIF + + ENDDO + ENDDO + ENDIF + + IF (.NOT.ok_aie) THEN + DO k = 1, klev + DO i = 1, klon + cldtaupi(i,k)=pcltau(i,k) + ENDDO + ENDDO + ENDIF + +ccc DO k = 1, klev +ccc DO i = 1, klon +ccc t(i,k) = t(i,k) +ccc pclc(i,k) = MAX( 1.e-5 , pclc(i,k) ) +ccc lo = pclc(i,k) .GT. (2.*1.e-5) +ccc zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1)) +ccc . /(rg*pclc(i,k)) +ccc zradef = 10.0 + (1.-sigs(k))*45.0 +ccc pcltau(i,k) = 1.5 * zflwp / zradef +ccc zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0) +ccc zmsac = 0.13*(1.0-zfice) + 0.08*zfice +ccc pclemi(i,k) = 1.-EXP(-zmsac*zflwp) +ccc if (.NOT.lo) pclc(i,k) = 0.0 +ccc if (.NOT.lo) pcltau(i,k) = 0.0 +ccc if (.NOT.lo) pclemi(i,k) = 0.0 +ccc ENDDO +ccc ENDDO +ccccc print*, 'pas de nuage dans le rayonnement' +ccccc DO k = 1, klev +ccccc DO i = 1, klon +ccccc pclc(i,k) = 0.0 +ccccc pcltau(i,k) = 0.0 +ccccc pclemi(i,k) = 0.0 +ccccc ENDDO +ccccc ENDDO +C +C COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS +C +c IM cf. CR:test: calcul prenant ou non en compte le recouvrement +c initialisations + DO i=1,klon + zclear(i)=1. + zcloud(i)=0. + pch(i)=1.0 + pcm(i) = 1.0 + pcl(i) = 1.0 + pctlwp(i) = 0.0 + ENDDO +C +cIM cf CR DO k=1,klev + DO k = klev, 1, -1 + DO i = 1, klon + pctlwp(i) = pctlwp(i) + & + pqlwp(i,k)*diff_paprs(i,k) + ENDDO + ENDDO +c IM cf. CR + IF (NOVLP.EQ.1) THEN + DO k = klev, 1, -1 + DO i = 1, klon + zclear(i)=zclear(i)*(1.-MAX(pclc(i,k),zcloud(i))) + & /(1.-MIN(real(zcloud(i), kind=8),1.-ZEPSEC)) + pct(i)=1.-zclear(i) + IF (pplay(i,k).LE.cetahb*paprs(i,1)) THEN + pch(i) = pch(i)*(1.-MAX(pclc(i,k),zcloud(i))) + & /(1.-MIN(real(zcloud(i), kind=8),1.-ZEPSEC)) + ELSE IF (pplay(i,k).GT.cetahb*paprs(i,1) .AND. + & pplay(i,k).LE.cetamb*paprs(i,1)) THEN + pcm(i) = pcm(i)*(1.-MAX(pclc(i,k),zcloud(i))) + & /(1.-MIN(real(zcloud(i), kind=8),1.-ZEPSEC)) + ELSE IF (pplay(i,k).GT.cetamb*paprs(i,1)) THEN + pcl(i) = pcl(i)*(1.-MAX(pclc(i,k),zcloud(i))) + & /(1.-MIN(real(zcloud(i), kind=8),1.-ZEPSEC)) + endif + zcloud(i)=pclc(i,k) + ENDDO + ENDDO + ELSE IF (NOVLP.EQ.2) THEN + DO k = klev, 1, -1 + DO i = 1, klon + zcloud(i)=MAX(pclc(i,k),zcloud(i)) + pct(i)=zcloud(i) + IF (pplay(i,k).LE.cetahb*paprs(i,1)) THEN + pch(i) = MIN(pclc(i,k),pch(i)) + ELSE IF (pplay(i,k).GT.cetahb*paprs(i,1) .AND. + & pplay(i,k).LE.cetamb*paprs(i,1)) THEN + pcm(i) = MIN(pclc(i,k),pcm(i)) + ELSE IF (pplay(i,k).GT.cetamb*paprs(i,1)) THEN + pcl(i) = MIN(pclc(i,k),pcl(i)) + endif + ENDDO + ENDDO + ELSE IF (NOVLP.EQ.3) THEN + DO k = klev, 1, -1 + DO i = 1, klon + zclear(i)=zclear(i)*(1.-pclc(i,k)) + pct(i)=1-zclear(i) + IF (pplay(i,k).LE.cetahb*paprs(i,1)) THEN + pch(i) = pch(i)*(1.0-pclc(i,k)) + ELSE IF (pplay(i,k).GT.cetahb*paprs(i,1) .AND. + & pplay(i,k).LE.cetamb*paprs(i,1)) THEN + pcm(i) = pcm(i)*(1.0-pclc(i,k)) + ELSE IF (pplay(i,k).GT.cetamb*paprs(i,1)) THEN + pcl(i) = pcl(i)*(1.0-pclc(i,k)) + endif + ENDDO + ENDDO + ENDIF + +C + DO i = 1, klon +c IM cf. CR pct(i)=1.-pct(i) + pch(i)=1.-pch(i) + pcm(i)=1.-pcm(i) + pcl(i)=1.-pcl(i) + ENDDO + +C + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/nflxtr.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/nflxtr.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/nflxtr.F90 (revision 1280) @@ -0,0 +1,159 @@ +! +! $Id $ +! +SUBROUTINE nflxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d,pplay,paprs,x,dx) + USE dimphy + IMPLICIT NONE +!===================================================================== +! Objet : Melange convectif de traceurs a partir des flux de masse +! Date : 13/12/1996 -- 13/01/97 +! Auteur: O. Boucher (LOA) sur inspiration de Z. X. Li (LMD), +! Brinkop et Sausen (1996) et Boucher et al. (1996). +! ATTENTION : meme si cette routine se veut la plus generale possible, +! elle a herite de certaines notations et conventions du +! schema de Tiedtke (1993). +! 1. En particulier, les couches sont numerotees de haut en bas !!! +! Ceci est valable pour les flux +! mais pas pour les entrees x, pplay, paprs !!!! +! 2. pmfu est positif, pmfd est negatif +! 3. Tous les flux d'entrainements et de detrainements sont positifs +! contrairement au schema de Tiedtke d'ou les changements de signe!!!! +!===================================================================== +! + include "YOMCST.h" + include "YOECUMF.h" + + REAL,INTENT(IN) :: pdtime ! pdtphys +! +! les flux sont definis au 1/2 niveaux +! => pmfu(klev+1) et pmfd(klev+1) sont implicitement nuls +! + REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfu ! flux de masse dans le panache montant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfd ! flux de masse dans le panache descendant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_u ! flux entraine dans le panache montant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_u ! flux detraine dans le panache montant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_d ! flux entraine dans le panache descendant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_d ! flux detraine dans le panache descendant + + REAL,DIMENSION(klon,klev),INTENT(IN) :: pplay ! pression aux couches (bas en haut) + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs ! pression aux 1/2 couches (bas en haut) + REAL,DIMENSION(klon,klev),INTENT(IN) :: x ! q de traceur (bas en haut) + REAL,DIMENSION(klon,klev),INTENT(INOUT) :: dx ! tendance de traceur (bas en haut) + +! flux convectifs mais en variables locales + REAL,DIMENSION(klon,klev+1) :: zmfu ! copie de pmfu avec klev+1 = 0 + REAL,DIMENSION(klon,klev+1) :: zmfd ! copie de pmfd avec klev+1 = 0 + REAL,DIMENSION(klon,klev) :: zen_u + REAL,DIMENSION(klon,klev) :: zde_u + REAL,DIMENSION(klon,klev) :: zen_d + REAL,DIMENSION(klon,klev) :: zde_d + REAL :: zmfe + +! variables locales +! les flux de x sont definis aux 1/2 niveaux +! xu et xd sont definis aux niveaux complets + REAL,DIMENSION(klon,klev) :: xu ! q de traceurs dans le panache montant + REAL,DIMENSION(klon,klev) :: xd ! q de traceurs dans le panache descendant + REAL,DIMENSION(klon,klev+1) :: zmfux ! flux de x dans le panache montant + REAL,DIMENSION(klon,klev+1) :: zmfdx ! flux de x dans le panache descendant + REAL,DIMENSION(klon,klev+1) :: zmfex ! flux de x dans l'environnement + INTEGER :: i, k + REAL,PARAMETER :: zmfmin=1.E-10 + +! ============================================== +! Extension des flux UP et DN sur klev+1 niveaux +! ============================================== + DO k=1,klev + DO i=1,klon + zmfu(i,k)=pmfu(i,k) + zmfd(i,k)=pmfd(i,k) + ENDDO + ENDDO + DO i=1,klon + zmfu(i,klev+1)=0. + zmfd(i,klev+1)=0. + ENDDO +! ========================================== +! modif pour diagnostiquer les detrainements +! ========================================== +! on privilegie l'ajustement de l'entrainement dans l'ascendance. + + DO k=1, klev + DO i=1, klon + zen_d(i,k)=pen_d(i,k) + zde_u(i,k)=pde_u(i,k) + zde_d(i,k) =-zmfd(i,k+1)+zmfd(i,k)+zen_d(i,k) + zen_u(i,k) = zmfu(i,k+1)-zmfu(i,k)+zde_u(i,k) + ENDDO + ENDDO +! ========================================= +! calcul des flux dans le panache montant +! ========================================= +! +! Dans la premiere couche, on prend q comme valeur de qu + + DO i=1, klon + zmfux(i,1)=0.0 + ENDDO + +! Autres couches + DO k=1,klev + DO i=1, klon + IF ((zmfu(i,k+1)+zde_u(i,k)).lt.zmfmin) THEN + xu(i,k)=x(i,k) + ELSE + xu(i,k)=(zmfux(i,k)+zen_u(i,k)*x(i,k))/(zmfu(i,k+1)+zde_u(i,k)) + ENDIF + zmfux(i,k+1)=zmfu(i,k+1)*xu(i,k) + ENDDO + ENDDO +! ========================================== +! calcul des flux dans le panache descendant +! ========================================== + + DO i=1, klon + zmfdx(i,klev+1)=0.0 + ENDDO + + DO k=klev,1,-1 + DO i=1, klon + IF ((zde_d(i,k)-zmfd(i,k)).lt.zmfmin) THEN + xd(i,k)=x(i,k) + ELSE + xd(i,k)=(zmfdx(i,k+1)-zen_d(i,k)*x(i,k))/(zmfd(i,k)-zde_d(i,k)) + ENDIF + zmfdx(i,k)=zmfd(i,k)*xd(i,k) + ENDDO + ENDDO +! =================================================== +! introduction du flux de retour dans l'environnement +! =================================================== + + DO k=2, klev + DO i=1, klon + zmfe=-zmfu(i,k)-zmfd(i,k) + IF (zmfe.le.0.) then + zmfex(i,k)= zmfe*x(i,k) + ELSE + zmfex(i,k)= zmfe*x(i,k-1) + ENDIF + ENDDO + ENDDO + + DO i=1, klon + zmfex(i,1)=0. + zmfex(i,klev+1)=0. + ENDDO +! ========================== +! calcul final des tendances +! ========================== + DO k=1, klev + DO i=1, klon + dx(i,k)=RG/(paprs(i,k)-paprs(i,k+1))*pdtime* & + ( zmfux(i,k) - zmfux(i,k+1) + & + zmfdx(i,k) - zmfdx(i,k+1) + & + zmfex(i,k) - zmfex(i,k+1) ) + ENDDO + ENDDO + +END SUBROUTINE nflxtr Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/nonlocal.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/nonlocal.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/nonlocal.F (revision 1280) @@ -0,0 +1,415 @@ +! +! $Header$ +! +C====================================================================== + SUBROUTINE nonlocal(knon, paprs, pplay, + . tsol,beta,u,v,t,q, + . cd_h, cd_m, pcfh, pcfm, cgh, cgq) + USE dimphy + IMPLICIT none +c====================================================================== +c Laurent Li (LMD/CNRS), le 30 septembre 1998 +c Couche limite non-locale. Adaptation du code du CCM3. +c Code non teste, donc a ne pas utiliser. +c====================================================================== +c Nonlocal scheme that determines eddy diffusivities based on a +c diagnosed boundary layer height and a turbulent velocity scale. +c Also countergradient effects for heat and moisture are included. +c +c For more information, see Holtslag, A.A.M., and B.A. Boville, 1993: +c Local versus nonlocal boundary-layer diffusion in a global climate +c model. J. of Climate, vol. 6, 1825-1842. +c====================================================================== +#include "YOMCST.h" +#include "iniprint.h" +c +c Arguments: +c + INTEGER knon ! nombre de points a calculer + REAL tsol(klon) ! temperature du sol (K) + REAL beta(klon) ! efficacite d'evaporation (entre 0 et 1) + REAL paprs(klon,klev+1) ! pression a inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) + REAL u(klon,klev) ! vitesse U (m/s) + REAL v(klon,klev) ! vitesse V (m/s) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! vapeur d'eau (kg/kg) + REAL cd_h(klon) ! coefficient de friction au sol pour chaleur + REAL cd_m(klon) ! coefficient de friction au sol pour vitesse +c + INTEGER isommet + REAL vk + PARAMETER (vk=0.40) + REAL ricr + PARAMETER (ricr=0.4) + REAL fak + PARAMETER (fak=8.5) + REAL fakn + PARAMETER (fakn=7.2) + REAL onet + PARAMETER (onet=1.0/3.0) + REAL t_coup + PARAMETER(t_coup=273.15) + REAL zkmin + PARAMETER (zkmin=0.01) + REAL betam + PARAMETER (betam=15.0) + REAL betah + PARAMETER (betah=15.0) + REAL betas + PARAMETER (betas=5.0) + REAL sffrac + PARAMETER (sffrac=0.1) + REAL binm + PARAMETER (binm=betam*sffrac) + REAL binh + PARAMETER (binh=betah*sffrac) + REAL ccon + PARAMETER (ccon=fak*sffrac*vk) +c + REAL z(klon,klev) + REAL pcfm(klon,klev), pcfh(klon,klev) +c + INTEGER i, k + REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy + REAL zx_alf1, zx_alf2 ! parametres pour extrapolation + REAL khfs(klon) ! surface kinematic heat flux [mK/s] + REAL kqfs(klon) ! sfc kinematic constituent flux [m/s] + REAL heatv(klon) ! surface virtual heat flux + REAL ustar(klon) + REAL rino(klon,klev) ! bulk Richardon no. from level to ref lev + LOGICAL unstbl(klon) ! pts w/unstbl pbl (positive virtual ht flx) + LOGICAL stblev(klon) ! stable pbl with levels within pbl + LOGICAL unslev(klon) ! unstbl pbl with levels within pbl + LOGICAL unssrf(klon) ! unstb pbl w/lvls within srf pbl lyr + LOGICAL unsout(klon) ! unstb pbl w/lvls in outer pbl lyr + LOGICAL check(klon) ! True=>chk if Richardson no.>critcal + REAL pblh(klon) + REAL cgh(klon,2:klev) ! counter-gradient term for heat [K/m] + REAL cgq(klon,2:klev) ! counter-gradient term for constituents + REAL cgs(klon,2:klev) ! counter-gradient star (cg/flux) + REAL obklen(klon) + REAL ztvd, ztvu, zdu2 + REAL therm(klon) ! thermal virtual temperature excess + REAL phiminv(klon) ! inverse phi function for momentum + REAL phihinv(klon) ! inverse phi function for heat + REAL wm(klon) ! turbulent velocity scale for momentum + REAL fak1(klon) ! k*ustar*pblh + REAL fak2(klon) ! k*wm*pblh + REAL fak3(klon) ! fakn*wstr/wm + REAL pblk(klon) ! level eddy diffusivity for momentum + REAL pr(klon) ! Prandtl number for eddy diffusivities + REAL zl(klon) ! zmzp / Obukhov length + REAL zh(klon) ! zmzp / pblh + REAL zzh(klon) ! (1-(zmzp/pblh))**2 + REAL wstr(klon) ! w*, convective velocity scale + REAL zm(klon) ! current level height + REAL zp(klon) ! current level height + one level up + REAL zcor, zdelta, zcvm5, zxqs + REAL fac, pblmin, zmzp, term +c +#include "YOETHF.h" +#include "FCTTRE.h" +c +c Initialisation +c + isommet=klev + + DO i = 1, klon + pcfh(i,1) = cd_h(i) + pcfm(i,1) = cd_m(i) + ENDDO + DO k = 2, klev + DO i = 1, klon + pcfh(i,k) = zkmin + pcfm(i,k) = zkmin + cgs(i,k) = 0.0 + cgh(i,k) = 0.0 + cgq(i,k) = 0.0 + ENDDO + ENDDO +c +c Calculer les hauteurs de chaque couche +c + DO i = 1, knon + z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) + . * (paprs(i,1)-pplay(i,1)) / RG + ENDDO + DO k = 2, klev + DO i = 1, knon + z(i,k) = z(i,k-1) + . + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) + . * (pplay(i,k-1)-pplay(i,k)) / RG + ENDDO + ENDDO +c + DO i = 1, knon + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-tsol(i))) + zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta + zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1)) + zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1) + zxqs=MIN(0.5,zxqs) + zcor=1./(1.-retv*zxqs) + zxqs=zxqs*zcor + ELSE + IF (tsol(i).LT.t_coup) THEN + zxqs = qsats(tsol(i)) / paprs(i,1) + ELSE + zxqs = qsatl(tsol(i)) / paprs(i,1) + ENDIF + ENDIF + zx_alf1 = 1.0 + zx_alf2 = 1.0 - zx_alf1 + zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1))) + . *(1.+RETV*q(i,1))*zx_alf1 + . + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2))) + . *(1.+RETV*q(i,2))*zx_alf2 + zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2 + zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2 + zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2 + zxmod = 1.0+SQRT(zxu**2+zxv**2) + khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i) + kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i) + heatv(i) = khfs(i) + 0.61*zxt*kqfs(i) + taux = zxu *zxmod*cd_m(i) + tauy = zxv *zxmod*cd_m(i) + ustar(i) = SQRT(taux**2+tauy**2) + ustar(i) = MAX(SQRT(ustar(i)),0.01) + ENDDO +c + DO i = 1, knon + rino(i,1) = 0.0 + check(i) = .TRUE. + pblh(i) = z(i,1) + obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i)) + ENDDO + +C +C PBL height calculation: +C Search for level of pbl. Scan upward until the Richardson number between +C the first level and the current level exceeds the "critical" value. +C + fac = 100.0 + DO k = 1, isommet + DO i = 1, knon + IF (check(i)) THEN + zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2 + zdu2 = max(zdu2,1.0e-20) + ztvd =(t(i,k)+z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,k))) + . *(1.+RETV*q(i,k)) + ztvu =(t(i,1)-z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1))) + . *(1.+RETV*q(i,1)) + rino(i,k) = (z(i,k)-z(i,1))*RG*(ztvd-ztvu) + . /(zdu2*0.5*(ztvd+ztvu)) + IF (rino(i,k).GE.ricr) THEN + pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) * + . (ricr-rino(i,k-1))/(rino(i,k-1)-rino(i,k)) + check(i) = .FALSE. + ENDIF + ENDIF + ENDDO + ENDDO + +C +C Set pbl height to maximum value where computation exceeds number of +C layers allowed +C + DO i = 1, knon + if (check(i)) pblh(i) = z(i,isommet) + ENDDO +C +C Improve estimate of pbl height for the unstable points. +C Find unstable points (sensible heat flux is upward): +C + DO i = 1, knon + IF (heatv(i) .GT. 0.) THEN + unstbl(i) = .TRUE. + check(i) = .TRUE. + ELSE + unstbl(i) = .FALSE. + check(i) = .FALSE. + ENDIF + ENDDO +C +C For the unstable case, compute velocity scale and the +C convective temperature excess: +C + DO i = 1, knon + IF (check(i)) THEN + phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet + wm(i)= ustar(i)*phiminv(i) + therm(i) = heatv(i)*fak/wm(i) + rino(i,1) = 0.0 + ENDIF + ENDDO +C +C Improve pblh estimate for unstable conditions using the +C convective temperature excess: +C + DO k = 1, isommet + DO i = 1, knon + IF (check(i)) THEN + zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2 + zdu2 = max(zdu2,1.0e-20) + ztvd =(t(i,k)+z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,k))) + . *(1.+RETV*q(i,k)) + ztvu =(t(i,1)+therm(i)-z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1))) + . *(1.+RETV*q(i,1)) + rino(i,k) = (z(i,k)-z(i,1))*RG*(ztvd-ztvu) + . /(zdu2*0.5*(ztvd+ztvu)) + IF (rino(i,k).GE.ricr) THEN + pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) * + . (ricr-rino(i,k-1))/(rino(i,k-1)-rino(i,k)) + check(i) = .FALSE. + ENDIF + ENDIF + ENDDO + ENDDO +C +C Set pbl height to maximum value where computation exceeds number of +C layers allowed +C + DO i = 1, knon + if (check(i)) pblh(i) = z(i,isommet) + ENDDO +C +C Points for which pblh exceeds number of pbl layers allowed; +C set to maximum +C + DO i = 1, knon + IF (check(i)) pblh(i) = z(i,isommet) + ENDDO +C +C PBL height must be greater than some minimum mechanical mixing depth +C Several investigators have proposed minimum mechanical mixing depth +C relationships as a function of the local friction velocity, u*. We +C make use of a linear relationship of the form h = c u* where c=700. +C The scaling arguments that give rise to this relationship most often +C represent the coefficient c as some constant over the local coriolis +C parameter. Here we make use of the experimental results of Koracin +C and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f +C where f was evaluated at 39.5 N and 52 N. Thus we use a typical mid +C latitude value for f so that c = 0.07/f = 700. +C + DO i = 1, knon + pblmin = 700.0*ustar(i) + pblh(i) = MAX(pblh(i),pblmin) + ENDDO +C +C pblh is now available; do preparation for diffusivity calculation: +C + DO i = 1, knon + pblk(i) = 0.0 + fak1(i) = ustar(i)*pblh(i)*vk +C +C Do additional preparation for unstable cases only, set temperature +C and moisture perturbations depending on stability. +C + IF (unstbl(i)) THEN + zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1))) + . *(1.+RETV*q(i,1)) + phiminv(i) = (1. - binm*pblh(i)/obklen(i))**onet + phihinv(i) = sqrt(1. - binh*pblh(i)/obklen(i)) + wm(i) = ustar(i)*phiminv(i) + fak2(i) = wm(i)*pblh(i)*vk + wstr(i) = (heatv(i)*RG*pblh(i)/zxt)**onet + fak3(i) = fakn*wstr(i)/wm(i) + ENDIF + ENDDO + +C Main level loop to compute the diffusivities and +C counter-gradient terms: +C + DO 1000 k = 2, isommet +C +C Find levels within boundary layer: +C + DO i = 1, knon + unslev(i) = .FALSE. + stblev(i) = .FALSE. + zm(i) = z(i,k-1) + zp(i) = z(i,k) + IF (zkmin.EQ.0.0 .AND. zp(i).GT.pblh(i)) zp(i) = pblh(i) + IF (zm(i) .LT. pblh(i)) THEN + zmzp = 0.5*(zm(i) + zp(i)) + zh(i) = zmzp/pblh(i) + zl(i) = zmzp/obklen(i) + zzh(i) = 0. + IF (zh(i).LE.1.0) zzh(i) = (1. - zh(i))**2 +C +C stblev for points zm < plbh and stable and neutral +C unslev for points zm < plbh and unstable +C + IF (unstbl(i)) THEN + unslev(i) = .TRUE. + ELSE + stblev(i) = .TRUE. + ENDIF + ENDIF + ENDDO +C +C Stable and neutral points; set diffusivities; counter-gradient +C terms zero for stable case: +C + DO i = 1, knon + IF (stblev(i)) THEN + IF (zl(i).LE.1.) THEN + pblk(i) = fak1(i)*zh(i)*zzh(i)/(1. + betas*zl(i)) + ELSE + pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas + zl(i)) + ENDIF + pcfm(i,k) = pblk(i) + pcfh(i,k) = pcfm(i,k) + ENDIF + ENDDO +C +C unssrf, unstable within surface layer of pbl +C unsout, unstable within outer layer of pbl +C + DO i = 1, knon + unssrf(i) = .FALSE. + unsout(i) = .FALSE. + IF (unslev(i)) THEN + IF (zh(i).lt.sffrac) THEN + unssrf(i) = .TRUE. + ELSE + unsout(i) = .TRUE. + ENDIF + ENDIF + ENDDO +C +C Unstable for surface layer; counter-gradient terms zero +C + DO i = 1, knon + IF (unssrf(i)) THEN + term = (1. - betam*zl(i))**onet + pblk(i) = fak1(i)*zh(i)*zzh(i)*term + pr(i) = term/sqrt(1. - betah*zl(i)) + ENDIF + ENDDO +C +C Unstable for outer layer; counter-gradient terms non-zero: +C + DO i = 1, knon + IF (unsout(i)) THEN + pblk(i) = fak2(i)*zh(i)*zzh(i) + cgs(i,k) = fak3(i)/(pblh(i)*wm(i)) + cgh(i,k) = khfs(i)*cgs(i,k) + pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak + cgq(i,k) = kqfs(i)*cgs(i,k) + ENDIF + ENDDO +C +C For all unstable layers, set diffusivities +C + DO i = 1, knon + IF (unslev(i)) THEN + pcfm(i,k) = pblk(i) + pcfh(i,k) = pblk(i)/pr(i) + ENDIF + ENDDO + 1000 continue ! end of level loop + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/nuage.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/nuage.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/nuage.F (revision 1280) @@ -0,0 +1,408 @@ +! $Id$ +! + SUBROUTINE nuage (paprs, pplay, + . t, pqlwp, pclc, pcltau, pclemi, + . pch, pcl, pcm, pct, pctlwp, + e ok_aie, + e mass_solu_aero, mass_solu_aero_pi, + e bl95_b0, bl95_b1, + s cldtaupi, re, fl) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910 +c Objet: Calculer epaisseur optique et emmissivite des nuages +c====================================================================== +c Arguments: +c t-------input-R-temperature +c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg) +c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1) +c ok_aie--input-L-apply aerosol indirect effect or not +c mass_solu_aero-----input-R-total mass concentration for all soluble aerosols[ug/m^3] +c mass_solu_aero_pi--input-R-dito, pre-industrial value +c bl95_b0-input-R-a parameter, may be varied for tests (s-sea, l-land) +c bl95_b1-input-R-a parameter, may be varied for tests ( -"- ) +c +c cldtaupi-output-R-pre-industrial value of cloud optical thickness, +c needed for the diagnostics of the aerosol indirect +c radiative forcing (see radlwsw) +c re------output-R-Cloud droplet effective radius multiplied by fl [um] +c fl------output-R-Denominator to re, introduced to avoid problems in +c the averaging of the output. fl is the fraction of liquid +c water clouds within a grid cell +c +c pcltau--output-R-epaisseur optique des nuages +c pclemi--output-R-emissivite des nuages (0 a 1) +c====================================================================== +C +#include "YOMCST.h" +c +cym#include "dimensions.h" +cym#include "dimphy.h" + REAL paprs(klon,klev+1), pplay(klon,klev) + REAL t(klon,klev) +c + REAL pclc(klon,klev) + REAL pqlwp(klon,klev) + REAL pcltau(klon,klev), pclemi(klon,klev) +c + REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon) +c + LOGICAL lo +c + REAL cetahb, cetamb + PARAMETER (cetahb = 0.45, cetamb = 0.80) +C + INTEGER i, k + REAL zflwp, zradef, zfice, zmsac +c + REAL radius, rad_froid, rad_chaud, rad_chau1, rad_chau2 + PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0) +ccc PARAMETER (rad_chaud=15.0, rad_froid=35.0) +c sintex initial PARAMETER (rad_chaud=10.0, rad_froid=30.0) + REAL coef, coef_froi, coef_chau + PARAMETER (coef_chau=0.13, coef_froi=0.09) + REAL seuil_neb, t_glace + PARAMETER (seuil_neb=0.001, t_glace=273.0-15.0) + INTEGER nexpo ! exponentiel pour glace/eau + PARAMETER (nexpo=6) + +cjq for the aerosol indirect effect +cjq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003 +cjq + LOGICAL ok_aie ! Apply AIE or not? + + REAL mass_solu_aero(klon, klev) ! total mass concentration for all soluble aerosols[ug m-3] + REAL mass_solu_aero_pi(klon, klev) ! - " - pre-industrial value + REAL cdnc(klon, klev) ! cloud droplet number concentration [m-3] + REAL re(klon, klev) ! cloud droplet effective radius [um] + REAL cdnc_pi(klon, klev) ! cloud droplet number concentration [m-3] (pi value) + REAL re_pi(klon, klev) ! cloud droplet effective radius [um] (pi value) + + REAL fl(klon, klev) ! xliq * rneb (denominator to re; fraction of liquid water clouds within the grid cell) + + REAL bl95_b0, bl95_b1 ! Parameter in B&L 95-Formula + + REAL cldtaupi(klon, klev) ! pre-industrial cloud opt thickness for diag +cjq-end + +ccc PARAMETER (nexpo=1) +c +c Calculer l'epaisseur optique et l'emmissivite des nuages +c + DO k = 1, klev + DO i = 1, klon + rad_chaud = rad_chau1 + IF (k.LE.3) rad_chaud = rad_chau2 + + pclc(i,k) = MAX(pclc(i,k), seuil_neb) + zflwp = 1000.*pqlwp(i,k)/RG/pclc(i,k) + . *(paprs(i,k)-paprs(i,k+1)) + zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace) + zfice = MIN(MAX(zfice,0.0),1.0) + zfice = zfice**nexpo + + IF (ok_aie) THEN + ! Formula "D" of Boucher and Lohmann, Tellus, 1995 + ! + cdnc(i,k) = 10.**(bl95_b0+bl95_b1* + . log(MAX(mass_solu_aero(i,k),1.e-4))/log(10.))*1.e6 !-m-3 + ! Cloud droplet number concentration (CDNC) is restricted + ! to be within [20, 1000 cm^3] + ! + cdnc(i,k)=MIN(1000.e6,MAX(20.e6,cdnc(i,k))) + cdnc_pi(i,k) = 10.**(bl95_b0+bl95_b1* + . log(MAX(mass_solu_aero_pi(i,k),1.e-4))/log(10.))*1.e6 !-m-3 + cdnc_pi(i,k)=MIN(1000.e6,MAX(20.e6,cdnc_pi(i,k))) + ! + ! + ! air density: pplay(i,k) / (RD * zT(i,k)) + ! factor 1.1: derive effective radius from volume-mean radius + ! factor 1000 is the water density + ! _chaud means that this is the CDR for liquid water clouds + ! + rad_chaud = + . 1.1 * ( (pqlwp(i,k) * pplay(i,k) / (RD * T(i,k)) ) + . / (4./3. * RPI * 1000. * cdnc(i,k)) )**(1./3.) + ! + ! Convert to um. CDR shall be at least 3 um. + ! + rad_chaud = MAX(rad_chaud*1.e6, 3.) + + ! For output diagnostics + ! + ! Cloud droplet effective radius [um] + ! + ! we multiply here with f * xl (fraction of liquid water + ! clouds in the grid cell) to avoid problems in the + ! averaging of the output. + ! In the output of IOIPSL, derive the real cloud droplet + ! effective radius as re/fl + ! + fl(i,k) = pclc(i,k)*(1.-zfice) + re(i,k) = rad_chaud*fl(i,k) + + ! Pre-industrial cloud opt thickness + ! + ! "radius" is calculated as rad_chaud above (plus the + ! ice cloud contribution) but using cdnc_pi instead of + ! cdnc. + radius = MAX(1.1e6 * ( (pqlwp(i,k)*pplay(i,k)/(RD*T(i,k))) + . / (4./3.*RPI*1000.*cdnc_pi(i,k)) )**(1./3.), + . 3.) * (1.-zfice) + rad_froid * zfice + cldtaupi(i,k) = 3.0/2.0 * zflwp / radius + . + ENDIF ! ok_aie + + radius = rad_chaud * (1.-zfice) + rad_froid * zfice + coef = coef_chau * (1.-zfice) + coef_froi * zfice + pcltau(i,k) = 3.0/2.0 * zflwp / radius + pclemi(i,k) = 1.0 - EXP( - coef * zflwp) + lo = (pclc(i,k) .LE. seuil_neb) + IF (lo) pclc(i,k) = 0.0 + IF (lo) pcltau(i,k) = 0.0 + IF (lo) pclemi(i,k) = 0.0 + + IF (.NOT.ok_aie) cldtaupi(i,k)=pcltau(i,k) + ENDDO + ENDDO +ccc DO k = 1, klev +ccc DO i = 1, klon +ccc t(i,k) = t(i,k) +ccc pclc(i,k) = MAX( 1.e-5 , pclc(i,k) ) +ccc lo = pclc(i,k) .GT. (2.*1.e-5) +ccc zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1)) +ccc . /(rg*pclc(i,k)) +ccc zradef = 10.0 + (1.-sigs(k))*45.0 +ccc pcltau(i,k) = 1.5 * zflwp / zradef +ccc zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0) +ccc zmsac = 0.13*(1.0-zfice) + 0.08*zfice +ccc pclemi(i,k) = 1.-EXP(-zmsac*zflwp) +ccc if (.NOT.lo) pclc(i,k) = 0.0 +ccc if (.NOT.lo) pcltau(i,k) = 0.0 +ccc if (.NOT.lo) pclemi(i,k) = 0.0 +ccc ENDDO +ccc ENDDO +cccccc print*, 'pas de nuage dans le rayonnement' +cccccc DO k = 1, klev +cccccc DO i = 1, klon +cccccc pclc(i,k) = 0.0 +cccccc pcltau(i,k) = 0.0 +cccccc pclemi(i,k) = 0.0 +cccccc ENDDO +cccccc ENDDO +C +C COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS +C + DO i = 1, klon + pct(i)=1.0 + pch(i)=1.0 + pcm(i) = 1.0 + pcl(i) = 1.0 + pctlwp(i) = 0.0 + ENDDO +C + DO k = klev, 1, -1 + DO i = 1, klon + pctlwp(i) = pctlwp(i) + . + pqlwp(i,k)*(paprs(i,k)-paprs(i,k+1))/RG + pct(i) = pct(i)*(1.0-pclc(i,k)) + if (pplay(i,k).LE.cetahb*paprs(i,1)) + . pch(i) = pch(i)*(1.0-pclc(i,k)) + if (pplay(i,k).GT.cetahb*paprs(i,1) .AND. + . pplay(i,k).LE.cetamb*paprs(i,1)) + . pcm(i) = pcm(i)*(1.0-pclc(i,k)) + if (pplay(i,k).GT.cetamb*paprs(i,1)) + . pcl(i) = pcl(i)*(1.0-pclc(i,k)) + ENDDO + ENDDO +C + DO i = 1, klon + pct(i)=1.-pct(i) + pch(i)=1.-pch(i) + pcm(i)=1.-pcm(i) + pcl(i)=1.-pcl(i) + ENDDO +C + RETURN + END + SUBROUTINE diagcld1(paprs,pplay,rain,snow,kbot,ktop, + . diafra,dialiq) + use dimphy + IMPLICIT none +c +c Laurent Li (LMD/CNRS), le 12 octobre 1998 +c (adaptation du code ECMWF) +c +c Dans certains cas, le schema pronostique des nuages n'est +c pas suffisament performant. On a donc besoin de diagnostiquer +c ces nuages. Je dois avouer que c'est une frustration. +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c Arguments d'entree: + REAL paprs(klon,klev+1) ! pression (Pa) a inter-couche + REAL pplay(klon,klev) ! pression (Pa) au milieu de couche + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (Kg/Kg) + REAL rain(klon) ! pluie convective (kg/m2/s) + REAL snow(klon) ! neige convective (kg/m2/s) + INTEGER ktop(klon) ! sommet de la convection + INTEGER kbot(klon) ! bas de la convection +c +c Arguments de sortie: + REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee + REAL dialiq(klon,klev) ! eau liquide nuageuse +c +c Constantes ajustables: + REAL CANVA, CANVB, CANVH + PARAMETER (CANVA=2.0, CANVB=0.3, CANVH=0.4) + REAL CCA, CCB, CCC + PARAMETER (CCA=0.125, CCB=1.5, CCC=0.8) + REAL CCFCT, CCSCAL + PARAMETER (CCFCT=0.400) + PARAMETER (CCSCAL=1.0E+11) + REAL CETAHB, CETAMB + PARAMETER (CETAHB=0.45, CETAMB=0.80) + REAL CCLWMR + PARAMETER (CCLWMR=1.E-04) + REAL ZEPSCR + PARAMETER (ZEPSCR=1.0E-10) +c +c Variables locales: + INTEGER i, k + REAL zcc(klon) +c +c Initialisation: +c + DO k = 1, klev + DO i = 1, klon + diafra(i,k) = 0.0 + dialiq(i,k) = 0.0 + ENDDO + ENDDO +c + DO i = 1, klon ! Calculer la fraction nuageuse + zcc(i) = 0.0 + IF((rain(i)+snow(i)).GT.0.) THEN + zcc(i)= CCA * LOG(MAX(ZEPSCR,(rain(i)+snow(i))*CCSCAL))-CCB + zcc(i)= MIN(CCC,MAX(0.0,zcc(i))) + ENDIF + ENDDO +c + DO i = 1, klon ! pour traiter les enclumes + diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),zcc(i)*CCFCT) + IF ((zcc(i).GE.CANVH) .AND. + . (pplay(i,ktop(i)).LE.CETAHB*paprs(i,1))) + . diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)), + . MAX(zcc(i)*CCFCT,CANVA*(zcc(i)-CANVB))) + dialiq(i,ktop(i))=CCLWMR*diafra(i,ktop(i)) + ENDDO +c + DO k = 1, klev ! nuages convectifs (sauf enclumes) + DO i = 1, klon + IF (k.LT.ktop(i) .AND. k.GE.kbot(i)) THEN + diafra(i,k)=MAX(diafra(i,k),zcc(i)*CCFCT) + dialiq(i,k)=CCLWMR*diafra(i,k) + ENDIF + ENDDO + ENDDO +c + RETURN + END + SUBROUTINE diagcld2(paprs,pplay,t,q, diafra,dialiq) + use dimphy + IMPLICIT none +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c Arguments d'entree: + REAL paprs(klon,klev+1) ! pression (Pa) a inter-couche + REAL pplay(klon,klev) ! pression (Pa) au milieu de couche + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (Kg/Kg) +c +c Arguments de sortie: + REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee + REAL dialiq(klon,klev) ! eau liquide nuageuse +c + REAL CETAMB + PARAMETER (CETAMB=0.80) + REAL CLOIA, CLOIB, CLOIC, CLOID + PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.6, CLOID=5.0) +ccc PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.9, CLOID=5.0) + REAL RGAMMAS + PARAMETER (RGAMMAS=0.05) + REAL CRHL + PARAMETER (CRHL=0.15) +ccc PARAMETER (CRHL=0.70) + REAL t_coup + PARAMETER (t_coup=234.0) +c +c Variables locales: + INTEGER i, k, kb, invb(klon) + REAL zqs, zrhb, zcll, zdthmin(klon), zdthdp + REAL zdelta, zcor +c +c Fonctions thermodynamiques: +#include "YOETHF.h" +#include "FCTTRE.h" +c +c Initialisation: +c + DO k = 1, klev + DO i = 1, klon + diafra(i,k) = 0.0 + dialiq(i,k) = 0.0 + ENDDO + ENDDO +c + DO i = 1, klon + invb(i) = klev + zdthmin(i)=0.0 + ENDDO + + DO k = 2, klev/2-1 + DO i = 1, klon + zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) + . - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1) + zdthdp = zdthdp * CLOIA + IF (pplay(i,k).GT.CETAMB*paprs(i,1) .AND. + . zdthdp.LT.zdthmin(i) ) THEN + zdthmin(i) = zdthdp + invb(i) = k + ENDIF + ENDDO + ENDDO + + DO i = 1, klon + kb=invb(i) + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-t(i,kb))) + zqs= R2ES*FOEEW(t(i,kb),zdelta)/pplay(i,kb) + zqs=MIN(0.5,zqs) + zcor=1./(1.-RETV*zqs) + zqs=zqs*zcor + ELSE + IF (t(i,kb) .LT. t_coup) THEN + zqs = qsats(t(i,kb)) / pplay(i,kb) + ELSE + zqs = qsatl(t(i,kb)) / pplay(i,kb) + ENDIF + ENDIF + zcll = CLOIB * zdthmin(i) + CLOIC + zcll = MIN(1.0,MAX(0.0,zcll)) + zrhb= q(i,kb)/zqs + IF (zcll.GT.0.0.AND.zrhb.LT.CRHL) + . zcll=zcll*(1.-(CRHL-zrhb)*CLOID) + zcll=MIN(1.0,MAX(0.0,zcll)) + diafra(i,kb) = MAX(diafra(i,kb),zcll) + dialiq(i,kb)= diafra(i,kb) * RGAMMAS*zqs + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/nuage.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/nuage.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/nuage.h (revision 1280) @@ -0,0 +1,7 @@ +! +! $Header$ +! + REAL rad_froid, rad_chau1, rad_chau2 + + common /nuagecom/ rad_froid,rad_chau1, rad_chau2 +!$OMP THREADPRIVATE(/nuagecom/) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/o3cm.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/o3cm.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/o3cm.F (revision 1280) @@ -0,0 +1,61 @@ +! +! $Header$ +! + SUBROUTINE o3cm (amb, bmb, sortie, ntab) + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: Ce programme calcule le contenu en ozone "sortie" +c (unite: cm.atm) entre deux niveaux "amb" et "bmb" (unite: mb) +c "ntab" est le nombre d'intervalles pour l'integration, sa +c valeur depend bien sur de l'epaisseur de la couche et de +c la precision qu'on souhaite a obtenir +c====================================================================== + REAL amb, bmb, sortie + INTEGER ntab +c====================================================================== + INTEGER n + REAL xtab(500), xa, xb, ya, yb, xincr +c====================================================================== + external mbtozm +c====================================================================== +c la fonction en ligne w(x) donne le profil de l'ozone en fonction +c de l'altitude (unite: cm.atm / km) +c (Green 1964, Appl. Opt. 3: 203-208) + REAL wp, xp, h, x, w, con + PARAMETER (wp=0.218, xp=23.25, h=4.63, con=1.0) + w(x) = wp/h * EXP((x-xp)/h)/ (con+EXP((x-xp)/h))**2 +c====================================================================== + IF (ntab .GT. 499) STOP 'BIG ntab' + xincr = (bmb-amb) / FLOAT(ntab) + xtab(1) = amb + DO n = 2, ntab + xtab(n) = xtab(n-1) + xincr + ENDDO + xtab(ntab+1) = bmb + sortie = 0.0 + DO n = 1, ntab + CALL mbtozm(xtab(n), xa) + CALL mbtozm(xtab(n+1), xb) + xa = xa / 1000. + xb = xb / 1000. + ya = w(xa) + yb = w(xb) + sortie = sortie + (ya+yb)/2.0 * ABS(xb-xa) + ENDDO + RETURN + END + SUBROUTINE mbtozm(rmb,zm) + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) +c Objet: transformer une hauteur de mb (rmb) en metre (zm) +c====================================================================== + REAL rmb, zm +c====================================================================== + REAL gama, tzero, pzero, g, r + PARAMETER (gama=6.5e-3, tzero=288., pzero=1013.25) + PARAMETER (g=9.81, r=287.0) + zm = tzero/gama * ( 1.-(rmb/pzero)**(r*gama/g) ) + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/oasis.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/oasis.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/oasis.F90 (revision 1280) @@ -0,0 +1,457 @@ +! +MODULE oasis +! +! This module contains subroutines for initialization, sending and receiving +! towards the coupler OASIS3. It also contains some parameters for the coupling. +! +! This module should always be compiled. With the coupler OASIS3 available the cpp key +! CPP_COUPLE should be set and the entier of this file will then be compiled. +! In a forced mode CPP_COUPLE should not be defined and the compilation ends before +! the CONTAINS, without compiling the subroutines. +! + USE dimphy + USE mod_phys_lmdz_para + USE write_field_phy + +#ifdef CPP_COUPLE + USE mod_prism_proto + USE mod_prism_def_partition_proto + USE mod_prism_get_proto + USE mod_prism_put_proto +#endif + + IMPLICIT NONE + + ! Id for fields sent to ocean + INTEGER, PARAMETER :: ids_tauxxu = 1 + INTEGER, PARAMETER :: ids_tauyyu = 2 + INTEGER, PARAMETER :: ids_tauzzu = 3 + INTEGER, PARAMETER :: ids_tauxxv = 4 + INTEGER, PARAMETER :: ids_tauyyv = 5 + INTEGER, PARAMETER :: ids_tauzzv = 6 + INTEGER, PARAMETER :: ids_windsp = 7 + INTEGER, PARAMETER :: ids_shfice = 8 + INTEGER, PARAMETER :: ids_shfoce = 9 + INTEGER, PARAMETER :: ids_shftot = 10 + INTEGER, PARAMETER :: ids_nsfice = 11 + INTEGER, PARAMETER :: ids_nsfoce = 12 + INTEGER, PARAMETER :: ids_nsftot = 13 + INTEGER, PARAMETER :: ids_dflxdt = 14 + INTEGER, PARAMETER :: ids_totrai = 15 + INTEGER, PARAMETER :: ids_totsno = 16 + INTEGER, PARAMETER :: ids_toteva = 17 + INTEGER, PARAMETER :: ids_icevap = 18 + INTEGER, PARAMETER :: ids_ocevap = 19 + INTEGER, PARAMETER :: ids_calvin = 20 + INTEGER, PARAMETER :: ids_liqrun = 21 + INTEGER, PARAMETER :: ids_runcoa = 22 + INTEGER, PARAMETER :: ids_rivflu = 23 + INTEGER, PARAMETER :: ids_atmco2 = 24 + INTEGER, PARAMETER :: ids_taumod = 25 + INTEGER, PARAMETER :: maxsend = 25 ! Maximum number of fields to send + + ! Id for fields received from ocean + INTEGER, PARAMETER :: idr_sisutw = 1 + INTEGER, PARAMETER :: idr_icecov = 2 + INTEGER, PARAMETER :: idr_icealw = 3 + INTEGER, PARAMETER :: idr_icetem = 4 + INTEGER, PARAMETER :: idr_curenx = 5 + INTEGER, PARAMETER :: idr_cureny = 6 + INTEGER, PARAMETER :: idr_curenz = 7 + INTEGER, PARAMETER :: idr_oceco2 = 8 + INTEGER, PARAMETER :: maxrecv = 8 ! Maximum number of fields to receive + + + TYPE, PUBLIC :: FLD_CPL ! Type for coupling field information + CHARACTER(len = 8) :: name ! Name of the coupling field + LOGICAL :: action ! To be exchanged or not + INTEGER :: nid ! Id of the field + END TYPE FLD_CPL + + TYPE(FLD_CPL), DIMENSION(maxsend), SAVE, PUBLIC :: infosend ! Information for sending coupling fields + TYPE(FLD_CPL), DIMENSION(maxrecv), SAVE, PUBLIC :: inforecv ! Information for receiving coupling fields + + LOGICAL,SAVE :: cpl_current +!$OMP THREADPRIVATE(cpl_current) + +#ifdef CPP_COUPLE + +CONTAINS + + SUBROUTINE inicma +!************************************************************************************ +!**** *INICMA* - Initialize coupled mode communication for atmosphere +! and exchange some initial information with Oasis +! +! Rewrite to take the PRISM/psmile library into account +! LF 09/2003 +! + USE IOIPSL + USE surface_data, ONLY : version_ocean + USE carbon_cycle_mod, ONLY : carbon_cycle_cpl + + INCLUDE "dimensions.h" + INCLUDE "iniprint.h" + +! Local variables +!************************************************************************************ + INTEGER :: comp_id + INTEGER :: ierror, il_commlocal + INTEGER :: il_part_id + INTEGER, DIMENSION(3) :: ig_paral + INTEGER, DIMENSION(2) :: il_var_nodims + INTEGER, DIMENSION(4) :: il_var_actual_shape + INTEGER :: il_var_type + INTEGER :: jf + CHARACTER (len = 6) :: clmodnam + CHARACTER (len = 20) :: modname = 'inicma' + CHARACTER (len = 80) :: abort_message + LOGICAL :: cpl_current_omp + +!* 1. Initializations +! --------------- +!************************************************************************************ + WRITE(lunout,*) ' ' + WRITE(lunout,*) ' ' + WRITE(lunout,*) ' ROUTINE INICMA' + WRITE(lunout,*) ' **************' + WRITE(lunout,*) ' ' + WRITE(lunout,*) ' ' + +! +! Define the model name +! + clmodnam = 'lmdz.x' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp + + +!************************************************************************************ +! Define if coupling ocean currents or not +!************************************************************************************ +!$OMP MASTER + cpl_current_omp = .FALSE. + CALL getin('cpl_current', cpl_current_omp) +!$OMP END MASTER +!$OMP BARRIER + cpl_current = cpl_current_omp + WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current + +!************************************************************************************ +! Define coupling variables +!************************************************************************************ + +! Atmospheric variables to send + +!$OMP MASTER + infosend(:)%action = .FALSE. + + infosend(ids_tauxxu)%action = .TRUE. ; infosend(ids_tauxxu)%name = 'COTAUXXU' + infosend(ids_tauyyu)%action = .TRUE. ; infosend(ids_tauyyu)%name = 'COTAUYYU' + infosend(ids_tauzzu)%action = .TRUE. ; infosend(ids_tauzzu)%name = 'COTAUZZU' + infosend(ids_tauxxv)%action = .TRUE. ; infosend(ids_tauxxv)%name = 'COTAUXXV' + infosend(ids_tauyyv)%action = .TRUE. ; infosend(ids_tauyyv)%name = 'COTAUYYV' + infosend(ids_tauzzv)%action = .TRUE. ; infosend(ids_tauzzv)%name = 'COTAUZZV' + infosend(ids_windsp)%action = .TRUE. ; infosend(ids_windsp)%name = 'COWINDSP' + infosend(ids_shfice)%action = .TRUE. ; infosend(ids_shfice)%name = 'COSHFICE' + infosend(ids_nsfice)%action = .TRUE. ; infosend(ids_nsfice)%name = 'CONSFICE' + infosend(ids_dflxdt)%action = .TRUE. ; infosend(ids_dflxdt)%name = 'CODFLXDT' + infosend(ids_calvin)%action = .TRUE. ; infosend(ids_calvin)%name = 'COCALVIN' + + IF (version_ocean=='nemo') THEN + infosend(ids_shftot)%action = .TRUE. ; infosend(ids_shftot)%name = 'COQSRMIX' + infosend(ids_nsftot)%action = .TRUE. ; infosend(ids_nsftot)%name = 'COQNSMIX' + infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOTRAI' + infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOTSNO' + infosend(ids_toteva)%action = .TRUE. ; infosend(ids_toteva)%name = 'COTOTEVA' + infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COICEVAP' + infosend(ids_liqrun)%action = .TRUE. ; infosend(ids_liqrun)%name = 'COLIQRUN' + infosend(ids_taumod)%action = .TRUE. ; infosend(ids_taumod)%name = 'COTAUMOD' + IF (carbon_cycle_cpl) THEN + infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2' + ENDIF + + ELSE IF (version_ocean=='opa8') THEN + infosend(ids_shfoce)%action = .TRUE. ; infosend(ids_shfoce)%name = 'COSHFOCE' + infosend(ids_nsfoce)%action = .TRUE. ; infosend(ids_nsfoce)%name = 'CONSFOCE' + infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COTFSICE' + infosend(ids_ocevap)%action = .TRUE. ; infosend(ids_ocevap)%name = 'COTFSOCE' + infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOLPSU' + infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOSPSU' + infosend(ids_runcoa)%action = .TRUE. ; infosend(ids_runcoa)%name = 'CORUNCOA' + infosend(ids_rivflu)%action = .TRUE. ; infosend(ids_rivflu)%name = 'CORIVFLU' + ENDIF + +! Oceanic variables to receive + + inforecv(:)%action = .FALSE. + + inforecv(idr_sisutw)%action = .TRUE. ; inforecv(idr_sisutw)%name = 'SISUTESW' + inforecv(idr_icecov)%action = .TRUE. ; inforecv(idr_icecov)%name = 'SIICECOV' + inforecv(idr_icealw)%action = .TRUE. ; inforecv(idr_icealw)%name = 'SIICEALW' + inforecv(idr_icetem)%action = .TRUE. ; inforecv(idr_icetem)%name = 'SIICTEMW' + + IF (cpl_current ) THEN + inforecv(idr_curenx)%action = .TRUE. ; inforecv(idr_curenx)%name = 'CURRENTX' + inforecv(idr_cureny)%action = .TRUE. ; inforecv(idr_cureny)%name = 'CURRENTY' + inforecv(idr_curenz)%action = .TRUE. ; inforecv(idr_curenz)%name = 'CURRENTZ' + ENDIF + + IF (carbon_cycle_cpl ) THEN + inforecv(idr_oceco2)%action = .TRUE. ; inforecv(idr_oceco2)%name = 'SICO2FLX' + ENDIF + +!************************************************************************************ +! Here we go: psmile initialisation +!************************************************************************************ + IF (is_sequential) THEN + CALL prism_init_comp_proto (comp_id, clmodnam, ierror) + + IF (ierror .NE. PRISM_Ok) THEN + abort_message=' Probleme init dans prism_init_comp ' + CALL abort_gcm(modname,abort_message,1) + ELSE + WRITE(lunout,*) 'inicma : init psmile ok ' + ENDIF + ENDIF + + CALL prism_get_localcomm_proto (il_commlocal, ierror) +!************************************************************************************ +! Domain decomposition +!************************************************************************************ + ig_paral(1) = 1 ! apple partition for // + ig_paral(2) = (jj_begin-1)*iim+ii_begin-1 ! offset + ig_paral(3) = (jj_end*iim+ii_end) - (jj_begin*iim+ii_begin) + 1 + + IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+iim-1 + WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3) + + ierror=PRISM_Ok + CALL prism_def_partition_proto (il_part_id, ig_paral, ierror) + + IF (ierror .NE. PRISM_Ok) THEN + abort_message=' Probleme dans prism_def_partition ' + CALL abort_gcm(modname,abort_message,1) + ELSE + WRITE(lunout,*) 'inicma : decomposition domaine psmile ok ' + ENDIF + + il_var_nodims(1) = 2 + il_var_nodims(2) = 1 + + il_var_actual_shape(1) = 1 + il_var_actual_shape(2) = iim + il_var_actual_shape(3) = 1 + il_var_actual_shape(4) = jjm+1 + + il_var_type = PRISM_Real + +!************************************************************************************ +! Oceanic Fields to receive +! Loop over all possible variables +!************************************************************************************ + DO jf=1, maxrecv + IF (inforecv(jf)%action) THEN + CALL prism_def_var_proto(inforecv(jf)%nid, inforecv(jf)%name, il_part_id, & + il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, & + ierror) + IF (ierror .NE. PRISM_Ok) THEN + WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',& + inforecv(jf)%name + abort_message=' Problem in call to prism_def_var_proto for fields to receive' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + END DO + +!************************************************************************************ +! Atmospheric Fields to send +! Loop over all possible variables +!************************************************************************************ + DO jf=1,maxsend + IF (infosend(jf)%action) THEN + CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, & + il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, & + ierror) + IF (ierror .NE. PRISM_Ok) THEN + WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',& + infosend(jf)%name + abort_message=' Problem in call to prism_def_var_proto for fields to send' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + END DO + +!************************************************************************************ +! End definition +!************************************************************************************ + CALL prism_enddef_proto(ierror) + IF (ierror .NE. PRISM_Ok) THEN + abort_message=' Problem in call to prism_endef_proto' + CALL abort_gcm(modname,abort_message,1) + ELSE + WRITE(lunout,*) 'inicma : endef psmile ok ' + ENDIF + +!$OMP END MASTER + + END SUBROUTINE inicma + +! +!************************************************************************************ +! + + SUBROUTINE fromcpl(ktime, tab_get) +! ====================================================================== +! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST +! and Sea-Ice provided by the coupler. Adaptation to psmile library +!====================================================================== +! + INCLUDE "dimensions.h" + INCLUDE "iniprint.h" +! Input arguments +!************************************************************************************ + INTEGER, INTENT(IN) :: ktime + +! Output arguments +!************************************************************************************ + REAL, DIMENSION(iim, jj_nb,maxrecv), INTENT(OUT) :: tab_get + +! Local variables +!************************************************************************************ + INTEGER :: ierror, i + INTEGER :: istart,iend + CHARACTER (len = 20) :: modname = 'fromcpl' + CHARACTER (len = 80) :: abort_message + REAL, DIMENSION(iim*jj_nb) :: field + +!************************************************************************************ + WRITE (lunout,*) ' ' + WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime + WRITE (lunout,*) ' ' + + istart=ii_begin + IF (is_south_pole) THEN + iend=(jj_end-jj_begin)*iim+iim + ELSE + iend=(jj_end-jj_begin)*iim+ii_end + ENDIF + + DO i = 1, maxrecv + IF (inforecv(i)%action) THEN + field(:) = -99999. + CALL prism_get_proto(inforecv(i)%nid, ktime, field(istart:iend), ierror) + tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/)) + + IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. & + ierror.NE.PRISM_FromRest & + .AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut & + .AND. ierror.NE.PRISM_FromRestOut) THEN + WRITE (lunout,*) 'Error with receiving filed : ', inforecv(i)%name, ktime + abort_message=' Problem in prism_get_proto ' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + END DO + + + END SUBROUTINE fromcpl + +! +!************************************************************************************ +! + + SUBROUTINE intocpl(ktime, last, tab_put) +! ====================================================================== +! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the +! atmospheric coupling fields to the coupler with the psmile library. +! IF last time step, writes output fields to binary files. +! ====================================================================== +! +! + INCLUDE "dimensions.h" + INCLUDE "iniprint.h" +! Input arguments +!************************************************************************************ + INTEGER, INTENT(IN) :: ktime + LOGICAL, INTENT(IN) :: last + REAL, DIMENSION(iim, jj_nb, maxsend), INTENT(IN) :: tab_put + +! Local variables +!************************************************************************************ + LOGICAL :: checkout + INTEGER :: istart,iend + INTEGER :: wstart,wend + INTEGER :: ierror, i + REAL, DIMENSION(iim*jj_nb) :: field + CHARACTER (len = 20),PARAMETER :: modname = 'intocpl' + CHARACTER (len = 80) :: abort_message + +!************************************************************************************ + checkout=.FALSE. + + WRITE(lunout,*) ' ' + WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime + WRITE(lunout,*) 'last = ', last + WRITE(lunout,*) + + + istart=ii_begin + IF (is_south_pole) THEN + iend=(jj_end-jj_begin)*iim+iim + ELSE + iend=(jj_end-jj_begin)*iim+ii_end + ENDIF + + IF (checkout) THEN + wstart=istart + wend=iend + IF (is_north_pole) wstart=istart+iim-1 + IF (is_south_pole) wend=iend-iim+1 + + DO i = 1, maxsend + IF (infosend(i)%action) THEN + field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/)) + CALL writefield_phy(infosend(i)%name,field(wstart:wend),1) + END IF + END DO + END IF + +!************************************************************************************ +! PRISM_PUT +!************************************************************************************ + + DO i = 1, maxsend + IF (infosend(i)%action) THEN + field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/)) + CALL prism_put_proto(infosend(i)%nid, ktime, field(istart:iend), ierror) + + IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest & + .AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. & + ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN + WRITE (lunout,*) 'Error with sending field :', infosend(i)%name, ktime + abort_message=' Problem in prism_put_proto ' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + END DO + +!************************************************************************************ +! Finalize PSMILE for the case is_sequential, if parallel finalization is done +! from Finalize_parallel in dyn3dpar/parallel.F90 +!************************************************************************************ + + IF (last) THEN + IF (is_sequential) THEN + CALL prism_terminate_proto(ierror) + IF (ierror .NE. PRISM_Ok) THEN + abort_message=' Problem in prism_terminate_proto ' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + ENDIF + + + END SUBROUTINE intocpl + +#endif + +END MODULE oasis Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ocean_cpl_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ocean_cpl_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ocean_cpl_mod.F90 (revision 1280) @@ -0,0 +1,324 @@ +! +MODULE ocean_cpl_mod +! +! This module is used both for the sub-surface ocean and sea-ice for the case of a +! coupled model configuration, ocean=couple. +! + + IMPLICIT NONE + PRIVATE + + PUBLIC :: ocean_cpl_init, ocean_cpl_noice, ocean_cpl_ice + +!**************************************************************************************** +! +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE ocean_cpl_init(dtime, rlon, rlat) +! +! Allocate fields for this module and initailize the module mod_cpl +! + USE dimphy, ONLY : klon + USE cpl_mod + +! Input arguments +!************************************************************************************* + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + +! Local variables +!************************************************************************************* + INTEGER :: error + CHARACTER (len = 80) :: abort_message + CHARACTER (len = 20) :: modname = 'ocean_cpl_init' + +! Initialize module cpl_init + CALL cpl_init(dtime, rlon, rlat) + + END SUBROUTINE ocean_cpl_init +! +!**************************************************************************************** +! + SUBROUTINE ocean_cpl_noice( & + swnet, lwnet, alb1, & + windsp, fder_old, & + itime, dtime, knon, knindex, & + p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, & + radsol, snow, agesno, & + qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l) + +! +! This subroutine treats the "open ocean", all grid points that are not entierly covered +! by ice. The subroutine first receives fields from coupler, then some calculations at +! surface is done and finally it sends some fields to the coupler. +! + USE dimphy, ONLY : klon + USE cpl_mod + USE calcul_fluxs_mod + + INCLUDE "indicesol.h" + INCLUDE "YOMCST.h" +! +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: swnet + REAL, DIMENSION(klon), INTENT(IN) :: lwnet + REAL, DIMENSION(klon), INTENT(IN) :: alb1 ! albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(IN) :: windsp + REAL, DIMENSION(klon), INTENT(IN) :: fder_old + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + +! In/Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: radsol + REAL, DIMENSION(klon), INTENT(INOUT) :: snow + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + +! Local variables +!**************************************************************************************** + INTEGER :: i + INTEGER, DIMENSION(1) :: iloc + REAL, DIMENSION(klon) :: cal, beta, dif_grnd + REAL, DIMENSION(klon) :: fder_new + REAL, DIMENSION(klon) :: tsurf_cpl + REAL, DIMENSION(klon) :: u0_cpl, v0_cpl + REAL, DIMENSION(klon) :: u1_lay, v1_lay + LOGICAL :: check=.FALSE. + +! End definitions +!**************************************************************************************** + + IF (check) WRITE(*,*)' Entering ocean_cpl_noice' + +!**************************************************************************************** +! Receive sea-surface temperature(tsurf_cpl) from coupler +! +!**************************************************************************************** + CALL cpl_receive_ocean_fields(knon, knindex, tsurf_cpl, u0_cpl, v0_cpl) + +!**************************************************************************************** +! Calculate fluxes at surface +! +!**************************************************************************************** + cal = 0. + beta = 1. + dif_grnd = 0. + agesno(:) = 0. + + DO i = 1, knon + u1_lay(i) = u1(i) - u0_cpl(i) + v1_lay(i) = v1(i) - v0_cpl(i) + END DO + + CALL calcul_fluxs(knon, is_oce, dtime, & + tsurf_cpl, p1lay, cal, beta, cdragh, ps, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + +! - Flux calculation at first modele level for U and V + CALL calcul_flux_wind(knon, dtime, & + u0_cpl, v0_cpl, u1, v1, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + +!**************************************************************************************** +! Calculate fder : flux derivative (sensible and latente) +! +!**************************************************************************************** + fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:) + + iloc = MAXLOC(fder_new(1:klon)) + IF (check .AND. fder_new(iloc(1))> 0.) THEN + WRITE(*,*)'**** Debug fder****' + WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1)) + WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), & + dflux_s(iloc(1)), dflux_l(iloc(1)) + ENDIF + +!**************************************************************************************** +! Send and cumulate fields to the coupler +! +!**************************************************************************************** + + CALL cpl_send_ocean_fields(itime, knon, knindex, & + swnet, lwnet, fluxlat, fluxsens, & + precip_rain, precip_snow, evap, tsurf_new, fder_new, alb1, flux_u1, flux_v1, windsp) + + + END SUBROUTINE ocean_cpl_noice +! +!**************************************************************************************** +! + SUBROUTINE ocean_cpl_ice( & + rlon, rlat, swnet, lwnet, alb1, & + fder_old, & + itime, dtime, knon, knindex, & + lafin, & + p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, pctsrf, & + radsol, snow, qsurf, & + alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l) +! +! This subroutine treats the ocean where there is ice. The subroutine first receives +! fields from coupler, then some calculations at surface is done and finally sends +! some fields to the coupler. +! + USE dimphy, ONLY : klon + USE cpl_mod + USE calcul_fluxs_mod + + INCLUDE "indicesol.h" + INCLUDE "YOMCST.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + LOGICAL, INTENT(IN) :: lafin + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(IN) :: swnet + REAL, DIMENSION(klon), INTENT(IN) :: lwnet + REAL, DIMENSION(klon), INTENT(IN) :: alb1 ! albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(IN) :: fder_old + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + +! In/output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: radsol + REAL, DIMENSION(klon), INTENT(INOUT) :: snow + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new, alb2_new + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + +! Local variables +!**************************************************************************************** + INTEGER :: i + INTEGER, DIMENSION(1) :: iloc + LOGICAL :: check=.FALSE. + REAL, PARAMETER :: t_grnd=271.35 + REAL, DIMENSION(klon) :: cal, beta, dif_grnd + REAL, DIMENSION(klon) :: tsurf_cpl, fder_new + REAL, DIMENSION(klon) :: alb_cpl + REAL, DIMENSION(klon) :: u0, v0 + REAL, DIMENSION(klon) :: u1_lay, v1_lay + +! End definitions +!**************************************************************************************** + + IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon + +!**************************************************************************************** +! Receive ocean temperature(tsurf_cpl) and albedo(alb_new) from coupler +! +!**************************************************************************************** + + CALL cpl_receive_seaice_fields(knon, knindex, & + tsurf_cpl, alb_cpl, u0, v0) + + alb1_new(1:knon) = alb_cpl(1:knon) + alb2_new(1:knon) = alb_cpl(1:knon) + + +!**************************************************************************************** +! Calculate fluxes at surface +! +!**************************************************************************************** + cal = 0. + dif_grnd = 0. + beta = 1.0 + + DO i = 1, knon + u1_lay(i) = u1(i) - u0(i) + v1_lay(i) = v1(i) - v0(i) + END DO + + CALL calcul_fluxs(knon, is_sic, dtime, & + tsurf_cpl, p1lay, cal, beta, cdragh, ps, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + + +! - Flux calculation at first modele level for U and V + CALL calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + +!**************************************************************************************** +! Calculate fder : flux derivative (sensible and latente) +! +!**************************************************************************************** + fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:) + + iloc = MAXLOC(fder_new(1:klon)) + IF (check .AND. fder_new(iloc(1))> 0.) THEN + WRITE(*,*)'**** Debug fder ****' + WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1)) + WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), & + dflux_s(iloc(1)), dflux_l(iloc(1)) + ENDIF + +!**************************************************************************************** +! Send and cumulate fields to the coupler +! +!**************************************************************************************** + + CALL cpl_send_seaice_fields(itime, dtime, knon, knindex, & + pctsrf, lafin, rlon, rlat, & + swnet, lwnet, fluxlat, fluxsens, & + precip_rain, precip_snow, evap, tsurf_new, fder_new, alb1, flux_u1, flux_v1) + + + END SUBROUTINE ocean_cpl_ice +! +!**************************************************************************************** +! +END MODULE ocean_cpl_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ocean_forced_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ocean_forced_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ocean_forced_mod.F90 (revision 1280) @@ -0,0 +1,270 @@ +! +MODULE ocean_forced_mod +! +! This module is used for both the sub-surfaces ocean and sea-ice for the case of a +! forced ocean, "ocean=force". +! + IMPLICIT NONE + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE ocean_forced_noice( & + itime, dtime, jour, knon, knindex, & + p1lay, cdragh, cdragm, precip_rain, precip_snow, & + temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, & + radsol, snow, agesno, & + qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l) +! +! This subroutine treats the "open ocean", all grid points that are not entierly covered +! by ice. +! The routine receives data from climatologie file limit.nc and does some calculations at the +! surface. +! + USE dimphy + USE calcul_fluxs_mod + USE limit_read_mod + INCLUDE "indicesol.h" + INCLUDE "YOMCST.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + +! In/Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: radsol + REAL, DIMENSION(klon), INTENT(INOUT) :: snow + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno !? put to 0 in ocean + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + +! Local variables +!**************************************************************************************** + INTEGER :: i + REAL, DIMENSION(klon) :: cal, beta, dif_grnd + REAL, DIMENSION(klon) :: alb_neig, tsurf_lim, zx_sl + REAL, DIMENSION(klon) :: u0, v0 + REAL, DIMENSION(klon) :: u1_lay, v1_lay + LOGICAL :: check=.FALSE. + +!**************************************************************************************** +! Start calculation +!**************************************************************************************** + IF (check) WRITE(*,*)' Entering ocean_forced_noice' + +!**************************************************************************************** +! 1) +! Read sea-surface temperature from file limit.nc +! +!**************************************************************************************** + CALL limit_read_sst(knon,knindex,tsurf_lim) + +!**************************************************************************************** +! 2) +! Flux calculation +! +!**************************************************************************************** +! Set some variables for calcul_fluxs + cal = 0. + beta = 1. + dif_grnd = 0. + alb_neig(:) = 0. + agesno(:) = 0. +! Suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + u1_lay(:) = u1(:) - u0(:) + v1_lay(:) = v1(:) - v0(:) + +! Calcul de tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l and qsurf + CALL calcul_fluxs(knon, is_oce, dtime, & + tsurf_lim, p1lay, cal, beta, cdragh, ps, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + +! - Flux calculation at first modele level for U and V + CALL calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + + END SUBROUTINE ocean_forced_noice +! +!*************************************************************************************** +! + SUBROUTINE ocean_forced_ice( & + itime, dtime, jour, knon, knindex, & + tsurf_in, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, & + radsol, snow, qsol, agesno, tsoil, & + qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l) +! +! This subroutine treats the ocean where there is ice. +! The routine reads data from climatologie file and does flux calculations at the +! surface. +! + USE dimphy + USE calcul_fluxs_mod + USE surface_data, ONLY : calice, calsno, tau_gl + USE limit_read_mod + USE fonte_neige_mod, ONLY : fonte_neige + + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + INCLUDE "YOMCST.h" + INCLUDE "clesphys.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: tsurf_in + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + +! In/Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: radsol + REAL, DIMENSION(klon), INTENT(INOUT) :: snow, qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new ! new albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(OUT) :: alb2_new ! new albedo in near IR interval + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + +! Local variables +!**************************************************************************************** + LOGICAL :: check=.FALSE. + INTEGER :: i + REAL :: zfra + REAL, PARAMETER :: t_grnd=271.35 + REAL, DIMENSION(klon) :: cal, beta, dif_grnd, capsol + REAL, DIMENSION(klon) :: alb_neig, tsurf_tmp + REAL, DIMENSION(klon) :: soilcap, soilflux + REAL, DIMENSION(klon) :: u0, v0 + REAL, DIMENSION(klon) :: u1_lay, v1_lay + +!**************************************************************************************** +! Start calculation +!**************************************************************************************** + IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon + +!**************************************************************************************** +! 1) +! Flux calculation : tsurf_new, evap, fluxlat, fluxsens, flux_u1, flux_v1 +! dflux_s, dflux_l and qsurf +!**************************************************************************************** + tsurf_tmp(:) = tsurf_in(:) + +! calculate the parameters cal, beta, capsol and dif_grnd + CALL calbeta(dtime, is_sic, knon, snow, qsol, beta, capsol, dif_grnd) + + + IF (soil_model) THEN +! update tsoil and calculate soilcap and soilflux + CALL soil(dtime, is_sic, knon, snow, tsurf_tmp, tsoil,soilcap, soilflux) + cal(1:knon) = RCPD / soilcap(1:knon) + radsol(1:knon) = radsol(1:knon) + soilflux(1:knon) + dif_grnd = 1.0 / tau_gl + ELSE + dif_grnd = 1.0 / tau_gl + cal = RCPD * calice + WHERE (snow > 0.0) cal = RCPD * calsno + ENDIF + + beta = 1.0 +! Suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + u1_lay(:) = u1(:) - u0(:) + v1_lay(:) = v1(:) - v0(:) + CALL calcul_fluxs(knon, is_sic, dtime, & + tsurf_tmp, p1lay, cal, beta, cdragh, ps, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + +! - Flux calculation at first modele level for U and V + CALL calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + +!**************************************************************************************** +! 2) +! Calculations due to snow and runoff +! +!**************************************************************************************** + CALL fonte_neige( knon, is_sic, knindex, dtime, & + tsurf_tmp, precip_rain, precip_snow, & + snow, qsol, tsurf_new, evap) + +! Calculation of albedo at snow (alb_neig) and update the age of snow (agesno) +! + CALL albsno(klon, knon, dtime, agesno(:), alb_neig(:), precip_snow(:)) + + WHERE (snow(1:knon) .LT. 0.0001) agesno(1:knon) = 0. + + alb1_new(:) = 0.0 + DO i=1, knon + zfra = MAX(0.0,MIN(1.0,snow(i)/(snow(i)+10.0))) + alb1_new(i) = alb_neig(i) * zfra + 0.6 * (1.0-zfra) + ENDDO + + alb2_new(:) = alb1_new(:) + + END SUBROUTINE ocean_forced_ice +! +!**************************************************************************************** +! +END MODULE ocean_forced_mod + + + + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ocean_slab_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ocean_slab_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ocean_slab_mod.F90 (revision 1280) @@ -0,0 +1,162 @@ +! +MODULE ocean_slab_mod +! +! This module is used for both surface ocean and sea-ice when using the slab ocean, +! "ocean=slab". +! + IMPLICIT NONE + PRIVATE + PUBLIC :: ocean_slab_frac, ocean_slab_noice + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE ocean_slab_frac(itime, dtime, jour, pctsrf, is_modified) + + USE dimphy + USE limit_read_mod + USE surface_data + INCLUDE "indicesol.h" +! INCLUDE "clesphys.h" + +! Arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime ! numero du pas de temps courant + INTEGER, INTENT(IN) :: jour ! jour a lire dans l'annee + REAL , INTENT(IN) :: dtime ! pas de temps de la physique (en s) + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf ! sub-surface fraction + LOGICAL, INTENT(OUT) :: is_modified ! true if pctsrf is modified at this time step + +! Local variables +!**************************************************************************************** + CHARACTER (len = 80) :: abort_message + CHARACTER (len = 20) :: modname = 'ocean_slab_frac' + + + IF (version_ocean == 'sicOBS') THEN + CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified) + ELSE + abort_message='Ocean slab model without forced sea-ice fractions has to be rewritten!!!' + CALL abort_gcm(modname,abort_message,1) +! Here should sea-ice/ocean fraction either be calculated or returned if saved as a module varaiable +! (in the case the new fractions are calculated in ocean_slab_ice or ocean_slab_noice subroutines). + END IF + + END SUBROUTINE ocean_slab_frac +! +!**************************************************************************************** +! + SUBROUTINE ocean_slab_noice( & + itime, dtime, jour, knon, knindex, & + p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, tsurf_in, & + radsol, snow, agesno, & + qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l, lmt_bils) + + USE dimphy + USE calcul_fluxs_mod + + INCLUDE "indicesol.h" + INCLUDE "iniprint.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime + INTEGER, INTENT(IN) :: jour + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + REAL, DIMENSION(klon), INTENT(IN) :: tsurf_in + +! In/Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: radsol + REAL, DIMENSION(klon), INTENT(INOUT) :: snow + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + REAL, DIMENSION(klon), INTENT(OUT) :: lmt_bils + +! Local variables +!**************************************************************************************** + INTEGER :: i + REAL, DIMENSION(klon) :: cal, beta, dif_grnd + REAL, DIMENSION(klon) :: lmt_bils_oce, lmt_foce, diff_sst + REAL, DIMENSION(klon) :: u0, v0 + REAL, DIMENSION(klon) :: u1_lay, v1_lay + REAL :: calc_bils_oce, deltat + REAL, PARAMETER :: cyang=50.0 * 4.228e+06 ! capacite calorifique volumetrique de l'eau J/(m2 K) + +!**************************************************************************************** +! 1) Flux calculation +! +!**************************************************************************************** + cal(:) = 0. + beta(:) = 1. + dif_grnd(:) = 0. + agesno(:) = 0. + +! Suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + u1_lay(:) = u1(:) - u0(:) + v1_lay(:) = v1(:) - v0(:) + + CALL calcul_fluxs(knon, is_oce, dtime, & + tsurf_in, p1lay, cal, beta, cdragh, ps, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + +! - Flux calculation at first modele level for U and V + CALL calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + +!**************************************************************************************** +! 2) Get global variables lmt_bils and lmt_foce from file limit_slab.nc +! +!**************************************************************************************** + CALL limit_slab(itime, dtime, jour, lmt_bils, lmt_foce, diff_sst) ! global pour un processus + + lmt_bils_oce(:) = 0. + WHERE (lmt_foce > 0.) + lmt_bils_oce = lmt_bils / lmt_foce ! global + END WHERE + +!**************************************************************************************** +! 3) Recalculate new temperature +! +!**************************************************************************************** + DO i = 1, knon + calc_bils_oce = radsol(i) + fluxsens(i) + fluxlat(i) + deltat = (calc_bils_oce - lmt_bils_oce(knindex(i)))*dtime/cyang +diff_sst(knindex(i)) + tsurf_new(i) = tsurf_in(i) + deltat + END DO + + END SUBROUTINE ocean_slab_noice +! +!**************************************************************************************** +! +END MODULE ocean_slab_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/open_climoz_m.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/open_climoz_m.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/open_climoz_m.F90 (revision 1280) @@ -0,0 +1,73 @@ +! $Id$ +module open_climoz_m + + implicit none + +contains + + subroutine open_climoz(ncid, press_in_edg) + + ! This procedure should be called once per "gcm" run, by a single + ! thread of each MPI process. + ! The root MPI process opens "climoz_LMDZ.nc", reads the pressure + ! levels and broadcasts them to the other processes. + + ! We assume that, in "climoz_LMDZ.nc", the pressure levels are in hPa + ! and in strictly ascending order. + + use netcdf95, only: nf95_open, nf95_close, nf95_gw_var, nf95_inq_varid + use netcdf, only: nf90_nowrite + + use mod_phys_lmdz_mpi_data, only: is_mpi_root + use mod_phys_lmdz_mpi_transfert, only: bcast_mpi ! broadcast + + integer, intent(out):: ncid ! of "climoz_LMDZ.nc", OpenMP shared + + real, pointer:: press_in_edg(:) + ! edges of pressure intervals for ozone climatology, in Pa, in strictly + ! ascending order, OpenMP shared + + ! Variables local to the procedure: + + real, pointer:: plev(:) + ! (pressure levels for ozone climatology, converted to Pa, in strictly + ! ascending order) + + integer varid ! for NetCDF + integer n_plev ! number of pressure levels in the input data + integer k + + !--------------------------------------- + + print *, "Call sequence information: open_climoz" + + if (is_mpi_root) then + call nf95_open("climoz_LMDZ.nc", nf90_nowrite, ncid) + + call nf95_inq_varid(ncid, "plev", varid) + call nf95_gw_var(ncid, varid, plev) + ! Convert from hPa to Pa because "paprs" and "pplay" are in Pa: + plev = plev * 100. + n_plev = size(plev) + end if + + call bcast_mpi(n_plev) + if (.not. is_mpi_root) allocate(plev(n_plev)) + call bcast_mpi(plev) + + ! Compute edges of pressure intervals: + allocate(press_in_edg(n_plev + 1)) + if (is_mpi_root) then + press_in_edg(1) = 0. + ! We choose edges halfway in logarithm: + forall (k = 2:n_plev) press_in_edg(k) = sqrt(plev(k - 1) * plev(k)) + press_in_edg(n_plev + 1) = huge(0.) + ! (infinity, but any value guaranteed to be greater than the + ! surface pressure would do) + end if + call bcast_mpi(press_in_edg) + deallocate(plev) ! pointer + + end subroutine open_climoz + +end module open_climoz_m Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/orbite.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/orbite.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/orbite.F (revision 1280) @@ -0,0 +1,325 @@ +! +! $Header$ +! +c====================================================================== + SUBROUTINE orbite(xjour,longi,dist) + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) (adapte du GCM du LMD) date: 19930818 +c Objet: pour un jour donne, calculer la longitude vraie de la terre +c (par rapport au point vernal-21 mars) dans son orbite solaire +c calculer aussi la distance terre-soleil (unite astronomique) +c====================================================================== +c Arguments: +c xjour--INPUT--R- jour de l'annee a compter du 1er janvier +c longi--OUTPUT-R- longitude vraie en degres par rapport au point +c vernal (21 mars) en degres +c dist---OUTPUT-R- distance terre-soleil (par rapport a la moyenne) + REAL xjour, longi, dist +c====================================================================== +#include "YOMCST.h" +C +C -- Variables dynamiques locales + REAL pir,xl,xllp,xee,xse,xlam,dlamm,anm,ranm,anv,ranv +C + pir = 4.0*ATAN(1.0) / 180.0 + xl=R_peri+180.0 + xllp=xl*pir + xee=R_ecc*R_ecc + xse=SQRT(1.0-xee) + xlam = (R_ecc/2.0+R_ecc*xee/8.0)*(1.0+xse)*SIN(xllp) + . - xee/4.0*(0.5+xse)*SIN(2.0*xllp) + . + R_ecc*xee/8.0*(1.0/3.0+xse)*SIN(3.0*xllp) + xlam=2.0*xlam/pir + dlamm=xlam+(xjour-81.0) + anm=dlamm-xl + ranm=anm*pir + xee=xee*R_ecc + ranv=ranm+(2.0*R_ecc-xee/4.0)*SIN(ranm) + . +5.0/4.0*R_ecc*R_ecc*SIN(2.0*ranm) + . +13.0/12.0*xee*SIN(3.0*ranm) +c + anv=ranv/pir + longi=anv+xl +C + dist = (1-R_ecc*R_ecc) + . /(1+R_ecc*COS(pir*(longi-(R_peri+180.0)))) + RETURN + END +c====================================================================== + SUBROUTINE angle(longi, lati, frac, muzero) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: Calculer la duree d'ensoleillement pour un jour et la hauteur +c du soleil (cosinus de l'angle zinithal) moyenne sur la journee +c====================================================================== +c Arguments: +c longi----INPUT-R- la longitude vraie de la terre dans son plan +c solaire a partir de l'equinoxe de printemps (degre) +c lati-----INPUT-R- la latitude d'un point sur la terre (degre) +c frac-----OUTPUT-R la duree d'ensoleillement dans la journee divisee +c par 24 heures (unite en fraction de 0 a 1) +c muzero---OUTPUT-R la moyenne du cosinus de l'angle zinithal sur +c la journee (0 a 1) +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" + REAL longi + REAL lati(klon), frac(klon), muzero(klon) +#include "YOMCST.h" + REAL lat, omega, lon_sun, lat_sun + REAL pi_local, incl + INTEGER i +c + pi_local = 4.0 * ATAN(1.0) + incl=R_incl * pi_local / 180. +c + lon_sun = longi * pi_local / 180.0 + lat_sun = ASIN (sin(lon_sun)*SIN(incl) ) +c + DO i = 1, klon + lat = lati(i) * pi_local / 180.0 +c + IF ( lat .GE. (pi_local/2.+lat_sun) + . .OR. lat.LE.(-pi_local/2.+lat_sun)) THEN + omega = 0.0 ! nuit polaire + ELSE IF ( lat.GE.(pi_local/2.-lat_sun) + . .OR. lat.LE.(-pi_local/2.-lat_sun)) THEN + omega = pi_local ! journee polaire + ELSE + omega = -TAN(lat)*TAN(lat_sun) + omega = ACOS (omega) + ENDIF +c + frac(i) = omega / pi_local +c + IF (omega .GT. 0.0) THEN + muzero(i) = SIN(lat)*SIN(lat_sun) + . + COS(lat)*COS(lat_sun)*SIN(omega) / omega + ELSE + muzero(i) = 0.0 + ENDIF + ENDDO +c + RETURN + END +c==================================================================== + SUBROUTINE zenang(longi,gmtime,pdtrad,lat,long, + s pmu0,frac) + USE dimphy + IMPLICIT none +c============================================================= +c Auteur : O. Boucher (LMD/CNRS) +c d'apres les routines zenith et angle de Z.X. Li +c Objet : calculer les valeurs moyennes du cos de l'angle zenithal +c et l'ensoleillement moyen entre gmtime1 et gmtime2 +c connaissant la declinaison, la latitude et la longitude. +c Rque : Different de la routine angle en ce sens que zenang +c fournit des moyennes de pmu0 et non des valeurs +c instantanees, du coup frac prend toutes les valeurs +c entre 0 et 1. +c Date : premiere version le 13 decembre 1994 +c revu pour GCM le 30 septembre 1996 +c=============================================================== +c longi : la longitude vraie de la terre dans son plan +c solaire a partir de l'equinoxe de printemps (degre) +c gmtime : temps universel en fraction de jour +c pdtrad : pas de temps du rayonnement (secondes) +c lat------INPUT : latitude en degres +c long-----INPUT : longitude en degres +c pmu0-----OUTPUT: angle zenithal moyen entre gmtime et gmtime+pdtrad +c frac-----OUTPUT: ensoleillement moyen entre gmtime et gmtime+pdtrad +c================================================================ +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c================================================================ + real, intent(in):: longi, gmtime, pdtrad + real lat(klon), long(klon), pmu0(klon), frac(klon) +c================================================================ + integer i + real gmtime1, gmtime2 + real pi_local, deux_pi_local, incl + real omega1, omega2, omega +c omega1, omega2 : temps 1 et 2 exprime en radian avec 0 a midi. +c omega : heure en radian du coucher de soleil +c -omega est donc l'heure en radian de lever du soleil + real omegadeb, omegafin + real zfrac1, zfrac2, z1_mu, z2_mu + real lat_sun ! declinaison en radian + real lon_sun ! longitude solaire en radian + real latr ! latitude du pt de grille en radian +c================================================================ +c + pi_local = 4.0 * ATAN(1.0) + deux_pi_local = 2.0 * pi_local + incl=R_incl * pi_local / 180. +c + lon_sun = longi * pi_local / 180.0 + lat_sun = ASIN (SIN(lon_sun)*SIN(incl) ) +c + gmtime1=gmtime*86400. + gmtime2=gmtime*86400.+pdtrad +c + DO i = 1, klon +c + latr = lat(i) * pi_local / 180. +c +c--pose probleme quand lat=+/-90 degres +c +c omega = -TAN(latr)*TAN(lat_sun) +c omega = ACOS(omega) +c IF (latr.GE.(pi_local/2.+lat_sun) +c . .OR. latr.LE.(-pi_local/2.+lat_sun)) THEN +c omega = 0.0 ! nuit polaire +c ENDIF +c IF (latr.GE.(pi_local/2.-lat_sun) +c . .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN +c omega = pi_local ! journee polaire +c ENDIF +c +c--remplace par cela (le cas par defaut est different) +c + omega=0.0 !--nuit polaire + IF (latr.GE.(pi_local/2.-lat_sun) + . .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN + omega = pi_local ! journee polaire + ENDIF + IF (latr.LT.(pi_local/2.+lat_sun).AND. + . latr.GT.(-pi_local/2.+lat_sun).AND. + . latr.LT.(pi_local/2.-lat_sun).AND. + . latr.GT.(-pi_local/2.-lat_sun)) THEN + omega = -TAN(latr)*TAN(lat_sun) + omega = ACOS(omega) + ENDIF +c + omega1 = gmtime1 + long(i)*86400.0/360.0 + omega1 = omega1 / 86400.0*deux_pi_local + omega1 = MOD (omega1+deux_pi_local, deux_pi_local) + omega1 = omega1 - pi_local +c + omega2 = gmtime2 + long(i)*86400.0/360.0 + omega2 = omega2 / 86400.0*deux_pi_local + omega2 = MOD (omega2+deux_pi_local, deux_pi_local) + omega2 = omega2 - pi_local +c + IF (omega1.LE.omega2) THEN !--on est dans la meme journee locale +c + IF (omega2.LE.-omega .OR. omega1.GE.omega + . .OR. omega.LT.1e-5) THEN !--nuit + frac(i)=0.0 + pmu0(i)=0.0 + ELSE !--jour+nuit/jour + omegadeb=MAX(-omega,omega1) + omegafin=MIN(omega,omega2) + frac(i)=(omegafin-omegadeb)/(omega2-omega1) + pmu0(i)=SIN(latr)*SIN(lat_sun) + + . COS(latr)*COS(lat_sun)* + . (SIN(omegafin)-SIN(omegadeb))/ + . (omegafin-omegadeb) + ENDIF +c + ELSE !---omega1 GT omega2 -- a cheval sur deux journees +c +c-------------------entre omega1 et pi + IF (omega1.GE.omega) THEN !--nuit + zfrac1=0.0 + z1_mu =0.0 + ELSE !--jour+nuit + omegadeb=MAX(-omega,omega1) + omegafin=omega + zfrac1=omegafin-omegadeb + z1_mu =SIN(latr)*SIN(lat_sun) + + . COS(latr)*COS(lat_sun)* + . (SIN(omegafin)-SIN(omegadeb))/ + . (omegafin-omegadeb) + ENDIF +c---------------------entre -pi et omega2 + IF (omega2.LE.-omega) THEN !--nuit + zfrac2=0.0 + z2_mu =0.0 + ELSE !--jour+nuit + omegadeb=-omega + omegafin=MIN(omega,omega2) + zfrac2=omegafin-omegadeb + z2_mu =SIN(latr)*SIN(lat_sun) + + . COS(latr)*COS(lat_sun)* + . (SIN(omegafin)-SIN(omegadeb))/ + . (omegafin-omegadeb) +c + ENDIF +c-----------------------moyenne + frac(i)=(zfrac1+zfrac2)/(omega2+deux_pi_local-omega1) + pmu0(i)=(zfrac1*z1_mu+zfrac2*z2_mu)/MAX(zfrac1+zfrac2,1.E-10) +c + ENDIF !---comparaison omega1 et omega2 +c + ENDDO +c + END +c=================================================================== + SUBROUTINE zenith (longi, gmtime, lat, long, + s pmu0, fract) + USE dimphy + IMPLICIT none +c +c Auteur(s): Z.X. Li (LMD/ENS) +c +c Objet: calculer le cosinus de l'angle zenithal du soleil en +c connaissant la declinaison du soleil, la latitude et la +c longitude du point sur la terre, et le temps universel +c +c Arguments d'entree: +c longi : declinaison du soleil (en degres) +c gmtime : temps universel en second qui varie entre 0 et 86400 +c lat : latitude en degres +c long : longitude en degres +c Arguments de sortie: +c pmu0 : cosinus de l'angle zenithal +c +c==================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c==================================================================== + REAL longi, gmtime + REAL lat(klon), long(klon), pmu0(klon), fract(klon) +c===================================================================== + INTEGER n + REAL zpi, zpir, omega, zgmtime + REAL incl, lat_sun, lon_sun +c---------------------------------------------------------------------- + zpi = 4.0*ATAN(1.0) + zpir = zpi / 180.0 + zgmtime=gmtime*86400. +c + incl=R_incl * zpir +c + lon_sun = longi * zpir + lat_sun = ASIN (SIN(lon_sun)*SIN(incl) ) +c +c--initialisation a la nuit +c + DO n =1, klon + pmu0(n)=0. + fract(n)=0.0 + ENDDO +c +c 1 degre en longitude = 240 secondes en temps +c + DO n = 1, klon + omega = zgmtime + long(n)*86400.0/360.0 + omega = omega / 86400.0 * 2.0 * zpi + omega = MOD(omega + 2.0 * zpi, 2.0 * zpi) + omega = omega - zpi + pmu0(n) = sin(lat(n)*zpir) * sin(lat_sun) + . + cos(lat(n)*zpir) * cos(lat_sun) + . * cos(omega) + pmu0(n) = MAX (pmu0(n), 0.0) + IF (pmu0(n).GT.1.E-6) fract(n)=1.0 + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/orografi.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/orografi.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/orografi.F (revision 1280) @@ -0,0 +1,1839 @@ +! +! $Header$ +! + SUBROUTINE drag_noro (nlon,nlev,dtime,paprs,pplay, + e pmea,pstd, psig, pgam, pthe,ppic,pval, + e kgwd,kdx,ktest, + e t, u, v, + s pulow, pvlow, pustr, pvstr, + s d_t, d_u, d_v) +c + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): F.Lott (LMD/CNRS) date: 19950201 +c Objet: Frottement de la montagne Interface +c====================================================================== +c Arguments: +c dtime---input-R- pas d'integration (s) +c paprs---input-R-pression pour chaque inter-couche (en Pa) +c pplay---input-R-pression pour le mileu de chaque couche (en Pa) +c t-------input-R-temperature (K) +c u-------input-R-vitesse horizontale (m/s) +c v-------input-R-vitesse horizontale (m/s) +c +c d_t-----output-R-increment de la temperature +c d_u-----output-R-increment de la vitesse u +c d_v-----output-R-increment de la vitesse v +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c ARGUMENTS +c + INTEGER nlon,nlev + REAL dtime + REAL paprs(klon,klev+1) + REAL pplay(klon,klev) + REAL pmea(nlon),pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon) + REAL ppic(nlon),pval(nlon) + REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon) + REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev) + REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev) +c + INTEGER i, k, kgwd, kdx(nlon), ktest(nlon) +c +c Variables locales: +c + REAL zgeom(klon,klev) + REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev) + REAL pt(klon,klev), pu(klon,klev), pv(klon,klev) + REAL papmf(klon,klev),papmh(klon,klev+1) +c +c initialiser les variables de sortie (pour securite) +c + DO i = 1,klon + pulow(i) = 0.0 + pvlow(i) = 0.0 + pustr(i) = 0.0 + pvstr(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_u(i,k) = 0.0 + d_v(i,k) = 0.0 + pdudt(i,k)=0.0 + pdvdt(i,k)=0.0 + pdtdt(i,k)=0.0 + ENDDO + ENDDO +c +c preparer les variables d'entree (attention: l'ordre des niveaux +c verticaux augmente du haut vers le bas) +c + DO k = 1, klev + DO i = 1, klon + pt(i,k) = t(i,klev-k+1) + pu(i,k) = u(i,klev-k+1) + pv(i,k) = v(i,klev-k+1) + papmf(i,k) = pplay(i,klev-k+1) + ENDDO + ENDDO + DO k = 1, klev+1 + DO i = 1, klon + papmh(i,k) = paprs(i,klev-k+2) + ENDDO + ENDDO + DO i = 1, klon + zgeom(i,klev) = RD * pt(i,klev) + . * LOG(papmh(i,klev+1)/papmf(i,klev)) + ENDDO + DO k = klev-1, 1, -1 + DO i = 1, klon + zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0 + . * LOG(papmf(i,k+1)/papmf(i,k)) + ENDDO + ENDDO +c +c appeler la routine principale +c + CALL orodrag(klon,klev,kgwd,kdx,ktest, + . dtime, + . papmh, papmf, zgeom, + . pt, pu, pv, + . pmea, pstd, psig, pgam, pthe, ppic,pval, + . pulow,pvlow, + . pdudt,pdvdt,pdtdt) +C + DO k = 1, klev + DO i = 1, klon + d_u(i,klev+1-k) = dtime*pdudt(i,k) + d_v(i,klev+1-k) = dtime*pdvdt(i,k) + d_t(i,klev+1-k) = dtime*pdtdt(i,k) + pustr(i) = pustr(i) +cIM BUG . +rg*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k)) + . +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG + pvstr(i) = pvstr(i) +cIM BUG . +rg*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k)) + . +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG + ENDDO + ENDDO +c + RETURN + END + SUBROUTINE orodrag( nlon,nlev + i , kgwd, kdx, ktest + r , ptsphy + r , paphm1,papm1,pgeom1,ptm1,pum1,pvm1 + r , pmea, pstd, psig, pgamma, ptheta, ppic, pval +c outputs + r , pulow,pvlow + r , pvom,pvol,pte ) + + USE dimphy + implicit none + +c +c +c**** *gwdrag* - does the gravity wave parametrization. +c +c purpose. +c -------- +c +c this routine computes the physical tendencies of the +c prognostic variables u,v and t due to vertical transports by +c subgridscale orographically excited gravity waves +c +c** interface. +c ---------- +c called from *callpar*. +c +c the routine takes its input from the long-term storage: +c u,v,t and p at t-1. +c +c explicit arguments : +c -------------------- +c ==== inputs === +c ==== outputs === +c +c implicit arguments : none +c -------------------- +c +c implicit logical (l) +c +c method. +c ------- +c +c externals. +c ---------- + integer ismin, ismax + external ismin, ismax +c +c reference. +c ---------- +c +c author. +c ------- +c m.miller + b.ritter e.c.m.w.f. 15/06/86. +c +c f.lott + m. miller e.c.m.w.f. 22/11/94 +c----------------------------------------------------------------------- +c +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" +c----------------------------------------------------------------------- +c +c* 0.1 arguments +c --------- +c +c +cym integer nlon, nlev, klevm1 + integer nlon, nlev + integer kgwd, jl, ilevp1, jk, ji + real zdelp, ztemp, zforc, ztend + real rover, zb, zc, zconb, zabsv + real zzd1, ratio, zbet, zust,zvst, zdis + real pte(nlon,nlev), + * pvol(nlon,nlev), + * pvom(nlon,nlev), + * pulow(klon), + * pvlow(klon) + real pum1(nlon,nlev), + * pvm1(nlon,nlev), + * ptm1(nlon,nlev), + * pmea(nlon),pstd(nlon),psig(nlon), + * pgamma(nlon),ptheta(nlon),ppic(nlon),pval(nlon), + * pgeom1(nlon,nlev), + * papm1(nlon,nlev), + * paphm1(nlon,nlev+1) +c + integer kdx(nlon),ktest(nlon) +c----------------------------------------------------------------------- +c +c* 0.2 local arrays +c ------------ + integer isect(klon), + * icrit(klon), + * ikcrith(klon), + * ikenvh(klon), + * iknu(klon), + * iknu2(klon), + * ikcrit(klon), + * ikhlim(klon) +c + real ztau(klon,klev+1), + $ ztauf(klon,klev+1), + * zstab(klon,klev+1), + * zvph(klon,klev+1), + * zrho(klon,klev+1), + * zri(klon,klev+1), + * zpsi(klon,klev+1), + * zzdep(klon,klev) + real zdudt(klon), + * zdvdt(klon), + * zdtdt(klon), + * zdedt(klon), + * zvidis(klon), + * znu(klon), + * zd1(klon), + * zd2(klon), + * zdmod(klon) + real ztmst, ptsphy, zrtmst +c +c------------------------------------------------------------------ +c +c* 1. initialization +c -------------- +c + 100 continue +c +c ------------------------------------------------------------------ +c +c* 1.1 computational constants +c ----------------------- +c + 110 continue +c +c ztmst=twodt +c if(nstep.eq.nstart) ztmst=0.5*twodt +cym klevm1=klev-1 + ztmst=ptsphy + zrtmst=1./ztmst +c ------------------------------------------------------------------ +c + 120 continue +c +c ------------------------------------------------------------------ +c +c* 1.3 check whether row contains point for printing +c --------------------------------------------- +c + 130 continue +c +c ------------------------------------------------------------------ +c +c* 2. precompute basic state variables. +c* ---------- ----- ----- ---------- +c* define low level wind, project winds in plane of +c* low level wind, determine sector in which to take +c* the variance and set indicator for critical levels. +c + 200 continue +c +c +c + call orosetup + * ( nlon, ktest + * , ikcrit, ikcrith, icrit, ikenvh,iknu,iknu2 + * , paphm1, papm1 , pum1 , pvm1 , ptm1 , pgeom1, pstd + * , zrho , zri , zstab , ztau , zvph , zpsi, zzdep + * , pulow, pvlow + * , ptheta,pgamma,pmea,ppic,pval,znu ,zd1, zd2, zdmod ) +c +c +c +c*********************************************************** +c +c +c* 3. compute low level stresses using subcritical and +c* supercritical forms.computes anisotropy coefficient +c* as measure of orographic twodimensionality. +c + 300 continue +c + call gwstress + * ( nlon , nlev + * , ktest , icrit, ikenvh, iknu + * , zrho , zstab, zvph , pstd, psig, pmea, ppic + * , ztau + * , pgeom1,zdmod) +c +c +c* 4. compute stress profile. +c* ------- ------ -------- +c + 400 continue +c +c + call gwprofil + * ( nlon , nlev + * , kgwd , kdx , ktest + * , ikcrith, icrit + * , paphm1, zrho , zstab , zvph + * , zri , ztau + * , zdmod , psig , pstd) +c +c +c* 5. compute tendencies. +c* ------------------- +c + 500 continue +c +c explicit solution at all levels for the gravity wave +c implicit solution for the blocked levels + + do 510 jl=kidia,kfdia + zvidis(jl)=0.0 + zdudt(jl)=0.0 + zdvdt(jl)=0.0 + zdtdt(jl)=0.0 + 510 continue +c + ilevp1=klev+1 +c +c + do 524 jk=1,klev +c +c +c do 523 jl=1,kgwd +c ji=kdx(jl) +c Modif vectorisation 02/04/2004 + do 523 ji=kidia,kfdia + if(ktest(ji).eq.1) then + + zdelp=paphm1(ji,jk+1)-paphm1(ji,jk) + ztemp=-rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,ilevp1)*zdelp) + zdudt(ji)=(pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji) + zdvdt(ji)=(pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji) +c +c controle des overshoots: +c + zforc=sqrt(zdudt(ji)**2+zdvdt(ji)**2)+1.E-12 + ztend=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst+1.E-12 + rover=0.25 + if(zforc.ge.rover*ztend)then + zdudt(ji)=rover*ztend/zforc*zdudt(ji) + zdvdt(ji)=rover*ztend/zforc*zdvdt(ji) + endif +c +c fin du controle des overshoots +c + if(jk.ge.ikenvh(ji)) then + zb=1.0-0.18*pgamma(ji)-0.04*pgamma(ji)**2 + zc=0.48*pgamma(ji)+0.3*pgamma(ji)**2 + zconb=2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji)) + zabsv=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2. + zzd1=zb*cos(zpsi(ji,jk))**2+zc*sin(zpsi(ji,jk))**2 + ratio=(cos(zpsi(ji,jk))**2+pgamma(ji)*sin(zpsi(ji,jk))**2)/ + * (pgamma(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2) + zbet=max(0.,2.-1./ratio)*zconb*zzdep(ji,jk)*zzd1*zabsv +c +c simplement oppose au vent +c + zdudt(ji)=-pum1(ji,jk)/ztmst + zdvdt(ji)=-pvm1(ji,jk)/ztmst +c +c projection dans la direction de l'axe principal de l'orographie +cmod zdudt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.) +cmod * +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.)) +cmod * *cos(ptheta(ji)*rpi/180.)/ztmst +cmod zdvdt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.) +cmod * +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.)) +cmod * *sin(ptheta(ji)*rpi/180.)/ztmst + zdudt(ji)=zdudt(ji)*(zbet/(1.+zbet)) + zdvdt(ji)=zdvdt(ji)*(zbet/(1.+zbet)) + end if + pvom(ji,jk)=zdudt(ji) + pvol(ji,jk)=zdvdt(ji) + zust=pum1(ji,jk)+ztmst*zdudt(ji) + zvst=pvm1(ji,jk)+ztmst*zdvdt(ji) + zdis=0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2) + zdedt(ji)=zdis/ztmst + zvidis(ji)=zvidis(ji)+zdis*zdelp + zdtdt(ji)=zdedt(ji)/rcpd +c pte(ji,jk)=zdtdt(ji) +c +c ENCORE UN TRUC POUR EVITER LES EXPLOSIONS +c + pte(ji,jk)=0.0 + + endif + 523 continue + + 524 continue +c +c + return + end + SUBROUTINE orosetup + * ( nlon , ktest + * , kkcrit, kkcrith, kcrit + * , kkenvh, kknu , kknu2 + * , paphm1, papm1 , pum1 , pvm1 , ptm1 , pgeom1, pstd + * , prho , pri , pstab , ptau , pvph ,ppsi, pzdep + * , pulow , pvlow + * , ptheta, pgamma, pmea, ppic, pval + * , pnu , pd1 , pd2 ,pdmod ) +c +c**** *gwsetup* +c +c purpose. +c -------- +c +c** interface. +c ---------- +c from *orodrag* +c +c explicit arguments : +c -------------------- +c ==== inputs === +c ==== outputs === +c +c implicit arguments : none +c -------------------- +c +c method. +c ------- +c +c +c externals. +c ---------- +c +c +c reference. +c ---------- +c +c see ecmwf research department documentation of the "i.f.s." +c +c author. +c ------- +c +c modifications. +c -------------- +c f.lott for the new-gwdrag scheme november 1993 +c +c----------------------------------------------------------------------- + USE dimphy + implicit none +c + +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" + +c----------------------------------------------------------------------- +c +c* 0.1 arguments +c --------- +c + integer nlon + integer jl, jk + real zdelp + + integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon), + * ktest(nlon),kkenvh(nlon) + +c + real paphm1(nlon,klev+1),papm1(nlon,klev),pum1(nlon,klev), + * pvm1(nlon,klev),ptm1(nlon,klev),pgeom1(nlon,klev), + * prho(nlon,klev+1),pri(nlon,klev+1),pstab(nlon,klev+1), + * ptau(nlon,klev+1),pvph(nlon,klev+1),ppsi(nlon,klev+1), + * pzdep(nlon,klev) + real pulow(nlon),pvlow(nlon),ptheta(nlon),pgamma(nlon),pnu(nlon), + * pd1(nlon),pd2(nlon),pdmod(nlon) + real pstd(nlon),pmea(nlon),ppic(nlon),pval(nlon) +c +c----------------------------------------------------------------------- +c +c* 0.2 local arrays +c ------------ +c +c + integer ilevm1, ilevm2, ilevh + real zcons1, zcons2,zcons3, zhgeo + real zu, zphi, zvt1,zvt2, zst, zvar, zdwind, zwind + real zstabm, zstabp, zrhom, zrhop, alpha + real zggeenv, zggeom1,zgvar + logical lo + logical ll1(klon,klev+1) + integer kknu(klon),kknu2(klon),kknub(klon),kknul(klon), + * kentp(klon),ncount(klon) +c + real zhcrit(klon,klev),zvpf(klon,klev), + * zdp(klon,klev) + real znorm(klon),zb(klon),zc(klon), + * zulow(klon),zvlow(klon),znup(klon),znum(klon) +c +c ------------------------------------------------------------------ +c +c* 1. initialization +c -------------- +c +c print *,' entree gwsetup' + 100 continue +c +c ------------------------------------------------------------------ +c +c* 1.1 computational constants +c ----------------------- +c + 110 continue +c + ilevm1=klev-1 + ilevm2=klev-2 + ilevh =klev/3 +c + zcons1=1./rd +cold zcons2=g**2/cpd + zcons2=rg**2/rcpd +cold zcons3=1.5*api + zcons3=1.5*rpi +c +c +c ------------------------------------------------------------------ +c +c* 2. +c -------------- +c + 200 continue +c +c ------------------------------------------------------------------ +c +c* 2.1 define low level wind, project winds in plane of +c* low level wind, determine sector in which to take +c* the variance and set indicator for critical levels. +c +c +c + do 2001 jl=kidia,kfdia + kknu(jl) =klev + kknu2(jl) =klev + kknub(jl) =klev + kknul(jl) =klev + pgamma(jl) =max(pgamma(jl),gtsec) + ll1(jl,klev+1)=.false. + 2001 continue +c +c Ajouter une initialisation (L. Li, le 23fev99): +c + do jk=klev,ilevh,-1 + do jl=kidia,kfdia + ll1(jl,jk)= .FALSE. + ENDDO + ENDDO +c +c* define top of low level flow +c ---------------------------- + do 2002 jk=klev,ilevh,-1 + do 2003 jl=kidia,kfdia + lo=(paphm1(jl,jk)/paphm1(jl,klev+1)).ge.gsigcr + if(lo) then + kkcrit(jl)=jk + endif + zhcrit(jl,jk)=ppic(jl) + zhgeo=pgeom1(jl,jk)/rg + ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk)) + if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then + kknu(jl)=jk + endif + if(.not.ll1(jl,ilevh))kknu(jl)=ilevh + 2003 continue + 2002 continue + do 2004 jk=klev,ilevh,-1 + do 2005 jl=kidia,kfdia + zhcrit(jl,jk)=ppic(jl)-pval(jl) + zhgeo=pgeom1(jl,jk)/rg + ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk)) + if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then + kknu2(jl)=jk + endif + if(.not.ll1(jl,ilevh))kknu2(jl)=ilevh + 2005 continue + 2004 continue + do 2006 jk=klev,ilevh,-1 + do 2007 jl=kidia,kfdia + zhcrit(jl,jk)=amax1(ppic(jl)-pmea(jl),pmea(jl)-pval(jl)) + zhgeo=pgeom1(jl,jk)/rg + ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk)) + if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then + kknub(jl)=jk + endif + if(.not.ll1(jl,ilevh))kknub(jl)=ilevh + 2007 continue + 2006 continue +c + do 2010 jl=kidia,kfdia + kknu(jl)=min(kknu(jl),nktopg) + kknu2(jl)=min(kknu2(jl),nktopg) + kknub(jl)=min(kknub(jl),nktopg) + kknul(jl)=klev + 2010 continue +c + + 210 continue +c +c +cc* initialize various arrays +c + do 2107 jl=kidia,kfdia + prho(jl,klev+1) =0.0 + pstab(jl,klev+1) =0.0 + pstab(jl,1) =0.0 + pri(jl,klev+1) =9999.0 + ppsi(jl,klev+1) =0.0 + pri(jl,1) =0.0 + pvph(jl,1) =0.0 + pulow(jl) =0.0 + pvlow(jl) =0.0 + zulow(jl) =0.0 + zvlow(jl) =0.0 + kkcrith(jl) =klev + kkenvh(jl) =klev + kentp(jl) =klev + kcrit(jl) =1 + ncount(jl) =0 + ll1(jl,klev+1) =.false. + 2107 continue +c +c* define low-level flow +c --------------------- +c + do 223 jk=klev,2,-1 + do 222 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1) + prho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) + pstab(jl,jk)=2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))* + * (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk)) + pstab(jl,jk)=max(pstab(jl,jk),gssec) + endif + 222 continue + 223 continue +c +c******************************************************************** +c +c* define blocked flow +c ------------------- + do 2115 jk=klev,ilevh,-1 + do 2116 jl=kidia,kfdia + if(jk.ge.kknub(jl).and.jk.le.kknul(jl)) then + pulow(jl)=pulow(jl)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + pvlow(jl)=pvlow(jl)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + end if + 2116 continue + 2115 continue + do 2110 jl=kidia,kfdia + pulow(jl)=pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl))) + pvlow(jl)=pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl))) + znorm(jl)=max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec) + pvph(jl,klev+1)=znorm(jl) + 2110 continue +c +c******* setup orography axes and define plane of profiles ******* +c + do 2112 jl=kidia,kfdia + lo=(pulow(jl).lt.gvsec).and.(pulow(jl).ge.-gvsec) + if(lo) then + zu=pulow(jl)+2.*gvsec + else + zu=pulow(jl) + endif + zphi=atan(pvlow(jl)/zu) + ppsi(jl,klev+1)=ptheta(jl)*rpi/180.-zphi + zb(jl)=1.-0.18*pgamma(jl)-0.04*pgamma(jl)**2 + zc(jl)=0.48*pgamma(jl)+0.3*pgamma(jl)**2 + pd1(jl)=zb(jl)-(zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2) + pd2(jl)=(zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))*cos(ppsi(jl,klev+1)) + pdmod(jl)=sqrt(pd1(jl)**2+pd2(jl)**2) + 2112 continue +c +c ************ define flow in plane of lowlevel stress ************* +c + do 213 jk=1,klev + do 212 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zvt1 =pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk) + zvt2 =-pvlow(jl)*pum1(jl,jk)+pulow(jl)*pvm1(jl,jk) + zvpf(jl,jk)=(zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl)) + endif + ptau(jl,jk) =0.0 + pzdep(jl,jk) =0.0 + ppsi(jl,jk) =0.0 + ll1(jl,jk) =.false. + 212 continue + 213 continue + do 215 jk=2,klev + do 214 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1) + pvph(jl,jk)=((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+ + * (papm1(jl,jk)-paphm1(jl,jk))*zvpf(jl,jk-1)) + * /zdp(jl,jk) + if(pvph(jl,jk).lt.gvsec) then + pvph(jl,jk)=gvsec + kcrit(jl)=jk + endif + endif + 214 continue + 215 continue +c +c +c* 2.2 brunt-vaisala frequency and density at half levels. +c + 220 continue +c + do 2211 jk=ilevh,klev + do 221 jl=kidia,kfdia + if(ktest(jl).eq.1) then + if(jk.ge.(kknub(jl)+1).and.jk.le.kknul(jl)) then + zst=zcons2/ptm1(jl,jk)*(1.-rcpd*prho(jl,jk)* + * (ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk)) + pstab(jl,klev+1)=pstab(jl,klev+1)+zst*zdp(jl,jk) + pstab(jl,klev+1)=max(pstab(jl,klev+1),gssec) + prho(jl,klev+1)=prho(jl,klev+1)+paphm1(jl,jk)*2.*zdp(jl,jk) + * *zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) + endif + endif + 221 continue + 2211 continue +c + do 2212 jl=kidia,kfdia + pstab(jl,klev+1)=pstab(jl,klev+1)/(papm1(jl,kknul(jl)) + * -papm1(jl,kknub(jl))) + prho(jl,klev+1)=prho(jl,klev+1)/(papm1(jl,kknul(jl)) + * -papm1(jl,kknub(jl))) + zvar=pstd(jl) + 2212 continue +c +c* 2.3 mean flow richardson number. +c* and critical height for froude layer +c + 230 continue +c + do 232 jk=2,klev + do 231 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zdwind=max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)),gvsec) + pri(jl,jk)=pstab(jl,jk)*(zdp(jl,jk) + * /(rg*prho(jl,jk)*zdwind))**2 + pri(jl,jk)=max(pri(jl,jk),grcrit) + endif + 231 continue + 232 continue + +c +c +c* define top of 'envelope' layer +c ---------------------------- + + do 233 jl=kidia,kfdia + pnu (jl)=0.0 + znum(jl)=0.0 + 233 continue + + do 234 jk=2,klev-1 + do 234 jl=kidia,kfdia + + if(ktest(jl).eq.1) then + + if (jk.ge.kknub(jl)) then + + znum(jl)=pnu(jl) + zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ + * max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec) + zwind=max(sqrt(zwind**2),gvsec) + zdelp=paphm1(jl,jk+1)-paphm1(jl,jk) + zstabm=sqrt(max(pstab(jl,jk ),gssec)) + zstabp=sqrt(max(pstab(jl,jk+1),gssec)) + zrhom=prho(jl,jk ) + zrhop=prho(jl,jk+1) + pnu(jl) = pnu(jl) + (zdelp/rg)* + * ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind + if((znum(jl).le.gfrcrit).and.(pnu(jl).gt.gfrcrit) + * .and.(kkenvh(jl).eq.klev)) + * kkenvh(jl)=jk + + endif + + endif + + 234 continue + +c calculation of a dynamical mixing height for the breaking +c of gravity waves: + + + do 235 jl=kidia,kfdia + znup(jl)=0.0 + znum(jl)=0.0 + 235 continue + + do 236 jk=klev-1,2,-1 + do 236 jl=kidia,kfdia + + if(ktest(jl).eq.1) then + + znum(jl)=znup(jl) + zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ + * max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec) + zwind=max(sqrt(zwind**2),gvsec) + zdelp=paphm1(jl,jk+1)-paphm1(jl,jk) + zstabm=sqrt(max(pstab(jl,jk ),gssec)) + zstabp=sqrt(max(pstab(jl,jk+1),gssec)) + zrhom=prho(jl,jk ) + zrhop=prho(jl,jk+1) + znup(jl) = znup(jl) + (zdelp/rg)* + * ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind + if((znum(jl).le.rpi/2.).and.(znup(jl).gt.rpi/2.) + * .and.(kkcrith(jl).eq.klev)) + * kkcrith(jl)=jk + + endif + + 236 continue + + do 237 jl=kidia,kfdia + kkcrith(jl)=min0(kkcrith(jl),kknu2(jl)) + kkcrith(jl)=max0(kkcrith(jl),ilevh*2) + 237 continue +c +c directional info for flow blocking ************************* +c + do 251 jk=ilevh,klev + do 252 jl=kidia,kfdia + if(jk.ge.kkenvh(jl)) then + lo=(pum1(jl,jk).lt.gvsec).and.(pum1(jl,jk).ge.-gvsec) + if(lo) then + zu=pum1(jl,jk)+2.*gvsec + else + zu=pum1(jl,jk) + endif + zphi=atan(pvm1(jl,jk)/zu) + ppsi(jl,jk)=ptheta(jl)*rpi/180.-zphi + end if + 252 continue + 251 continue +c forms the vertical 'leakiness' ************************** + + alpha=3. + + do 254 jk=ilevh,klev + do 253 jl=kidia,kfdia + if(jk.ge.kkenvh(jl)) then + zggeenv=amax1(1., + * (pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)-1))/2.) + zggeom1=amax1(pgeom1(jl,jk),1.) + zgvar=amax1(pstd(jl)*rg,1.) +cmod pzdep(jl,jk)=sqrt((zggeenv-zggeom1)/(zggeom1+zgvar)) + pzdep(jl,jk)=(pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl, jk))/ + * (pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,klev)) + end if + 253 continue + 254 continue + + 260 continue + + return + end + SUBROUTINE gwstress + * ( nlon , nlev + * , ktest, kcrit, kkenvh + * , kknu + * , prho , pstab , pvph , pstd, psig + * , pmea , ppic , ptau + * , pgeom1 , pdmod ) +c +c**** *gwstress* +c +c purpose. +c -------- +c +c** interface. +c ---------- +c call *gwstress* from *gwdrag* +c +c explicit arguments : +c -------------------- +c ==== inputs === +c ==== outputs === +c +c implicit arguments : none +c -------------------- +c +c method. +c ------- +c +c +c externals. +c ---------- +c +c +c reference. +c ---------- +c +c see ecmwf research department documentation of the "i.f.s." +c +c author. +c ------- +c +c modifications. +c -------------- +c f. lott put the new gwd on ifs 22/11/93 +c +c----------------------------------------------------------------------- + USE dimphy + implicit none +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" + +c----------------------------------------------------------------------- +c +c* 0.1 arguments +c --------- +c + integer nlon, nlev + integer kcrit(nlon), + * ktest(nlon),kkenvh(nlon),kknu(nlon) +c + real prho(nlon,nlev+1),pstab(nlon,nlev+1),ptau(nlon,nlev+1), + * pvph(nlon,nlev+1), + * pgeom1(nlon,nlev),pstd(nlon) +c + real psig(nlon) + real pmea(nlon),ppic(nlon) + real pdmod(nlon) +c +c----------------------------------------------------------------------- +c +c* 0.2 local arrays +c ------------ + integer jl + real zblock, zvar, zeff + logical lo +c +c----------------------------------------------------------------------- +c +c* 0.3 functions +c --------- +c ------------------------------------------------------------------ +c +c* 1. initialization +c -------------- +c + 100 continue +c +c* 3.1 gravity wave stress. +c + 300 continue +c +c + do 301 jl=kidia,kfdia + if(ktest(jl).eq.1) then + +c effective mountain height above the blocked flow + + if(kkenvh(jl).eq.klev)then + zblock=0.0 + else + zblock=(pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)+1))/2./rg + endif + + zvar=ppic(jl)-pmea(jl) + zeff=amax1(0.,zvar-zblock) + + ptau(jl,klev+1)=prho(jl,klev+1)*gkdrag*psig(jl)*zeff**2 + * /4./pstd(jl)*pvph(jl,klev+1)*pdmod(jl)*sqrt(pstab(jl,klev+1)) + +c too small value of stress or low level flow include critical level +c or low level flow: gravity wave stress nul. + + lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl)) + * .or.(pvph(jl,klev+1).lt.gvcrit) +c if(lo) ptau(jl,klev+1)=0.0 + + else + + ptau(jl,klev+1)=0.0 + + endif + + 301 continue +c + return + end + SUBROUTINE GWPROFIL + * ( NLON, NLEV + * , kgwd, kdx , ktest + * , KKCRITH, KCRIT + * , PAPHM1, PRHO , PSTAB , PVPH , PRI , PTAU + * , pdmod , psig , pvar) + +C**** *GWPROFIL* +C +C PURPOSE. +C -------- +C +C** INTERFACE. +C ---------- +C FROM *GWDRAG* +C +C EXPLICIT ARGUMENTS : +C -------------------- +C ==== INPUTS === +C ==== OUTPUTS === +C +C IMPLICIT ARGUMENTS : NONE +C -------------------- +C +C METHOD: +C ------- +C THE STRESS PROFILE FOR GRAVITY WAVES IS COMPUTED AS FOLLOWS: +C IT IS CONSTANT (NO GWD) AT THE LEVELS BETWEEN THE GROUND +C AND THE TOP OF THE BLOCKED LAYER (KKENVH). +C IT DECREASES LINEARLY WITH HEIGHTS FROM THE TOP OF THE +C BLOCKED LAYER TO 3*VAROR (kKNU), TO SIMULATES LEE WAVES OR +C NONLINEAR GRAVITY WAVE BREAKING. +C ABOVE IT IS CONSTANT, EXCEPT WHEN THE WAVE ENCOUNTERS A CRITICAL +C LEVEL (KCRIT) OR WHEN IT BREAKS. +C +C +C +C EXTERNALS. +C ---------- +C +C +C REFERENCE. +C ---------- +C +C SEE ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "I.F.S." +C +C AUTHOR. +C ------- +C +C MODIFICATIONS. +C -------------- +C PASSAGE OF THE NEW GWDRAG TO I.F.S. (F. LOTT, 22/11/93) +C----------------------------------------------------------------------- + USE dimphy + implicit none +C + +C + +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" + +C----------------------------------------------------------------------- +C +C* 0.1 ARGUMENTS +C --------- +C + integer nlon,nlev + INTEGER KKCRITH(NLON),KCRIT(NLON) + * ,kdx(nlon) , ktest(nlon) + +C + REAL PAPHM1(NLON,NLEV+1), PSTAB(NLON,NLEV+1), + * PRHO (NLON,NLEV+1), PVPH (NLON,NLEV+1), + * PRI (NLON,NLEV+1), PTAU(NLON,NLEV+1) + + REAL pdmod (NLON) , psig(NLON), + * pvar(NLON) + +C----------------------------------------------------------------------- +C +C* 0.2 LOCAL ARRAYS +C ------------ +C + integer ilevh, ji, kgwd, jl, jk + real zsqr, zalfa, zriw, zdel, zb, zalpha,zdz2n + real zdelp, zdelpt + REAL ZDZ2 (KLON,KLEV) , ZNORM(KLON) , zoro(KLON) + REAL ZTAU (KLON,KLEV+1) +C +C----------------------------------------------------------------------- +C +C* 1. INITIALIZATION +C -------------- +C +c print *,' entree gwprofil' + 100 CONTINUE +C +C +C* COMPUTATIONAL CONSTANTS. +C ------------- ---------- +C + ilevh=KLEV/3 +C +c DO 400 ji=1,kgwd +c jl=kdx(ji) +c Modif vectorisation 02/04/2004 + DO 400 jl=kidia,kfdia + if (ktest(jl).eq.1) then + Zoro(JL)=Psig(JL)*Pdmod(JL)/4./max(pvar(jl),1.0) + ZTAU(JL,KLEV+1)=PTAU(JL,KLEV+1) + endif + 400 CONTINUE + +C + DO 430 JK=KLEV,2,-1 +C +C +C* 4.1 CONSTANT WAVE STRESS UNTIL TOP OF THE +C BLOCKING LAYER. + 410 CONTINUE +C +c DO 411 ji=1,kgwd +c jl=kdx(ji) +c Modif vectorisation 02/04/2004 + do 411 jl=kidia,kfdia + if (ktest(jl).eq.1) then + IF(JK.GT.KKCRITH(JL)) THEN + PTAU(JL,JK)=ZTAU(JL,KLEV+1) +C ENDIF +C IF(JK.EQ.KKCRITH(JL)) THEN + ELSE + PTAU(JL,JK)=GRAHILO*ZTAU(JL,KLEV+1) + ENDIF + endif + 411 CONTINUE +C +C* 4.15 CONSTANT SHEAR STRESS UNTIL THE TOP OF THE +C LOW LEVEL FLOW LAYER. + 415 CONTINUE +C +C +C* 4.2 WAVE DISPLACEMENT AT NEXT LEVEL. +C + 420 CONTINUE +C +c DO 421 ji=1,kgwd +c jl=kdx(ji) +c Modif vectorisation 02/04/2004 + do 421 jl=kidia,kfdia + if(ktest(jl).eq.1) then + IF(JK.LT.KKCRITH(JL)) THEN + ZNORM(JL)=gkdrag*PRHO(JL,JK)*SQRT(PSTAB(JL,JK))*PVPH(JL,JK) + * *zoro(jl) + ZDZ2(JL,JK)=PTAU(JL,JK+1)/max(ZNORM(JL),gssec) + ENDIF + endif + 421 CONTINUE +C +C* 4.3 WAVE RICHARDSON NUMBER, NEW WAVE DISPLACEMENT +C* AND STRESS: BREAKING EVALUATION AND CRITICAL +C LEVEL +C + +c DO 431 ji=1,kgwd +c jl=Kdx(ji) +c Modif vectorisation 02/04/2004 + do 431 jl=kidia,kfdia + if(ktest(jl).eq.1) then + + IF(JK.LT.KKCRITH(JL)) THEN + IF((PTAU(JL,JK+1).LT.GTSEC).OR.(JK.LE.KCRIT(JL))) THEN + PTAU(JL,JK)=0.0 + ELSE + ZSQR=SQRT(PRI(JL,JK)) + ZALFA=SQRT(PSTAB(JL,JK)*ZDZ2(JL,JK))/PVPH(JL,JK) + ZRIW=PRI(JL,JK)*(1.-ZALFA)/(1+ZALFA*ZSQR)**2 + IF(ZRIW.LT.GRCRIT) THEN + ZDEL=4./ZSQR/GRCRIT+1./GRCRIT**2+4./GRCRIT + ZB=1./GRCRIT+2./ZSQR + ZALPHA=0.5*(-ZB+SQRT(ZDEL)) + ZDZ2N=(PVPH(JL,JK)*ZALPHA)**2/PSTAB(JL,JK) + PTAU(JL,JK)=ZNORM(JL)*ZDZ2N + ELSE + PTAU(JL,JK)=ZNORM(JL)*ZDZ2(JL,JK) + ENDIF + PTAU(JL,JK)=MIN(PTAU(JL,JK),PTAU(JL,JK+1)) + ENDIF + ENDIF + endif + 431 CONTINUE + + 430 CONTINUE + 440 CONTINUE + +C REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL + +c DO 530 ji=1,kgwd +c jl=kdx(ji) +c Modif vectorisation 02/04/2004 + do 530 jl=kidia,kfdia + if(ktest(jl).eq.1) then + ZTAU(JL,KKCRITH(JL))=PTAU(JL,KKCRITH(JL)) + ZTAU(JL,NSTRA)=PTAU(JL,NSTRA) + endif + 530 CONTINUE + + DO 531 JK=1,KLEV + +c DO 532 ji=1,kgwd +c jl=kdx(ji) +c Modif vectorisation 02/04/2004 + do 532 jl=kidia,kfdia + if(ktest(jl).eq.1) then + + + IF(JK.GT.KKCRITH(JL))THEN + + ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KLEV+1 ) + ZDELPT=PAPHM1(JL,KKCRITH(JL))-PAPHM1(JL,KLEV+1 ) + PTAU(JL,JK)=ZTAU(JL,KLEV+1 ) + + . (ZTAU(JL,KKCRITH(JL))-ZTAU(JL,KLEV+1 ) )* + . ZDELP/ZDELPT + + ENDIF + + endif + 532 CONTINUE + +C REORGANISATION IN THE STRATOSPHERE + +c DO 533 ji=1,kgwd +c jl=kdx(ji) +c Modif vectorisation 02/04/2004 + do 533 jl=kidia,kfdia + if(ktest(jl).eq.1) then + + + IF(JK.LT.NSTRA)THEN + + ZDELP =PAPHM1(JL,NSTRA) + ZDELPT=PAPHM1(JL,JK) + PTAU(JL,JK)=ZTAU(JL,NSTRA)*ZDELPT/ZDELP + + ENDIF + + endif + 533 CONTINUE + +C REORGANISATION IN THE TROPOSPHERE + +c DO 534 ji=1,kgwd +c jl=kdx(ji) +c Modif vectorisation 02/04/2004 + do 534 jl=kidia,kfdia + if(ktest(jl).eq.1) then + + + IF(JK.LT.KKCRITH(JL).AND.JK.GT.NSTRA)THEN + + ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KKCRITH(JL)) + ZDELPT=PAPHM1(JL,NSTRA)-PAPHM1(JL,KKCRITH(JL)) + PTAU(JL,JK)=ZTAU(JL,KKCRITH(JL)) + + * (ZTAU(JL,NSTRA)-ZTAU(JL,KKCRITH(JL)))*ZDELP + . /ZDELPT + + ENDIF + endif + 534 CONTINUE + + + 531 CONTINUE + + + RETURN + END + SUBROUTINE lift_noro (nlon,nlev,dtime,paprs,pplay, + e plat,pmea,pstd, ppic, + e ktest, + e t, u, v, + s pulow, pvlow, pustr, pvstr, + s d_t, d_u, d_v) +c + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): F.Lott (LMD/CNRS) date: 19950201 +c Objet: Frottement de la montagne Interface +c====================================================================== +c Arguments: +c dtime---input-R- pas d'integration (s) +c paprs---input-R-pression pour chaque inter-couche (en Pa) +c pplay---input-R-pression pour le mileu de chaque couche (en Pa) +c t-------input-R-temperature (K) +c u-------input-R-vitesse horizontale (m/s) +c v-------input-R-vitesse horizontale (m/s) +c +c d_t-----output-R-increment de la temperature +c d_u-----output-R-increment de la vitesse u +c d_v-----output-R-increment de la vitesse v +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c ARGUMENTS +c + INTEGER nlon,nlev + REAL dtime + REAL paprs(klon,klev+1) + REAL pplay(klon,klev) + REAL plat(nlon),pmea(nlon) + REAL pstd(nlon) + REAL ppic(nlon) + REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon) + REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev) + REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev) +c + INTEGER i, k, ktest(nlon) +c +c Variables locales: +c + REAL zgeom(klon,klev) + REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev) + REAL pt(klon,klev), pu(klon,klev), pv(klon,klev) + REAL papmf(klon,klev),papmh(klon,klev+1) +c +c initialiser les variables de sortie (pour securite) +c + DO i = 1,klon + pulow(i) = 0.0 + pvlow(i) = 0.0 + pustr(i) = 0.0 + pvstr(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_u(i,k) = 0.0 + d_v(i,k) = 0.0 + pdudt(i,k)=0.0 + pdvdt(i,k)=0.0 + pdtdt(i,k)=0.0 + ENDDO + ENDDO +c +c preparer les variables d'entree (attention: l'ordre des niveaux +c verticaux augmente du haut vers le bas) +c + DO k = 1, klev + DO i = 1, klon + pt(i,k) = t(i,klev-k+1) + pu(i,k) = u(i,klev-k+1) + pv(i,k) = v(i,klev-k+1) + papmf(i,k) = pplay(i,klev-k+1) + ENDDO + ENDDO + DO k = 1, klev+1 + DO i = 1, klon + papmh(i,k) = paprs(i,klev-k+2) + ENDDO + ENDDO + DO i = 1, klon + zgeom(i,klev) = RD * pt(i,klev) + . * LOG(papmh(i,klev+1)/papmf(i,klev)) + ENDDO + DO k = klev-1, 1, -1 + DO i = 1, klon + zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0 + . * LOG(papmf(i,k+1)/papmf(i,k)) + ENDDO + ENDDO +c +c appeler la routine principale +c + CALL OROLIFT(klon,klev,ktest, + . dtime, + . papmh, zgeom, + . pt, pu, pv, + . plat,pmea, pstd, ppic, + . pulow,pvlow, + . pdudt,pdvdt,pdtdt) +C + DO k = 1, klev + DO i = 1, klon + d_u(i,klev+1-k) = dtime*pdudt(i,k) + d_v(i,klev+1-k) = dtime*pdvdt(i,k) + d_t(i,klev+1-k) = dtime*pdtdt(i,k) + pustr(i) = pustr(i) +cIM BUG . +RG*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k)) + . +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG + pvstr(i) = pvstr(i) +cIM BUG . +RG*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k)) + . +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG + ENDDO + ENDDO +c + RETURN + END + SUBROUTINE OROLIFT( NLON,NLEV + I , KTEST + R , PTSPHY + R , PAPHM1,PGEOM1,PTM1,PUM1,PVM1 + R , PLAT + R , PMEA, PVAROR, ppic +C OUTPUTS + R , PULOW,PVLOW + R , PVOM,PVOL,PTE ) + +C +C**** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT. +C +C PURPOSE. +C -------- +C +C** INTERFACE. +C ---------- +C CALLED FROM *lift_noro +C ---------- +C +C AUTHOR. +C ------- +C F.LOTT LMD 22/11/95 +C + USE dimphy + implicit none +C +C +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" +C----------------------------------------------------------------------- +C +C* 0.1 ARGUMENTS +C --------- +C +C + integer nlon, nlev + REAL PTE(NLON,NLEV), + * PVOL(NLON,NLEV), + * PVOM(NLON,NLEV), + * PULOW(NLON), + * PVLOW(NLON) + REAL PUM1(NLON,NLEV), + * PVM1(NLON,NLEV), + * PTM1(NLON,NLEV), + * PLAT(NLON),PMEA(NLON), + * PVAROR(NLON), + * ppic(NLON), + * PGEOM1(NLON,NLEV), + * PAPHM1(NLON,NLEV+1) +C + INTEGER KTEST(NLON) + real ptsphy +C----------------------------------------------------------------------- +C +C* 0.2 LOCAL ARRAYS +C ------------ + logical lifthigh +cym integer klevm1, jl, ilevh, jk + integer jl, ilevh, jk + real zcons1, ztmst, zrtmst,zpi, zhgeo + real zdelp, zslow, zsqua, zscav, zbet + INTEGER + * IKNUB(klon), + * IKNUL(klon) + LOGICAL LL1(KLON,KLEV+1) +C + REAL ZTAU(KLON,KLEV+1), + * ZTAV(KLON,KLEV+1), + * ZRHO(KLON,KLEV+1) + REAL ZDUDT(KLON), + * ZDVDT(KLON) + REAL ZHCRIT(KLON,KLEV) +C----------------------------------------------------------------------- +C +C* 1.1 INITIALIZATIONS +C --------------- + + LIFTHIGH=.FALSE. + + IF(NLON.NE.KLON.OR.NLEV.NE.KLEV)STOP + ZCONS1=1./RD +cym KLEVM1=KLEV-1 + ZTMST=PTSPHY + ZRTMST=1./ZTMST + ZPI=ACOS(-1.) +C + DO 1001 JL=kidia,kfdia + ZRHO(JL,KLEV+1) =0.0 + PULOW(JL) =0.0 + PVLOW(JL) =0.0 + iknub(JL) =klev + iknul(JL) =klev + ilevh=klev/3 + ll1(jl,klev+1)=.false. + DO 1000 JK=1,KLEV + PVOM(JL,JK)=0.0 + PVOL(JL,JK)=0.0 + PTE (JL,JK)=0.0 + 1000 CONTINUE + 1001 CONTINUE + +C +C* 2.1 DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF +C* LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE +C* THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS. +C +C +C + DO 2006 JK=KLEV,1,-1 + DO 2007 JL=kidia,kfdia + IF(KTEST(JL).EQ.1) THEN + ZHCRIT(JL,JK)=amax1(Ppic(JL)-pmea(JL),100.) + ZHGEO=PGEOM1(JL,JK)/RG + ll1(JL,JK)=(ZHGEO.GT.ZHCRIT(JL,JK)) + IF(ll1(JL,JK).neqv.ll1(JL,JK+1)) THEN + iknub(JL)=JK + ENDIF + ENDIF + 2007 CONTINUE + 2006 CONTINUE +C + do 2010 jl=kidia,kfdia + IF(KTEST(JL).EQ.1) THEN + iknub(jl)=max(iknub(jl),klev/2) + iknul(jl)=max(iknul(jl),2*klev/3) + if(iknub(jl).gt.nktopg) iknub(jl)=nktopg + if(iknub(jl).eq.nktopg) iknul(jl)=klev + if(iknub(jl).eq.iknul(jl)) iknub(jl)=iknul(jl)-1 + ENDIF + 2010 continue + +C do 2011 jl=kidia,kfdia +C IF(KTEST(JL).EQ.1) THEN +C print *,' iknul= ',iknul(jl),' iknub=',iknub(jl) +C ENDIF +C2011 continue + +C PRINT *,' DANS OROLIFT: 2010' + + DO 223 JK=KLEV,2,-1 + DO 222 JL=kidia,kfdia + ZRHO(JL,JK)=2.*PAPHM1(JL,JK)*ZCONS1/(PTM1(JL,JK)+PTM1(JL,JK-1)) + 222 CONTINUE + 223 CONTINUE +C PRINT *,' DANS OROLIFT: 223' + +C******************************************************************** +C +C* DEFINE LOW LEVEL FLOW +C ------------------- + DO 2115 JK=klev,1,-1 + DO 2116 JL=kidia,kfdia + IF(KTEST(JL).EQ.1) THEN + if(jk.ge.iknub(jl).and.jk.le.iknul(jl)) then + pulow(JL)=pulow(JL)+PUM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK)) + pvlow(JL)=pvlow(JL)+PVM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK)) + zrho(JL,klev+1)=zrho(JL,klev+1) + * +zrho(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK)) + end if + ENDIF + 2116 CONTINUE + 2115 CONTINUE + DO 2110 JL=kidia,kfdia + IF(KTEST(JL).EQ.1) THEN + pulow(JL)=pulow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl))) + pvlow(JL)=pvlow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl))) + zrho(JL,klev+1)=zrho(JL,klev+1) + * /(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl))) + ENDIF + 2110 CONTINUE + + +200 CONTINUE + +C*********************************************************** +C +C* 3. COMPUTE MOUNTAIN LIFT +C + 300 CONTINUE +C + DO 301 JL=kidia,kfdia + IF(KTEST(JL).EQ.1) THEN + ZTAU(JL,KLEV+1)= - GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA* +C * (2*PVAROR(JL)+PMEA(JL))* + * 2*PVAROR(JL)* + * SIN(ZPI/180.*PLAT(JL))*PVLOW(JL) + ZTAV(JL,KLEV+1)= GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA* +C * (2*PVAROR(JL)+PMEA(JL))* + * 2*PVAROR(JL)* + * SIN(ZPI/180.*PLAT(JL))*PULOW(JL) + ELSE + ZTAU(JL,KLEV+1)=0.0 + ZTAV(JL,KLEV+1)=0.0 + ENDIF +301 CONTINUE + +C +C* 4. COMPUTE LIFT PROFILE +C* -------------------- +C + + 400 CONTINUE + + DO 401 JK=1,KLEV + DO 401 JL=kidia,kfdia + IF(KTEST(JL).EQ.1) THEN + ZTAU(JL,JK)=ZTAU(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1) + ZTAV(JL,JK)=ZTAV(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1) + ELSE + ZTAU(JL,JK)=0.0 + ZTAV(JL,JK)=0.0 + ENDIF +401 CONTINUE +C +C +C* 5. COMPUTE TENDENCIES. +C* ------------------- + IF(LIFTHIGH)THEN +C + 500 CONTINUE +C PRINT *,' DANS OROLIFT: 500' +C +C EXPLICIT SOLUTION AT ALL LEVELS +C + DO 524 JK=1,klev + DO 523 JL=KIDIA,KFDIA + IF(KTEST(JL).EQ.1) THEN + ZDELP=PAPHM1(JL,JK+1)-PAPHM1(JL,JK) + ZDUDT(JL)=-RG*(ZTAU(JL,JK+1)-ZTAU(JL,JK))/ZDELP + ZDVDT(JL)=-RG*(ZTAV(JL,JK+1)-ZTAV(JL,JK))/ZDELP + ENDIF + 523 CONTINUE + 524 CONTINUE +C +C PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY +C + DO 530 JK=1,klev + DO 530 JL=KIDIA,KFDIA + IF(KTEST(JL).EQ.1) THEN + + ZSLOW=SQRT(PULOW(JL)**2+PVLOW(JL)**2) + ZSQUA=AMAX1(SQRT(PUM1(JL,JK)**2+PVM1(JL,JK)**2),GVSEC) + ZSCAV=-ZDUDT(JL)*PVM1(JL,JK)+ZDVDT(JL)*PUM1(JL,JK) + IF(ZSQUA.GT.GVSEC)THEN + PVOM(JL,JK)=-ZSCAV*PVM1(JL,JK)/ZSQUA**2 + PVOL(JL,JK)= ZSCAV*PUM1(JL,JK)/ZSQUA**2 + ELSE + PVOM(JL,JK)=0.0 + PVOL(JL,JK)=0.0 + ENDIF + ZSQUA=SQRT(PUM1(JL,JK)**2+PUM1(JL,JK)**2) + IF(ZSQUA.LT.ZSLOW)THEN + PVOM(JL,JK)=ZSQUA/ZSLOW*PVOM(JL,JK) + PVOL(JL,JK)=ZSQUA/ZSLOW*PVOL(JL,JK) + ENDIF + + ENDIF +530 CONTINUE +C +C 6. LOW LEVEL LIFT, SEMI IMPLICIT: +C ---------------------------------- + + ELSE + + DO 601 JL=KIDIA,KFDIA + IF(KTEST(JL).EQ.1) THEN + DO JK=KLEV,IKNUB(JL),-1 + ZBET=GKLIFT*2.*ROMEGA*SIN(ZPI/180.*PLAT(JL))*ztmst* + * (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL, JK))/ + * (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL,KLEV)) + ZDUDT(JL)=-PUM1(JL,JK)/ztmst/(1+ZBET**2) + ZDVDT(JL)=-PVM1(JL,JK)/ztmst/(1+ZBET**2) + PVOM(JL,JK)= ZBET**2*ZDUDT(JL) - ZBET *ZDVDT(JL) + PVOL(JL,JK)= ZBET *ZDUDT(JL) + ZBET**2*ZDVDT(JL) + ENDDO + ENDIF + 601 CONTINUE + + ENDIF + + RETURN + END + + + SUBROUTINE SUGWD(NLON,NLEV,paprs,pplay) + USE dimphy + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz +c USE parallel +C +C**** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG +C +C PURPOSE. +C -------- +C INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE +C GRAVITY WAVE DRAG PARAMETRIZATION. +C +C** INTERFACE. +C ---------- +C CALL *SUGWD* FROM *SUPHEC* +C ----- ------ +C +C EXPLICIT ARGUMENTS : +C -------------------- +C PSIG : VERTICAL COORDINATE TABLE +C NLEV : NUMBER OF MODEL LEVELS +C +C IMPLICIT ARGUMENTS : +C -------------------- +C COMMON YOEGWD +C +C METHOD. +C ------- +C SEE DOCUMENTATION +C +C EXTERNALS. +C ---------- +C NONE +C +C REFERENCE. +C ---------- +C ECMWF Research Department documentation of the IFS +C +C AUTHOR. +C ------- +C MARTIN MILLER *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 90-01-01 +C ------------------------------------------------------------------ + implicit none +C +C ----------------------------------------------------------------- +#include "YOEGWD.h" +C ---------------------------------------------------------------- +C + integer nlon,nlev, jk + REAL paprs(nlon,nlev+1) + REAL pplay(nlon,nlev) + real zpr,zstra,zsigt,zpm1r + REAL :: pplay_glo(klon_glo,nlev) + REAL :: paprs_glo(klon_glo,nlev+1) + +C +C* 1. SET THE VALUES OF THE PARAMETERS +C -------------------------------- +C + 100 CONTINUE +C + PRINT *,' DANS SUGWD NLEV=',NLEV + GHMAX=10000. +C + ZPR=100000. + ZSTRA=0.1 + ZSIGT=0.94 +cold ZPR=80000. +cold ZSIGT=0.85 +C + + CALL gather(pplay,pplay_glo) + CALL bcast(pplay_glo) + CALL gather(paprs,paprs_glo) + CALL bcast(paprs_glo) + + + DO 110 JK=1,NLEV + ZPM1R=pplay_glo((klon_glo/2)+1,jk)/paprs_glo((klon_glo/2)+1,1) + IF(ZPM1R.GE.ZSIGT)THEN + nktopg=JK + ENDIF + ZPM1R=pplay_glo((klon_glo/2)+1,jk)/paprs_glo((klon_glo/2)+1,1) + IF(ZPM1R.GE.ZSTRA)THEN + NSTRA=JK + ENDIF + 110 CONTINUE + + +c +c inversion car dans orodrag on compte les niveaux a l'envers + nktopg=nlev-nktopg+1 + nstra=nlev-nstra + print *,' DANS SUGWD nktopg=', nktopg + print *,' DANS SUGWD nstra=', nstra +C + GSIGCR=0.80 +C + GKDRAG=0.2 + GRAHILO=1. + GRCRIT=0.01 + GFRCRIT=1.0 + GKWAKE=0.50 +C + GKLIFT=0.50 + GVCRIT =0.0 +C +C +C ---------------------------------------------------------------- +C +C* 2. SET VALUES OF SECURITY PARAMETERS +C --------------------------------- +C + 200 CONTINUE +C + GVSEC=0.10 + GSSEC=1.E-12 +C + GTSEC=1.E-07 +C +C ---------------------------------------------------------------- +C + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/orografi_strato.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/orografi_strato.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/orografi_strato.F (revision 1280) @@ -0,0 +1,2052 @@ + SUBROUTINE drag_noro_strato (nlon,nlev,dtime,paprs,pplay, + e pmea,pstd, psig, pgam, pthe,ppic,pval, + e kgwd,kdx,ktest, + e t, u, v, + s pulow, pvlow, pustr, pvstr, + s d_t, d_u, d_v) +c + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): F.Lott (LMD/CNRS) date: 19950201 +c Object: Mountain drag interface. Made necessary because: +C 1. in the LMD-GCM Layers are from bottom to top, +C contrary to most European GCM. +c 2. the altitude above ground of each model layers +c needs to be known (variable zgeom) +c====================================================================== +c Explicit Arguments: +c ================== +c nlon----input-I-Total number of horizontal points that get into physics +c nlev----input-I-Number of vertical levels +c dtime---input-R-Time-step (s) +c paprs---input-R-Pressure in semi layers (Pa) +c pplay---input-R-Pressure model-layers (Pa) +c t-------input-R-temperature (K) +c u-------input-R-Horizontal wind (m/s) +c v-------input-R-Meridional wind (m/s) +c pmea----input-R-Mean Orography (m) +C pstd----input-R-SSO standard deviation (m) +c psig----input-R-SSO slope +c pgam----input-R-SSO Anisotropy +c pthe----input-R-SSO Angle +c ppic----input-R-SSO Peacks elevation (m) +c pval----input-R-SSO Valleys elevation (m) +c +c kgwd- -input-I: Total nb of points where the orography schemes are active +c ktest--input-I: Flags to indicate active points +c kdx----input-I: Locate the physical location of an active point. + +c pulow, pvlow -output-R: Low-level wind +c pustr, pvstr -output-R: Surface stress due to SSO drag (Pa) +c +c d_t-----output-R: T increment +c d_u-----output-R: U increment +c d_v-----output-R: V increment +c +c Implicit Arguments: +c =================== +c +c iim--common-I: Number of longitude intervals +c jjm--common-I: Number of latitude intervals +c klon-common-I: Number of points seen by the physics +c (iim+1)*(jjm+1) for instance +c klev-common-I: Number of vertical layers +c====================================================================== +c Local Variables: +c ================ +c +c zgeom-----R: Altitude of layer above ground +c pt, pu, pv --R: t u v from top to bottom +c pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom) +c papmf: pressure at model layer (from top to bottom) +c papmh: pressure at model 1/2 layer (from top to bottom) +c +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" +c +c ARGUMENTS +c + INTEGER nlon,nlev + REAL dtime + REAL paprs(nlon,nlev+1) + REAL pplay(nlon,nlev) + REAL pmea(nlon),pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon) + REAL ppic(nlon),pval(nlon) + REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon) + REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev) + REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev) +c + INTEGER i, k, kgwd, kdx(nlon), ktest(nlon) +c +c LOCAL VARIABLES: +c + REAL zgeom(klon,klev) + REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev) + REAL pt(klon,klev), pu(klon,klev), pv(klon,klev) + REAL papmf(klon,klev),papmh(klon,klev+1) +c +c INITIALIZE OUTPUT VARIABLES +c + DO i = 1,klon + pulow(i) = 0.0 + pvlow(i) = 0.0 + pustr(i) = 0.0 + pvstr(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_u(i,k) = 0.0 + d_v(i,k) = 0.0 + pdudt(i,k)=0.0 + pdvdt(i,k)=0.0 + pdtdt(i,k)=0.0 + ENDDO + ENDDO +c +c PREPARE INPUT VARIABLES FOR ORODRAG (i.e., ORDERED FROM TOP TO BOTTOM) +C CALCULATE LAYERS HEIGHT ABOVE GROUND) +c + DO k = 1, klev + DO i = 1, klon + pt(i,k) = t(i,klev-k+1) + pu(i,k) = u(i,klev-k+1) + pv(i,k) = v(i,klev-k+1) + papmf(i,k) = pplay(i,klev-k+1) + ENDDO + ENDDO + DO k = 1, klev+1 + DO i = 1, klon + papmh(i,k) = paprs(i,klev-k+2) + ENDDO + ENDDO + DO i = 1, klon + zgeom(i,klev) = RD * pt(i,klev) + . * LOG(papmh(i,klev+1)/papmf(i,klev)) + ENDDO + DO k = klev-1, 1, -1 + DO i = 1, klon + zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0 + . * LOG(papmf(i,k+1)/papmf(i,k)) + ENDDO + ENDDO +c +c CALL SSO DRAG ROUTINES +c + CALL orodrag_strato(klon,klev,kgwd,kdx,ktest, + . dtime, + . papmh, papmf, zgeom, + . pt, pu, pv, + . pmea, pstd, psig, pgam, pthe, ppic,pval, + . pulow,pvlow, + . pdudt,pdvdt,pdtdt) +C +C COMPUTE INCREMENTS AND STRESS FROM TENDENCIES + + DO k = 1, klev + DO i = 1, klon + d_u(i,klev+1-k) = dtime*pdudt(i,k) + d_v(i,klev+1-k) = dtime*pdvdt(i,k) + d_t(i,klev+1-k) = dtime*pdtdt(i,k) + pustr(i) = pustr(i) + . +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg + pvstr(i) = pvstr(i) + . +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg + ENDDO + ENDDO +c + RETURN + END + + SUBROUTINE orodrag_strato( nlon,nlev + i , kgwd, kdx, ktest + r , ptsphy + r , paphm1,papm1,pgeom1,ptm1,pum1,pvm1 + r , pmea, pstd, psig, pgam, pthe, ppic, pval +c outputs + r , pulow,pvlow + r , pvom,pvol,pte ) + + USE dimphy + IMPLICIT NONE +c +c +c**** *orodrag* - does the SSO drag parametrization. +c +c purpose. +c -------- +c +c this routine computes the physical tendencies of the +c prognostic variables u,v and t due to vertical transports by +c subgridscale orographically excited gravity waves, and to +c low level blocked flow drag. +c +c** interface. +c ---------- +c called from *drag_noro*. +c +c the routine takes its input from the long-term storage: +c u,v,t and p at t-1. +c +c explicit arguments : +c -------------------- +c ==== inputs === +c nlon----input-I-Total number of horizontal points that get into physics +c nlev----input-I-Number of vertical levels +c +c kgwd- -input-I: Total nb of points where the orography schemes are active +c ktest--input-I: Flags to indicate active points +c kdx----input-I: Locate the physical location of an active point. +c ptsphy--input-R-Time-step (s) +c paphm1--input-R: pressure at model 1/2 layer +c papm1---input-R: pressure at model layer +c pgeom1--input-R: Altitude of layer above ground +c ptm1, pum1, pvm1--R-: t, u and v +c pmea----input-R-Mean Orography (m) +C pstd----input-R-SSO standard deviation (m) +c psig----input-R-SSO slope +c pgam----input-R-SSO Anisotropy +c pthe----input-R-SSO Angle +c ppic----input-R-SSO Peacks elevation (m) +c pval----input-R-SSO Valleys elevation (m) + + integer nlon,nlev,kgwd + real ptsphy + +c ==== outputs === +c pulow, pvlow -output-R: Low-level wind +c +c pte -----output-R: T tendency +c pvom-----output-R: U tendency +c pvol-----output-R: V tendency +c +c +c Implicit Arguments: +c =================== +c +c klon-common-I: Number of points seen by the physics +c klev-common-I: Number of vertical layers +c +c method. +c ------- +c +c externals. +c ---------- + integer ismin, ismax + external ismin, ismax +c +c reference. +c ---------- +c +c author. +c ------- +c m.miller + b.ritter e.c.m.w.f. 15/06/86. +c +c f.lott + m. miller e.c.m.w.f. 22/11/94 +c----------------------------------------------------------------------- +c +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" +c----------------------------------------------------------------------- +c +c* 0.1 arguments +c --------- +c +c + real pte(nlon,nlev), + * pvol(nlon,nlev), + * pvom(nlon,nlev), + * pulow(nlon), + * pvlow(nlon) + real pum1(nlon,nlev), + * pvm1(nlon,nlev), + * ptm1(nlon,nlev), + * pmea(nlon),pstd(nlon),psig(nlon), + * pgam(nlon),pthe(nlon),ppic(nlon),pval(nlon), + * pgeom1(nlon,nlev), + * papm1(nlon,nlev), + * paphm1(nlon,nlev+1) +c + integer kdx(nlon),ktest(nlon) +c----------------------------------------------------------------------- +c +c* 0.2 local arrays +c ------------ + integer isect(klon), + * icrit(klon), + * ikcrith(klon), + * ikenvh(klon), + * iknu(klon), + * iknu2(klon), + * ikcrit(klon), + * ikhlim(klon) +c + real ztau(klon,klev+1), + * zstab(klon,klev+1), + * zvph(klon,klev+1), + * zrho(klon,klev+1), + * zri(klon,klev+1), + * zpsi(klon,klev+1), + * zzdep(klon,klev) + real zdudt(klon), + * zdvdt(klon), + * zdtdt(klon), + * zdedt(klon), + * zvidis(klon), + * ztfr(klon), + * znu(klon), + * zd1(klon), + * zd2(klon), + * zdmod(klon) + + +c local quantities: + + integer jl,jk,ji + real ztmst,zdelp,ztemp,zforc,ztend,rover + real zb,zc,zconb,zabsv,zzd1,ratio,zbet,zust,zvst,zdis + +c +c------------------------------------------------------------------ +c +c* 1. initialization +c -------------- +c +c print *,' in orodrag' + 100 continue +c +c ------------------------------------------------------------------ +c +c* 1.1 computational constants +c ----------------------- +c + 110 continue +c +c ztmst=twodt +c if(nstep.eq.nstart) ztmst=0.5*twodt + ztmst=ptsphy +c ------------------------------------------------------------------ +c + 120 continue +c +c ------------------------------------------------------------------ +c +c* 1.3 check whether row contains point for printing +c --------------------------------------------- +c + 130 continue +c +c ------------------------------------------------------------------ +c +c* 2. precompute basic state variables. +c* ---------- ----- ----- ---------- +c* define low level wind, project winds in plane of +c* low level wind, determine sector in which to take +c* the variance and set indicator for critical levels. +c + + 200 continue +c +c +c + call orosetup_strato + * ( nlon, nlev , ktest + * , ikcrit, ikcrith, icrit, isect, ikhlim, ikenvh,iknu,iknu2 + * , paphm1, papm1 , pum1 , pvm1 , ptm1 , pgeom1, pstd + * , zrho , zri , zstab , ztau , zvph , zpsi, zzdep + * , pulow, pvlow + * , pthe,pgam,pmea,ppic,pval,znu ,zd1, zd2, zdmod ) + + +c +c +c +c*********************************************************** +c +c +c* 3. compute low level stresses using subcritical and +c* supercritical forms.computes anisotropy coefficient +c* as measure of orographic twodimensionality. +c + 300 continue +c + call gwstress_strato + * ( nlon , nlev + * , ikcrit, isect, ikhlim, ktest, ikcrith, icrit, ikenvh, iknu + * , zrho , zstab, zvph , pstd, psig, pmea, ppic, pval + * , ztfr , ztau + * , pgeom1,pgam,zd1,zd2,zdmod,znu) + +c +c +c* 4. compute stress profile including +c trapped waves, wave breaking, +c linear decay in stratosphere. +c + 400 continue +c +c + + call gwprofil_strato + * ( nlon , nlev + * , kgwd , kdx , ktest + * , ikcrit, ikcrith, icrit , ikenvh, iknu + * ,iknu2 , paphm1, zrho , zstab , ztfr , zvph + * , zri , ztau + + * , zdmod , znu , psig , pgam , pstd , ppic , pval) + +c +c* 5. Compute tendencies from waves stress profile. +c Compute low level blocked flow drag. +c* -------------------------------------------- +c + 500 continue + + +c +c explicit solution at all levels for the gravity wave +c implicit solution for the blocked levels + + do 510 jl=kidia,kfdia + zvidis(jl)=0.0 + zdudt(jl)=0.0 + zdvdt(jl)=0.0 + zdtdt(jl)=0.0 + 510 continue +c + + do 524 jk=1,klev +c + +C WAVE STRESS +C------------- +c +c + do 523 ji=kidia,kfdia + + if(ktest(ji).eq.1) then + + zdelp=paphm1(ji,jk+1)-paphm1(ji,jk) + ztemp=-rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,klev+1)*zdelp) + + zdudt(ji)=(pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji) + zdvdt(ji)=(pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji) +c +c Control Overshoots +c + + if(jk.ge.nstra)then + rover=0.10 + if(abs(zdudt(ji)).gt.rover*abs(pum1(ji,jk))/ztmst) + C zdudt(ji)=rover*abs(pum1(ji,jk))/ztmst* + C zdudt(ji)/(abs(zdudt(ji))+1.E-10) + if(abs(zdvdt(ji)).gt.rover*abs(pvm1(ji,jk))/ztmst) + C zdvdt(ji)=rover*abs(pvm1(ji,jk))/ztmst* + C zdvdt(ji)/(abs(zdvdt(ji))+1.E-10) + endif + + rover=0.25 + zforc=sqrt(zdudt(ji)**2+zdvdt(ji)**2) + ztend=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst + + if(zforc.ge.rover*ztend)then + zdudt(ji)=rover*ztend/zforc*zdudt(ji) + zdvdt(ji)=rover*ztend/zforc*zdvdt(ji) + endif +c +c BLOCKED FLOW DRAG: +C ----------------- +c + if(jk.gt.ikenvh(ji)) then + zb=1.0-0.18*pgam(ji)-0.04*pgam(ji)**2 + zc=0.48*pgam(ji)+0.3*pgam(ji)**2 + zconb=2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji)) + zabsv=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2. + zzd1=zb*cos(zpsi(ji,jk))**2+zc*sin(zpsi(ji,jk))**2 + ratio=(cos(zpsi(ji,jk))**2+pgam(ji)*sin(zpsi(ji,jk))**2)/ + * (pgam(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2) + zbet=max(0.,2.-1./ratio)*zconb*zzdep(ji,jk)*zzd1*zabsv +c +c OPPOSED TO THE WIND +c + zdudt(ji)=-pum1(ji,jk)/ztmst + zdvdt(ji)=-pvm1(ji,jk)/ztmst +c +c PERPENDICULAR TO THE SSO MAIN AXIS: +C +cmod zdudt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.) +cmod * +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.)) +cmod * *cos(pthe(ji)*rpi/180.)/ztmst +cmod zdvdt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.) +cmod * +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.)) +cmod * *sin(pthe(ji)*rpi/180.)/ztmst +C + zdudt(ji)=zdudt(ji)*(zbet/(1.+zbet)) + zdvdt(ji)=zdvdt(ji)*(zbet/(1.+zbet)) + end if + pvom(ji,jk)=zdudt(ji) + pvol(ji,jk)=zdvdt(ji) + zust=pum1(ji,jk)+ztmst*zdudt(ji) + zvst=pvm1(ji,jk)+ztmst*zdvdt(ji) + zdis=0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2) + zdedt(ji)=zdis/ztmst + zvidis(ji)=zvidis(ji)+zdis*zdelp + zdtdt(ji)=zdedt(ji)/rcpd +c +c NO TENDENCIES ON TEMPERATURE ..... +c +c Instead of, pte(ji,jk)=zdtdt(ji), due to mechanical dissipation +c + pte(ji,jk)=0.0 + + endif + + 523 continue + 524 continue +c +c + 501 continue + + return + end + SUBROUTINE orosetup_strato + * ( nlon , nlev , ktest + * , kkcrit, kkcrith, kcrit, ksect , kkhlim + * , kkenvh, kknu , kknu2 + * , paphm1, papm1 , pum1 , pvm1 , ptm1 , pgeom1, pstd + * , prho , pri , pstab , ptau , pvph ,ppsi, pzdep + * , pulow , pvlow + * , ptheta, pgam, pmea, ppic, pval + * , pnu , pd1 , pd2 ,pdmod ) +C +c**** *gwsetup* +c +c purpose. +c -------- +c SET-UP THE ESSENTIAL PARAMETERS OF THE SSO DRAG SCHEME: +C DEPTH OF LOW WBLOCKED LAYER, LOW-LEVEL FLOW, BACKGROUND +C STRATIFICATION..... +c +c** interface. +c ---------- +c from *orodrag* +c +c explicit arguments : +c -------------------- +c ==== inputs === +c +c nlon----input-I-Total number of horizontal points that get into physics +c nlev----input-I-Number of vertical levels +c ktest--input-I: Flags to indicate active points +c +c ptsphy--input-R-Time-step (s) +c paphm1--input-R: pressure at model 1/2 layer +c papm1---input-R: pressure at model layer +c pgeom1--input-R: Altitude of layer above ground +c ptm1, pum1, pvm1--R-: t, u and v +c pmea----input-R-Mean Orography (m) +C pstd----input-R-SSO standard deviation (m) +c psig----input-R-SSO slope +c pgam----input-R-SSO Anisotropy +c pthe----input-R-SSO Angle +c ppic----input-R-SSO Peacks elevation (m) +c pval----input-R-SSO Valleys elevation (m) + +c ==== outputs === +c pulow, pvlow -output-R: Low-level wind +c kkcrit----I-: Security value for top of low level flow +c kcrit-----I-: Critical level +c ksect-----I-: Not used +c kkhlim----I-: Not used +c kkenvh----I-: Top of blocked flow layer +c kknu------I-: Layer that sees mountain peacks +c kknu2-----I-: Layer that sees mountain peacks above mountain mean +c kknub-----I-: Layer that sees mountain mean above valleys +c prho------R-: Density at 1/2 layers +c pri-------R-: Background Richardson Number, Wind shear measured along GW stress +c pstab-----R-: Brunt-Vaisala freq. at 1/2 layers +c pvph------R-: Wind in plan of GW stress, Half levels. +c ppsi------R-: Angle between low level wind and SS0 main axis. +c pd1-------R-| Compared the ratio of the stress +c pd2-------R-| that is along the wind to that Normal to it. +c pdi define the plane of low level stress +c compared to the low level wind. +c see p. 108 Lott & Miller (1997). +c pdmod-----R-: Norme of pdi + +c === local arrays === +c +c zvpf------R-: Wind projected in the plan of the low-level stress. + +c ==== outputs === +c +c implicit arguments : none +c -------------------- +c +c method. +c ------- +c +c +c externals. +c ---------- +c +c +c reference. +c ---------- +c +c see ecmwf research department documentation of the "i.f.s." +c +c author. +c ------- +c +c modifications. +c -------------- +c f.lott for the new-gwdrag scheme november 1993 +c +c----------------------------------------------------------------------- + USE dimphy + implicit none +c + +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" + +c----------------------------------------------------------------------- +c +c* 0.1 arguments +c --------- +c + integer nlon,nlev + integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon), + * kkhlim(nlon),ktest(nlon),kkenvh(nlon) + +c + real paphm1(nlon,klev+1),papm1(nlon,klev),pum1(nlon,klev), + * pvm1(nlon,klev),ptm1(nlon,klev),pgeom1(nlon,klev), + * prho(nlon,klev+1),pri(nlon,klev+1),pstab(nlon,klev+1), + * ptau(nlon,klev+1),pvph(nlon,klev+1),ppsi(nlon,klev+1), + * pzdep(nlon,klev) + real pulow(nlon),pvlow(nlon),ptheta(nlon),pgam(nlon),pnu(nlon), + * pd1(nlon),pd2(nlon),pdmod(nlon) + real pstd(nlon),pmea(nlon),ppic(nlon),pval(nlon) +c +c----------------------------------------------------------------------- +c +c* 0.2 local arrays +c ------------ +c +c + integer ilevh ,jl,jk + real zcons1,zcons2,zhgeo,zu,zphi + real zvt1,zvt2,zdwind,zwind,zdelp + real zstabm,zstabp,zrhom,zrhop + logical lo + logical ll1(klon,klev+1) + integer kknu(klon),kknu2(klon),kknub(klon),kknul(klon), + * kentp(klon),ncount(klon) +c + real zhcrit(klon,klev),zvpf(klon,klev), + * zdp(klon,klev) + real znorm(klon),zb(klon),zc(klon), + * zulow(klon),zvlow(klon),znup(klon),znum(klon) +c +c ------------------------------------------------------------------ +c +c* 1. initialization +c -------------- +c +c PRINT *,' in orosetup' + 100 continue +c +c ------------------------------------------------------------------ +c +c* 1.1 computational constants +c ----------------------- +c + 110 continue +c + ilevh =klev/3 +c + zcons1=1./rd + zcons2=rg**2/rcpd +c +c +c ------------------------------------------------------------------ +c +c* 2. +c -------------- +c + 200 continue +c +c ------------------------------------------------------------------ +c +c* 2.1 define low level wind, project winds in plane of +c* low level wind, determine sector in which to take +c* the variance and set indicator for critical levels. +c +c +c + do 2001 jl=kidia,kfdia + kknu(jl) =klev + kknu2(jl) =klev + kknub(jl) =klev + kknul(jl) =klev + pgam(jl) =max(pgam(jl),gtsec) + ll1(jl,klev+1)=.false. + 2001 continue +c +c Ajouter une initialisation (L. Li, le 23fev99): +c + do jk=klev,ilevh,-1 + do jl=kidia,kfdia + ll1(jl,jk)= .false. + ENDDO + ENDDO +c +c* define top of low level flow +c ---------------------------- + do 2002 jk=klev,ilevh,-1 + do 2003 jl=kidia,kfdia + if(ktest(jl).eq.1) then + lo=(paphm1(jl,jk)/paphm1(jl,klev+1)).ge.gsigcr + if(lo) then + kkcrit(jl)=jk + endif + zhcrit(jl,jk)=ppic(jl)-pval(jl) + zhgeo=pgeom1(jl,jk)/rg + ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk)) + if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then + kknu(jl)=jk + endif + if(.not.ll1(jl,ilevh))kknu(jl)=ilevh + endif + 2003 continue + 2002 continue + do 2004 jk=klev,ilevh,-1 + do 2005 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zhcrit(jl,jk)=ppic(jl)-pmea(jl) + zhgeo=pgeom1(jl,jk)/rg + ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk)) + if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then + kknu2(jl)=jk + endif + if(.not.ll1(jl,ilevh))kknu2(jl)=ilevh + endif + 2005 continue + 2004 continue + do 2006 jk=klev,ilevh,-1 + do 2007 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zhcrit(jl,jk)=amin1(ppic(jl)-pmea(jl),pmea(jl)-pval(jl)) + zhgeo=pgeom1(jl,jk)/rg + ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk)) + if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then + kknub(jl)=jk + endif + if(.not.ll1(jl,ilevh))kknub(jl)=ilevh + endif + 2007 continue + 2006 continue +c + do 2010 jl=kidia,kfdia + if(ktest(jl).eq.1) then + kknu(jl)=min(kknu(jl),nktopg) + kknu2(jl)=min(kknu2(jl),nktopg) + kknub(jl)=min(kknub(jl),nktopg) + kknul(jl)=klev + endif + 2010 continue +c + 210 continue +c +cc* initialize various arrays +c + do 2107 jl=kidia,kfdia + prho(jl,klev+1) =0.0 +cym correction en attendant mieux + prho(jl,1) =0.0 + pstab(jl,klev+1) =0.0 + pstab(jl,1) =0.0 + pri(jl,klev+1) =9999.0 + ppsi(jl,klev+1) =0.0 + pri(jl,1) =0.0 + pvph(jl,1) =0.0 + pvph(jl,klev+1) =0.0 +cym correction en attendant mieux +cym pvph(jl,klev) =0.0 + pulow(jl) =0.0 + pvlow(jl) =0.0 + zulow(jl) =0.0 + zvlow(jl) =0.0 + kkcrith(jl) =klev + kkenvh(jl) =klev + kentp(jl) =klev + kcrit(jl) =1 + ncount(jl) =0 + ll1(jl,klev+1) =.false. + 2107 continue +c +c* define flow density and stratification (rho and N2) +c at semi layers. +c ------------------------------------------------------- +c + do 223 jk=klev,2,-1 + do 222 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1) + prho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) + pstab(jl,jk)=2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))* + * (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk)) + pstab(jl,jk)=max(pstab(jl,jk),gssec) + endif + 222 continue + 223 continue +c +c******************************************************************** +c +c* define Low level flow (between ground and peacks-valleys) +c --------------------------------------------------------- + do 2115 jk=klev,ilevh,-1 + do 2116 jl=kidia,kfdia + if(ktest(jl).eq.1) then + if(jk.ge.kknu2(jl).and.jk.le.kknul(jl)) then + pulow(jl)=pulow(jl)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + pvlow(jl)=pvlow(jl)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + pstab(jl,klev+1)=pstab(jl,klev+1) + c +pstab(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + prho(jl,klev+1)=prho(jl,klev+1) + c +prho(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + end if + endif + 2116 continue + 2115 continue + do 2110 jl=kidia,kfdia + if(ktest(jl).eq.1) then + pulow(jl)=pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl))) + pvlow(jl)=pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl))) + znorm(jl)=max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec) + pvph(jl,klev+1)=znorm(jl) + pstab(jl,klev+1)=pstab(jl,klev+1) + c /(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl))) + prho(jl,klev+1)=prho(jl,klev+1) + c /(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl))) + endif + 2110 continue + +c +c******* setup orography orientation relative to the low level +C wind and define parameters of the Anisotropic wave stress. +c + do 2112 jl=kidia,kfdia + if(ktest(jl).eq.1) then + lo=(pulow(jl).lt.gvsec).and.(pulow(jl).ge.-gvsec) + if(lo) then + zu=pulow(jl)+2.*gvsec + else + zu=pulow(jl) + endif + zphi=atan(pvlow(jl)/zu) + ppsi(jl,klev+1)=ptheta(jl)*rpi/180.-zphi + zb(jl)=1.-0.18*pgam(jl)-0.04*pgam(jl)**2 + zc(jl)=0.48*pgam(jl)+0.3*pgam(jl)**2 + pd1(jl)=zb(jl)-(zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2) + pd2(jl)=(zb(jl)-zc(jl))*sin(ppsi(jl,klev+1)) + * *cos(ppsi(jl,klev+1)) + pdmod(jl)=sqrt(pd1(jl)**2+pd2(jl)**2) + endif + 2112 continue +c +c ************ projet flow in plane of lowlevel stress ************* +C ************ Find critical levels... ************* +c + do 213 jk=1,klev + do 212 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zvt1 =pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk) + zvt2 =-pvlow(jl)*pum1(jl,jk)+pulow(jl)*pvm1(jl,jk) + zvpf(jl,jk)=(zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl)) + endif + ptau(jl,jk) =0.0 + pzdep(jl,jk) =0.0 + ppsi(jl,jk) =0.0 + ll1(jl,jk) =.false. + 212 continue + 213 continue + do 215 jk=2,klev + do 214 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1) + pvph(jl,jk)=((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+ + * (papm1(jl,jk)-paphm1(jl,jk))*zvpf(jl,jk-1)) + * /zdp(jl,jk) + if(pvph(jl,jk).lt.gvsec) then + pvph(jl,jk)=gvsec + kcrit(jl)=jk + endif + endif + 214 continue + 215 continue +c +c* 2.3 mean flow richardson number. +c + 230 continue +c + do 232 jk=2,klev + do 231 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zdwind=max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)),gvsec) + pri(jl,jk)=pstab(jl,jk)*(zdp(jl,jk) + * /(rg*prho(jl,jk)*zdwind))**2 + pri(jl,jk)=max(pri(jl,jk),grcrit) + endif + 231 continue + 232 continue + +c +c +c* define top of 'envelope' layer +c ---------------------------- + + do 233 jl=kidia,kfdia + pnu (jl)=0.0 + znum(jl)=0.0 + 233 continue + + do 234 jk=2,klev-1 + do 234 jl=kidia,kfdia + + if(ktest(jl).eq.1) then + + if (jk.ge.kknu2(jl)) then + + znum(jl)=pnu(jl) + zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ + * max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec) + zwind=max(sqrt(zwind**2),gvsec) + zdelp=paphm1(jl,jk+1)-paphm1(jl,jk) + zstabm=sqrt(max(pstab(jl,jk ),gssec)) + zstabp=sqrt(max(pstab(jl,jk+1),gssec)) + zrhom=prho(jl,jk ) + zrhop=prho(jl,jk+1) + pnu(jl) = pnu(jl) + (zdelp/rg)* + * ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind + if((znum(jl).le.gfrcrit).and.(pnu(jl).gt.gfrcrit) + * .and.(kkenvh(jl).eq.klev)) + * kkenvh(jl)=jk + + endif + + endif + + 234 continue + +c calculation of a dynamical mixing height for when the waves +C BREAK AT LOW LEVEL: The drag will be repartited over +C a depths that depends on waves vertical wavelength, +C not just between two adjacent model layers. +c of gravity waves: + + do 235 jl=kidia,kfdia + znup(jl)=0.0 + znum(jl)=0.0 + 235 continue + + do 236 jk=klev-1,2,-1 + do 236 jl=kidia,kfdia + + if(ktest(jl).eq.1) then + + znum(jl)=znup(jl) + zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ + * max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec) + zwind=max(sqrt(zwind**2),gvsec) + zdelp=paphm1(jl,jk+1)-paphm1(jl,jk) + zstabm=sqrt(max(pstab(jl,jk ),gssec)) + zstabp=sqrt(max(pstab(jl,jk+1),gssec)) + zrhom=prho(jl,jk ) + zrhop=prho(jl,jk+1) + znup(jl) = znup(jl) + (zdelp/rg)* + * ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind + if((znum(jl).le.rpi/4.).and.(znup(jl).gt.rpi/4.) + * .and.(kkcrith(jl).eq.klev)) + * kkcrith(jl)=jk + + endif + + 236 continue + + do 237 jl=kidia,kfdia + if(ktest(jl).eq.1) then + kkcrith(jl)=max0(kkcrith(jl),ilevh*2) + kkcrith(jl)=max0(kkcrith(jl),kknu(jl)) + if(kcrit(jl).ge.kkcrith(jl))kcrit(jl)=1 + endif + 237 continue +c +c directional info for flow blocking ************************* +c + do 251 jk=1,klev + do 252 jl=kidia,kfdia + if(ktest(jl).eq.1) then + lo=(pum1(jl,jk).lt.gvsec).and.(pum1(jl,jk).ge.-gvsec) + if(lo) then + zu=pum1(jl,jk)+2.*gvsec + else + zu=pum1(jl,jk) + endif + zphi=atan(pvm1(jl,jk)/zu) + ppsi(jl,jk)=ptheta(jl)*rpi/180.-zphi + endif + 252 continue + 251 continue + +c forms the vertical 'leakiness' ************************** + + do 254 jk=ilevh,klev + do 253 jl=kidia,kfdia + if(ktest(jl).eq.1) then + pzdep(jl,jk)=0 + if(jk.ge.kkenvh(jl).and.kkenvh(jl).ne.klev) then + pzdep(jl,jk)=(pgeom1(jl,kkenvh(jl) )-pgeom1(jl, jk))/ + * (pgeom1(jl,kkenvh(jl) )-pgeom1(jl,klev)) + end if + endif + 253 continue + 254 continue + + return + end + SUBROUTINE gwstress_strato + * ( nlon , nlev + * , kkcrit, ksect, kkhlim, ktest, kkcrith, kcrit, kkenvh + * , kknu + * , prho , pstab , pvph , pstd, psig + * , pmea , ppic , pval , ptfr , ptau + * , pgeom1 , pgamma , pd1 , pd2 , pdmod , pnu ) +c +c**** *gwstress* +c +c purpose. +c -------- +c Compute the surface stress due to Gravity Waves, according +c to the Phillips (1979) theory of 3-D flow above +c anisotropic elliptic ridges. + +C The stress is reduced two account for cut-off flow over +C hill. The flow only see that part of the ridge located +c above the blocked layer (see zeff). +c +c** interface. +c ---------- +c call *gwstress* from *gwdrag* +c +c explicit arguments : +c -------------------- +c ==== inputs === +c ==== outputs === +c +c implicit arguments : none +c -------------------- +c +c method. +c ------- +c +c +c externals. +c ---------- +c +c +c reference. +c ---------- +c +c LOTT and MILLER (1997) & LOTT (1999) +c +c author. +c ------- +c +c modifications. +c -------------- +c f. lott put the new gwd on ifs 22/11/93 +c +c----------------------------------------------------------------------- + USE dimphy + implicit none + +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" + +c----------------------------------------------------------------------- +c +c* 0.1 arguments +c --------- +c + integer nlon,nlev + integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon), + * kkhlim(nlon),ktest(nlon),kkenvh(nlon),kknu(nlon) +c + real prho(nlon,nlev+1),pstab(nlon,nlev+1),ptau(nlon,nlev+1), + * pvph(nlon,nlev+1),ptfr(nlon), + * pgeom1(nlon,nlev),pstd(nlon) +c + real pd1(nlon),pd2(nlon),pnu(nlon),psig(nlon),pgamma(nlon) + real pmea(nlon),ppic(nlon),pval(nlon) + real pdmod(nlon) +c +c----------------------------------------------------------------------- +c +c* 0.2 local arrays +c ------------ +c zeff--real: effective height seen by the flow when there is blocking + + integer jl + real zeff +c +c----------------------------------------------------------------------- +c +c* 0.3 functions +c --------- +c ------------------------------------------------------------------ +c +c* 1. initialization +c -------------- +c +c PRINT *,' in gwstress' + 100 continue +c +c* 3.1 gravity wave stress. +c + 300 continue +c +c + do 301 jl=kidia,kfdia + if(ktest(jl).eq.1) then + +c effective mountain height above the blocked flow + + zeff=ppic(jl)-pval(jl) + if(kkenvh(jl).lt.klev)then + zeff=amin1(GFRCRIT*pvph(jl,klev+1)/sqrt(pstab(jl,klev+1)) + c ,zeff) + endif + + + ptau(jl,klev+1)=gkdrag*prho(jl,klev+1) + * *psig(jl)*pdmod(jl)/4./pstd(jl) + * *pvph(jl,klev+1)*sqrt(pstab(jl,klev+1)) + * *zeff**2 + + +c too small value of stress or low level flow include critical level +c or low level flow: gravity wave stress nul. + +c lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl)) +c * .or.(pvph(jl,klev+1).lt.gvcrit) +c if(lo) ptau(jl,klev+1)=0.0 + +c print *,jl,ptau(jl,klev+1) + + else + + ptau(jl,klev+1)=0.0 + + endif + + 301 continue + +c write(21)(ptau(jl,klev+1),jl=kidia,kfdia) + + return + end + + subroutine gwprofil_strato + * ( nlon, nlev + * , kgwd ,kdx , ktest + * , kkcrit, kkcrith, kcrit , kkenvh, kknu,kknu2 + * , paphm1, prho , pstab , ptfr , pvph , pri , ptau + * , pdmod , pnu , psig ,pgamma, pstd, ppic,pval) + +C**** *gwprofil* +C +C purpose. +C -------- +C +C** interface. +C ---------- +C from *gwdrag* +C +C explicit arguments : +C -------------------- +C ==== inputs === +C +C ==== outputs === +C +C implicit arguments : none +C -------------------- +C +C method: +C ------- +C the stress profile for gravity waves is computed as follows: +C it decreases linearly with heights from the ground +C to the low-level indicated by kkcrith, +C to simulates lee waves or +C low-level gravity wave breaking. +C above it is constant, except when the waves encounter a critical +C level (kcrit) or when they break. +C The stress is also uniformly distributed above the level +C nstra. +C + USE dimphy + IMPLICIT NONE + +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" + +C----------------------------------------------------------------------- +C +C* 0.1 ARGUMENTS +C --------- +C + integer nlon,nlev,kgwd + integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon) + * ,kdx(nlon),ktest(nlon) + * ,kkenvh(nlon),kknu(nlon),kknu2(nlon) +C + real paphm1(nlon,nlev+1), pstab(nlon,nlev+1), + * prho (nlon,nlev+1), pvph (nlon,nlev+1), + * pri (nlon,nlev+1), ptfr (nlon), ptau(nlon,nlev+1) + + real pdmod (nlon) , pnu (nlon) , psig(nlon), + * pgamma(nlon) , pstd(nlon) , ppic(nlon), pval(nlon) + +C----------------------------------------------------------------------- +C +C* 0.2 local arrays +C ------------ +C + integer jl,jk + real zsqr,zalfa,zriw,zdel,zb,zalpha,zdz2n,zdelp,zdelpt + + real zdz2 (klon,klev) , znorm(klon) , zoro(klon) + real ztau (klon,klev+1) +C +C----------------------------------------------------------------------- +C +C* 1. INITIALIZATION +C -------------- +C +C print *,' entree gwprofil' + 100 CONTINUE +C +C +C* COMPUTATIONAL CONSTANTS. +C ------------- ---------- +C + do 400 jl=kidia,kfdia + if(ktest(jl).eq.1)then + zoro(jl)=psig(jl)*pdmod(jl)/4./pstd(jl) + ztau(jl,klev+1)=ptau(jl,klev+1) +c print *,jl,ptau(jl,klev+1) + ztau(jl,kkcrith(jl))=grahilo*ptau(jl,klev+1) + endif + 400 continue + +C + do 430 jk=klev+1,1,-1 +C +C +C* 4.1 constant shear stress until top of the +C low-level breaking/trapped layer + 410 CONTINUE +C + do 411 jl=kidia,kfdia + if(ktest(jl).eq.1)then + if(jk.gt.kkcrith(jl)) then + zdelp=paphm1(jl,jk)-paphm1(jl,klev+1) + zdelpt=paphm1(jl,kkcrith(jl))-paphm1(jl,klev+1) + ptau(jl,jk)=ztau(jl,klev+1)+zdelp/zdelpt* + c (ztau(jl,kkcrith(jl))-ztau(jl,klev+1)) + else + ptau(jl,jk)=ztau(jl,kkcrith(jl)) + endif + endif + 411 continue +C +C* 4.15 constant shear stress until the top of the +C low level flow layer. + 415 continue +C +C +C* 4.2 wave displacement at next level. +C + 420 continue +C + 430 continue + +C +C* 4.4 wave richardson number, new wave displacement +C* and stress: breaking evaluation and critical +C level +C + + do 440 jk=klev,1,-1 + + do 441 jl=kidia,kfdia + if(ktest(jl).eq.1)then + znorm(jl)=prho(jl,jk)*sqrt(pstab(jl,jk))*pvph(jl,jk) + zdz2(jl,jk)=ptau(jl,jk)/amax1(znorm(jl),gssec)/zoro(jl) + endif + 441 continue + + do 442 jl=kidia,kfdia + if(ktest(jl).eq.1)then + if(jk.lt.kkcrith(jl)) then + if((ptau(jl,jk+1).lt.gtsec).or.(jk.le.kcrit(jl))) then + ptau(jl,jk)=0.0 + else + zsqr=sqrt(pri(jl,jk)) + zalfa=sqrt(pstab(jl,jk)*zdz2(jl,jk))/pvph(jl,jk) + zriw=pri(jl,jk)*(1.-zalfa)/(1+zalfa*zsqr)**2 + if(zriw.lt.grcrit) then +C print *,' breaking!!!',ptau(jl,jk) + zdel=4./zsqr/grcrit+1./grcrit**2+4./grcrit + zb=1./grcrit+2./zsqr + zalpha=0.5*(-zb+sqrt(zdel)) + zdz2n=(pvph(jl,jk)*zalpha)**2/pstab(jl,jk) + ptau(jl,jk)=znorm(jl)*zdz2n*zoro(jl) + endif + + ptau(jl,jk)=amin1(ptau(jl,jk),ptau(jl,jk+1)) + + endif + endif + endif + 442 continue + 440 continue + +C REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL + + do 530 jl=kidia,kfdia + if(ktest(jl).eq.1)then + ztau(jl,kkcrith(jl)-1)=ptau(jl,kkcrith(jl)-1) + ztau(jl,nstra)=ptau(jl,nstra) + endif + 530 continue + + do 531 jk=1,klev + + do 532 jl=kidia,kfdia + if(ktest(jl).eq.1)then + + if(jk.gt.kkcrith(jl)-1)then + + zdelp=paphm1(jl,jk)-paphm1(jl,klev+1 ) + zdelpt=paphm1(jl,kkcrith(jl)-1)-paphm1(jl,klev+1 ) + ptau(jl,jk)=ztau(jl,klev+1 ) + + . (ztau(jl,kkcrith(jl)-1)-ztau(jl,klev+1 ) )* + . zdelp/zdelpt + + endif + endif + + 532 continue + +C REORGANISATION AT THE MODEL TOP.... + + do 533 jl=kidia,kfdia + if(ktest(jl).eq.1)then + + if(jk.lt.nstra)then + + zdelp =paphm1(jl,nstra) + zdelpt=paphm1(jl,jk) + ptau(jl,jk)=ztau(jl,nstra)*zdelpt/zdelp +c ptau(jl,jk)=ztau(jl,nstra) + + endif + + endif + + 533 continue + + + 531 continue + + + 123 format(i4,1x,20(f6.3,1x)) + + + return + end + subroutine lift_noro_strato (nlon,nlev,dtime,paprs,pplay, + i plat,pmea,pstd, psig, pgam, pthe, ppic,pval, + i kgwd,kdx,ktest, + i t, u, v, + o pulow, pvlow, pustr, pvstr, + o d_t, d_u, d_v) +c + USE dimphy + implicit none +c====================================================================== +c Auteur(s): F.Lott (LMD/CNRS) date: 19950201 +c Object: Mountain lift interface (enhanced vortex stretching). +c Made necessary because: +C 1. in the LMD-GCM Layers are from bottom to top, +C contrary to most European GCM. +c 2. the altitude above ground of each model layers +c needs to be known (variable zgeom) +c====================================================================== +c Explicit Arguments: +c ================== +c nlon----input-I-Total number of horizontal points that get into physics +c nlev----input-I-Number of vertical levels +c dtime---input-R-Time-step (s) +c paprs---input-R-Pressure in semi layers (Pa) +c pplay---input-R-Pressure model-layers (Pa) +c t-------input-R-temperature (K) +c u-------input-R-Horizontal wind (m/s) +c v-------input-R-Meridional wind (m/s) +c pmea----input-R-Mean Orography (m) +C pstd----input-R-SSO standard deviation (m) +c psig----input-R-SSO slope +c pgam----input-R-SSO Anisotropy +c pthe----input-R-SSO Angle +c ppic----input-R-SSO Peacks elevation (m) +c pval----input-R-SSO Valleys elevation (m) +c +c kgwd- -input-I: Total nb of points where the orography schemes are active +c ktest--input-I: Flags to indicate active points +c kdx----input-I: Locate the physical location of an active point. + +c pulow, pvlow -output-R: Low-level wind +c pustr, pvstr -output-R: Surface stress due to SSO drag (Pa) +c +c d_t-----output-R: T increment +c d_u-----output-R: U increment +c d_v-----output-R: V increment +c +c Implicit Arguments: +c =================== +c +c iim--common-I: Number of longitude intervals +c jjm--common-I: Number of latitude intervals +c klon-common-I: Number of points seen by the physics +c (iim+1)*(jjm+1) for instance +c klev-common-I: Number of vertical layers +c====================================================================== +c Local Variables: +c ================ +c +c zgeom-----R: Altitude of layer above ground +c pt, pu, pv --R: t u v from top to bottom +c pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom) +c papmf: pressure at model layer (from top to bottom) +c papmh: pressure at model 1/2 layer (from top to bottom) +c +c====================================================================== + +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" +c +c ARGUMENTS +c + INTEGER nlon,nlev + REAL dtime + REAL paprs(klon,klev+1) + REAL pplay(klon,klev) + REAL plat(nlon),pmea(nlon) + REAL pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon) + REAL ppic(nlon),pval(nlon) + REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon) + REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev) + REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev) +c + INTEGER i, k, kgwd, kdx(nlon), ktest(nlon) +c +c Variables locales: +c + REAL zgeom(klon,klev) + REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev) + REAL pt(klon,klev), pu(klon,klev), pv(klon,klev) + REAL papmf(klon,klev),papmh(klon,klev+1) +c +c initialiser les variables de sortie (pour securite) +c + +c print *,'in lift_noro' + DO i = 1,klon + pulow(i) = 0.0 + pvlow(i) = 0.0 + pustr(i) = 0.0 + pvstr(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_u(i,k) = 0.0 + d_v(i,k) = 0.0 + pdudt(i,k)=0.0 + pdvdt(i,k)=0.0 + pdtdt(i,k)=0.0 + ENDDO + ENDDO +c +c preparer les variables d'entree (attention: l'ordre des niveaux +c verticaux augmente du haut vers le bas) +c + DO k = 1, klev + DO i = 1, klon + pt(i,k) = t(i,klev-k+1) + pu(i,k) = u(i,klev-k+1) + pv(i,k) = v(i,klev-k+1) + papmf(i,k) = pplay(i,klev-k+1) + ENDDO + ENDDO + DO k = 1, klev+1 + DO i = 1, klon + papmh(i,k) = paprs(i,klev-k+2) + ENDDO + ENDDO + DO i = 1, klon + zgeom(i,klev) = RD * pt(i,klev) + . * LOG(papmh(i,klev+1)/papmf(i,klev)) + ENDDO + DO k = klev-1, 1, -1 + DO i = 1, klon + zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0 + . * LOG(papmf(i,k+1)/papmf(i,k)) + ENDDO + ENDDO +c +c appeler la routine principale +c + + CALL OROLIFT_strato(klon,klev,kgwd,kdx,ktest, + . dtime, + . papmh, papmf, zgeom, + . pt, pu, pv, + . plat,pmea, pstd, psig, pgam, pthe, ppic,pval, + . pulow,pvlow, + . pdudt,pdvdt,pdtdt) +C + DO k = 1, klev + DO i = 1, klon + d_u(i,klev+1-k) = dtime*pdudt(i,k) + d_v(i,klev+1-k) = dtime*pdvdt(i,k) + d_t(i,klev+1-k) = dtime*pdtdt(i,k) + pustr(i) = pustr(i) + . +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg + pvstr(i) = pvstr(i) + . +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg + ENDDO + ENDDO + +c print *,' out lift_noro' +c + RETURN + END + subroutine orolift_strato( nlon,nlev + I , kgwd, kdx, ktest + R , ptsphy + R , paphm1,papm1,pgeom1,ptm1,pum1,pvm1 + R , plat + R , pmea, pstd, psig, pgam, pthe,ppic,pval +C OUTPUTS + R , pulow,pvlow + R , pvom,pvol,pte ) + +C +C**** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT. +C +C PURPOSE. +C -------- +C this routine computes the physical tendencies of the +C prognostic variables u,v when enhanced vortex stretching +C is needed. +C +C** INTERFACE. +C ---------- +C CALLED FROM *lift_noro +c explicit arguments : +c -------------------- +c ==== inputs === +c nlon----input-I-Total number of horizontal points that get into physics +c nlev----input-I-Number of vertical levels +c +c kgwd- -input-I: Total nb of points where the orography schemes are active +c ktest--input-I: Flags to indicate active points +c kdx----input-I: Locate the physical location of an active point. +c ptsphy--input-R-Time-step (s) +c paphm1--input-R: pressure at model 1/2 layer +c papm1---input-R: pressure at model layer +c pgeom1--input-R: Altitude of layer above ground +c ptm1, pum1, pvm1--R-: t, u and v +c pmea----input-R-Mean Orography (m) +C pstd----input-R-SSO standard deviation (m) +c psig----input-R-SSO slope +c pgam----input-R-SSO Anisotropy +c pthe----input-R-SSO Angle +c ppic----input-R-SSO Peacks elevation (m) +c pval----input-R-SSO Valleys elevation (m) +c plat----input-R-Latitude (degree) +c +c ==== outputs === +c pulow, pvlow -output-R: Low-level wind +c +c pte -----output-R: T tendency +c pvom-----output-R: U tendency +c pvol-----output-R: V tendency +c +c +c Implicit Arguments: +c =================== +c +c klon-common-I: Number of points seen by the physics +c klev-common-I: Number of vertical layers +c + +C ---------- +C +C AUTHOR. +C ------- +C F.LOTT LMD 22/11/95 +C + USE dimphy + implicit none +C +C +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" +C----------------------------------------------------------------------- +C +C* 0.1 ARGUMENTS +C --------- +C +C + integer nlon,nlev,kgwd + real ptsphy + real pte(nlon,nlev), + * pvol(nlon,nlev), + * pvom(nlon,nlev), + * pulow(nlon), + * pvlow(nlon) + real pum1(nlon,nlev), + * pvm1(nlon,nlev), + * ptm1(nlon,nlev), + * plat(nlon),pmea(nlon), + * pstd(nlon),psig(nlon),pgam(nlon), + * pthe(nlon),ppic(nlon),pval(nlon), + * pgeom1(nlon,nlev), + * papm1(nlon,nlev), + * paphm1(nlon,nlev+1) +C + INTEGER KDX(NLON),KTEST(NLON) +C----------------------------------------------------------------------- +C +C* 0.2 local arrays + + integer jl,ilevh,jk + real zhgeo,zdelp,zslow,zsqua,zscav,zbet +C ------------ + integer iknub(klon), + * iknul(klon) + logical ll1(klon,klev+1) +C + real ztau(klon,klev+1), + * ztav(klon,klev+1), + * zrho(klon,klev+1) + real zdudt(klon), + * zdvdt(klon) + real zhcrit(klon,klev) + + logical lifthigh + real zcons1,ztmst + +C----------------------------------------------------------------------- +C +C* 1.1 initialisations +C --------------- + + lifthigh=.false. + + if(nlon.ne.klon.or.nlev.ne.klev)stop + zcons1=1./rd + ztmst=ptsphy +C + do 1001 jl=kidia,kfdia + zrho(jl,klev+1) =0.0 + pulow(jl) =0.0 + pvlow(jl) =0.0 + iknub(JL) =klev + iknul(JL) =klev + ilevh=klev/3 + ll1(jl,klev+1)=.false. + do 1000 jk=1,klev + pvom(jl,jk)=0.0 + pvol(jl,jk)=0.0 + pte (jl,jk)=0.0 + 1000 continue + 1001 continue + +C +C* 2.1 DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF +C* LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE +C* THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS. +C +C +C + do 2006 jk=klev,1,-1 + do 2007 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zhcrit(jl,jk)=amax1(ppic(jl)-pval(jl),100.) + zhgeo=pgeom1(jl,jk)/rg + ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk)) + if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then + iknub(jl)=jk + endif + endif + 2007 continue + 2006 continue +C + + do 2010 jl=kidia,kfdia + if(ktest(jl).eq.1) then + iknub(jl)=max(iknub(jl),klev/2) + iknul(jl)=max(iknul(jl),2*klev/3) + if(iknub(jl).gt.nktopg) iknub(jl)=nktopg + if(iknub(jl).eq.nktopg) iknul(jl)=klev + if(iknub(jl).eq.iknul(jl)) iknub(jl)=iknul(jl)-1 + endif + 2010 continue + + do 223 jk=klev,2,-1 + do 222 jl=kidia,kfdia + zrho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) + 222 continue + 223 continue +c print *,' dans orolift: 223' + +C******************************************************************** +C +c* define low level flow +C ------------------- + do 2115 jk=klev,1,-1 + do 2116 jl=kidia,kfdia + if(ktest(jl).eq.1) THEN + if(jk.ge.iknub(jl).and.jk.le.iknul(jl)) then + pulow(JL)=pulow(JL)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + pvlow(JL)=pvlow(JL)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + zrho(JL,klev+1)=zrho(JL,klev+1) + * +zrho(JL,JK)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + endif + endif + 2116 continue + 2115 continue + do 2110 jl=kidia,kfdia + if(ktest(jl).eq.1) then + pulow(JL)=pulow(JL)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl))) + pvlow(JL)=pvlow(JL)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl))) + zrho(JL,klev+1)=zrho(Jl,klev+1) + * /(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl))) + endif + 2110 continue + + +200 continue + +C*********************************************************** +C +C* 3. COMPUTE MOUNTAIN LIFT +C + 300 continue +C + do 301 jl=kidia,kfdia + if(ktest(jl).eq.1) then + ztau(jl,klev+1)= - gklift*zrho(jl,klev+1)*2.*romega* +c * (2*pstd(jl)+pmea(jl))* + * 2*pstd(jl)* + * sin(rpi/180.*plat(jl))*pvlow(jl) + ztav(jl,klev+1)= gklift*zrho(jl,klev+1)*2.*romega* +c * (2*pstd(jl)+pmea(jl))* + * 2*pstd(jl)* + * sin(rpi/180.*plat(jl))*pulow(jl) + else + ztau(jl,klev+1)=0.0 + ztav(jl,klev+1)=0.0 + endif +301 continue + +C +C* 4. COMPUTE LIFT PROFILE +C* -------------------- +C + + 400 continue + + do 401 jk=1,klev + do 401 jl=kidia,kfdia + if(ktest(jl).eq.1) then + ztau(jl,jk)=ztau(jl,klev+1)*paphm1(jl,jk)/paphm1(jl,klev+1) + ztav(jl,jk)=ztav(jl,klev+1)*paphm1(jl,jk)/paphm1(jl,klev+1) + else + ztau(jl,jk)=0.0 + ztav(jl,jk)=0.0 + endif +401 continue +C +C +C* 5. COMPUTE TENDENCIES. +C* ------------------- + if(lifthigh)then +C + 500 continue +C +C EXPLICIT SOLUTION AT ALL LEVELS +C + do 524 jk=1,klev + do 523 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zdelp=paphm1(jl,jk+1)-paphm1(jl,jk) + zdudt(jl)=-rg*(ztau(jl,jk+1)-ztau(jl,jk))/zdelp + zdvdt(jl)=-rg*(ztav(jl,jk+1)-ztav(jl,jk))/zdelp + endif + 523 continue + 524 continue +C +C PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY +C + do 530 jk=1,klev + do 530 jl=kidia,kfdia + if(ktest(jl).eq.1) then + + zslow=sqrt(pulow(jl)**2+pvlow(jl)**2) + zsqua=amax1(sqrt(pum1(jl,jk)**2+pvm1(jl,jk)**2),gvsec) + zscav=-zdudt(jl)*pvm1(jl,jk)+zdvdt(jl)*pum1(jl,jk) + if(zsqua.gt.gvsec)then + pvom(jl,jk)=-zscav*pvm1(jl,jk)/zsqua**2 + pvol(jl,jk)= zscav*pum1(jl,jk)/zsqua**2 + else + pvom(jl,jk)=0.0 + pvol(jl,jk)=0.0 + endif + zsqua=sqrt(pum1(jl,jk)**2+pum1(jl,jk)**2) + if(zsqua.lt.zslow)then + pvom(jl,jk)=zsqua/zslow*pvom(jl,jk) + pvol(jl,jk)=zsqua/zslow*pvol(jl,jk) + endif + + endif +530 continue +C +C 6. LOW LEVEL LIFT, SEMI IMPLICIT: +C ---------------------------------- + + else + + do 601 jl=kidia,kfdia + if(ktest(jl).eq.1) then + do jk=klev,iknub(jl),-1 + zbet=gklift*2.*romega*sin(rpi/180.*plat(jl))*ztmst* + * (pgeom1(jl,iknub(jl)-1)-pgeom1(jl, jk))/ + * (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,klev)) + zdudt(jl)=-pum1(jl,jk)/ztmst/(1+zbet**2) + zdvdt(jl)=-pvm1(jl,jk)/ztmst/(1+zbet**2) + pvom(jl,jk)= zbet**2*zdudt(jl) - zbet *zdvdt(jl) + pvol(jl,jk)= zbet *zdudt(jl) + zbet**2*zdvdt(jl) + enddo + endif + 601 continue + + endif + +c print *,' out orolift' + + return + end + SUBROUTINE SUGWD_strato(NLON,NLEV,paprs,pplay) +C +C +C**** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG +C +C PURPOSE. +C -------- +C INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE +C GRAVITY WAVE DRAG PARAMETRIZATION. +C VERY IMPORTANT: +C ______________ +C THIS ROUTINE SET_UP THE "TUNABLE PARAMETERS" OF THE +C VARIOUS SSO SCHEMES +C +C** INTERFACE. +C ---------- +C CALL *SUGWD* FROM *SUPHEC* +C ----- ------ +C +C EXPLICIT ARGUMENTS : +C -------------------- +C PAPRS,PPLAY : Pressure at semi and full model levels +C NLEV : number of model levels +c NLON : number of points treated in the physics +C +C IMPLICIT ARGUMENTS : +C -------------------- +C COMMON YOEGWD +C-GFRCRIT-R: Critical Non-dimensional mountain Height +C (HNC in (1), LOTT 1999) +C-GKWAKE--R: Bluff-body drag coefficient for low level wake +C (Cd in (2), LOTT 1999) +C-GRCRIT--R: Critical Richardson Number +C (Ric, End of first column p791 of LOTT 1999) +C-GKDRAG--R: Gravity wave drag coefficient +C (G in (3), LOTT 1999) +C-GKLIFT--R: Mountain Lift coefficient +C (Cl in (4), LOTT 1999) +C-GHMAX---R: Not used +C-GRAHILO-R: Set-up the trapped waves fraction +C (Beta , End of first column, LOTT 1999) +C +C-GSIGCR--R: Security value for blocked flow depth +C-NKTOPG--I: Security value for blocked flow level +C-nstra----I: An estimate to qualify the upper levels of +C the model where one wants to impose strees +C profiles +C-GSSECC--R: Security min value for low-level B-V frequency +C-GTSEC---R: Security min value for anisotropy and GW stress. +C-GVSEC---R: Security min value for ulow +C +C +C METHOD. +C ------- +C SEE DOCUMENTATION +C +C EXTERNALS. +C ---------- +C NONE +C +C REFERENCE. +C ---------- +C Lott, 1999: Alleviation of stationary biases in a GCM through... +C Monthly Weather Review, 127, pp 788-801. +C +C AUTHOR. +C ------- +C FRANCOIS LOTT *LMD* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 90-01-01 (MARTIN MILLER, ECMWF) +C LAST: 99-07-09 (FRANCOIS LOTT,LMD) +C ------------------------------------------------------------------ + USE dimphy + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz + IMPLICIT NONE +C +C ----------------------------------------------------------------- +#include "YOEGWD.h" +C ---------------------------------------------------------------- +C +C ARGUMENTS + integer nlon,nlev + REAL paprs(nlon,nlev+1) + REAL pplay(nlon,nlev) +C + INTEGER JK + REAL ZPR,ZTOP,ZSIGT,ZPM1R + REAL :: pplay_glo(klon_glo,nlev) + REAL :: paprs_glo(klon_glo,nlev+1) + +C +C* 1. SET THE VALUES OF THE PARAMETERS +C -------------------------------- +C + 100 CONTINUE +C + PRINT *,' DANS SUGWD NLEV=',NLEV + GHMAX=10000. +C + ZPR=100000. + ZTOP=0.001 + ZSIGT=0.94 +cold ZPR=80000. +cold ZSIGT=0.85 +C + CALL gather(pplay,pplay_glo) + CALL bcast(pplay_glo) + CALL gather(paprs,paprs_glo) + CALL bcast(paprs_glo) + + DO 110 JK=1,NLEV + ZPM1R=pplay_glo(klon_glo/2,jk)/paprs_glo(klon_glo/2,1) + IF(ZPM1R.GE.ZSIGT)THEN + nktopg=JK + ENDIF + ZPM1R=pplay_glo(klon_glo/2,jk)/paprs_glo(klon_glo/2,1) + IF(ZPM1R.GE.ZTOP)THEN + nstra=JK + ENDIF + 110 CONTINUE +c +c inversion car dans orodrag on compte les niveaux a l'envers + nktopg=nlev-nktopg+1 + nstra=nlev-nstra + print *,' DANS SUGWD nktopg=', nktopg + print *,' DANS SUGWD nstra=', nstra +C + GSIGCR=0.80 +C + GKDRAG=0.1875 + GRAHILO=0.1 + GRCRIT=1.00 + GFRCRIT=1.00 + GKWAKE=0.50 +C + GKLIFT=0.25 + GVCRIT =0.1 + + WRITE(UNIT=6,FMT='('' *** SSO essential constants ***'')') + WRITE(UNIT=6,FMT='('' *** SPECIFIED IN SUGWD ***'')') + WRITE(UNIT=6,FMT='('' Gravity wave ct '',E13.7,'' '')')GKDRAG + WRITE(UNIT=6,FMT='('' Trapped/total wave dag '',E13.7,'' '')') + S GRAHILO + WRITE(UNIT=6,FMT='('' Critical Richardson = '',E13.7,'' '')') + S GRCRIT + WRITE(UNIT=6,FMT='('' Critical Froude'',e13.7)') GFRCRIT + WRITE(UNIT=6,FMT='('' Low level Wake bluff cte'',e13.7)') GKWAKE + WRITE(UNIT=6,FMT='('' Low level lift cte'',e13.7)') GKLIFT + +C +C +C ---------------------------------------------------------------- +C +C* 2. SET VALUES OF SECURITY PARAMETERS +C --------------------------------- +C + 200 CONTINUE +C + GVSEC=0.10 + GSSEC=0.0001 +C + GTSEC=0.00001 +C + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ozonecm_m.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ozonecm_m.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ozonecm_m.F90 (revision 1280) @@ -0,0 +1,92 @@ +! $Header$ +module ozonecm_m + + IMPLICIT NONE + +contains + + function ozonecm(rlat, paprs, rjour) + + ! The ozone climatology is based on an analytic formula which fits the + ! Krueger and Mintzner (1976) profile, as well as the variations with + ! altitude and latitude of the maximum ozone concentrations and the total + ! column ozone concentration of Keating and Young (1986). The analytic + ! formula have been established by J.-F. Royer (CRNM, Meteo France), who + ! also provided us the code. + + ! A. J. Krueger and R. A. Minzner, A Mid-Latitude Ozone Model for the + ! 1976 U.S. Standard Atmosphere, J. Geophys. Res., 81, 4477, (1976). + + ! Keating, G. M. and D. F. Young, 1985: Interim reference models for the + ! middle atmosphere, Handbook for MAP, vol. 16, 205-229. + + USE dimphy, only: klon, klev + use assert_m, only: assert + + REAL, INTENT (IN) :: rlat(:) ! (klon) + REAL, INTENT (IN) :: paprs(:, :) ! (klon,klev+1) + REAL, INTENT (IN) :: rjour + + REAL ozonecm(klon,klev) + ! "ozonecm(j, k)" is the column-density of ozone in cell "(j, k)", that is + ! between interface "k" and interface "k + 1", in kDU. + + ! Variables local to the procedure: + + REAL tozon ! equivalent pressure of ozone above interface "k", in Pa + real pi, pl + INTEGER i, k + + REAL field(klon,klev+1) + ! "field(:, k)" is the column-density of ozone between interface + ! "k" and the top of the atmosphere (interface "llm + 1"), in kDU. + + real, PARAMETER:: ps=101325. + REAL, parameter:: an = 360., zo3q3 = 4E-8 + REAL, parameter:: dobson_unit = 2.1415E-5 ! in kg m-2 + REAL gms, zslat, zsint, zcost, z, ppm, qpm, a + REAL asec, bsec, aprim, zo3a3 + + !---------------------------------------------------------- + + call assert((/size(rlat), size(paprs, 1)/) == klon, "ozonecm klon") + call assert(size(paprs, 2) == klev + 1, "ozonecm klev") + + pi = 4. * atan(1.) + DO k = 1, klev + DO i = 1, klon + zslat = sin(pi / 180. * rlat(i)) + zsint = sin(2 * pi * (rjour + 15.) / an) + zcost = cos(2 * pi * (rjour + 15.) / an) + z = 0.0531 + zsint * (-0.001595+0.009443*zslat) & + + zcost * (-0.001344-0.00346*zslat) & + + zslat**2 * (.056222 + zslat**2 & + * (-.037609+.012248*zsint+.00521*zcost+.008890*zslat)) + zo3a3 = zo3q3/ps/2. + z = z - zo3q3*ps + gms = z + ppm = 800. - (500.*zslat+150.*zcost)*zslat + qpm = 1.74E-5 - (7.5E-6*zslat+1.7E-6*zcost)*zslat + bsec = 2650. + 5000.*zslat**2 + a = 4.0*(bsec)**(3./2.)*(ppm)**(3./2.)*(1.0+(bsec/ps)**(3./2.)) + a = a/(bsec**(3./2.)+ppm**(3./2.))**2 + aprim = (2.666666*qpm*ppm-a*gms)/(1.0-a) + aprim = amax1(0., aprim) + asec = (gms-aprim)*(1.0+(bsec/ps)**(3./2.)) + asec = amax1(0.0, asec) + aprim = gms - asec/(1.+(bsec/ps)**(3./2.)) + pl = paprs(i, k) + tozon = aprim / (1. + 3. * (ppm / pl)**2) & + + asec / (1. + (bsec / pl)**(3./2.)) + zo3a3 * pl * pl + ! Convert from Pa to kDU: + field(i, k) = tozon / 9.81 / dobson_unit / 1e3 + END DO + END DO + + field(:,klev+1) = 0. + forall (k = 1: klev) ozonecm(:,k) = field(:,k) - field(:,k+1) + ozonecm = max(ozonecm, 1e-12) + + END function ozonecm + +end module ozonecm_m Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/pbl_surface_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/pbl_surface_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/pbl_surface_mod.F90 (revision 1280) @@ -0,0 +1,1388 @@ +! +! $Id$ +! +MODULE pbl_surface_mod +! +! Planetary Boundary Layer and Surface module +! +! This module manage the calculation of turbulent diffusion in the boundary layer +! and all interactions towards the differents sub-surfaces. +! +! + USE dimphy + USE mod_phys_lmdz_para, ONLY : mpi_size + USE ioipsl + USE surface_data, ONLY : type_ocean, ok_veget + USE surf_land_mod, ONLY : surf_land + USE surf_landice_mod, ONLY : surf_landice + USE surf_ocean_mod, ONLY : surf_ocean + USE surf_seaice_mod, ONLY : surf_seaice + USE cpl_mod, ONLY : gath2cpl + USE climb_hq_mod, ONLY : climb_hq_down, climb_hq_up + USE climb_wind_mod, ONLY : climb_wind_down, climb_wind_up + USE coef_diff_turb_mod, ONLY : coef_diff_turb + + IMPLICIT NONE + +! Declaration of variables saved in restart file + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: qsol ! water height in the soil (mm) + !$OMP THREADPRIVATE(qsol) + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: fder ! flux drift + !$OMP THREADPRIVATE(fder) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: snow ! snow at surface + !$OMP THREADPRIVATE(snow) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: qsurf ! humidity at surface + !$OMP THREADPRIVATE(qsurf) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: evap ! evaporation at surface + !$OMP THREADPRIVATE(evap) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: rugos ! rugosity at surface (m) + !$OMP THREADPRIVATE(rugos) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: agesno ! age of snow at surface + !$OMP THREADPRIVATE(agesno) + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: ftsoil ! soil temperature + !$OMP THREADPRIVATE(ftsoil) + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE pbl_surface_init(qsol_rst, fder_rst, snow_rst, qsurf_rst,& + evap_rst, rugos_rst, agesno_rst, ftsoil_rst) + +! This routine should be called after the restart file has been read. +! This routine initialize the restart variables and does some validation tests +! for the index of the different surfaces and tests the choice of type of ocean. + + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + INCLUDE "iniprint.h" + +! Input variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(IN) :: qsol_rst + REAL, DIMENSION(klon), INTENT(IN) :: fder_rst + REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: snow_rst + REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: qsurf_rst + REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: evap_rst + REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: rugos_rst + REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: agesno_rst + REAL, DIMENSION(klon, nsoilmx, nbsrf), INTENT(IN) :: ftsoil_rst + + +! Local variables +!**************************************************************************************** + INTEGER :: ierr + CHARACTER(len=80) :: abort_message + CHARACTER(len = 20) :: modname = 'pbl_surface_init' + + +!**************************************************************************************** +! Allocate and initialize module variables with fields read from restart file. +! +!**************************************************************************************** + ALLOCATE(qsol(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(fder(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(snow(klon,nbsrf), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(qsurf(klon,nbsrf), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(evap(klon,nbsrf), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(rugos(klon,nbsrf), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(agesno(klon,nbsrf), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(ftsoil(klon,nsoilmx,nbsrf), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1) + + + qsol(:) = qsol_rst(:) + fder(:) = fder_rst(:) + snow(:,:) = snow_rst(:,:) + qsurf(:,:) = qsurf_rst(:,:) + evap(:,:) = evap_rst(:,:) + rugos(:,:) = rugos_rst(:,:) + agesno(:,:) = agesno_rst(:,:) + ftsoil(:,:,:) = ftsoil_rst(:,:,:) + + +!**************************************************************************************** +! Test for sub-surface indices +! +!**************************************************************************************** + IF (is_ter /= 1) THEN + WRITE(lunout,*)" *** Warning ***" + WRITE(lunout,*)" is_ter n'est pas le premier surface, is_ter = ",is_ter + WRITE(lunout,*)"or on doit commencer par les surfaces continentales" + abort_message="voir ci-dessus" + CALL abort_gcm(modname,abort_message,1) + ENDIF + + IF ( is_oce > is_sic ) THEN + WRITE(lunout,*)' *** Warning ***' + WRITE(lunout,*)' Pour des raisons de sequencement dans le code' + WRITE(lunout,*)' l''ocean doit etre traite avant la banquise' + WRITE(lunout,*)' or is_oce = ',is_oce, '> is_sic = ',is_sic + abort_message='voir ci-dessus' + CALL abort_gcm(modname,abort_message,1) + ENDIF + + IF ( is_lic > is_sic ) THEN + WRITE(lunout,*)' *** Warning ***' + WRITE(lunout,*)' Pour des raisons de sequencement dans le code' + WRITE(lunout,*)' la glace contineltalle doit etre traite avant la glace de mer' + WRITE(lunout,*)' or is_lic = ',is_lic, '> is_sic = ',is_sic + abort_message='voir ci-dessus' + CALL abort_gcm(modname,abort_message,1) + ENDIF + +!**************************************************************************************** +! Validation of ocean mode +! +!**************************************************************************************** + + IF (type_ocean /= 'slab ' .AND. type_ocean /= 'force ' .AND. type_ocean /= 'couple') THEN + WRITE(lunout,*)' *** Warning ***' + WRITE(lunout,*)'Option couplage pour l''ocean = ', type_ocean + abort_message='option pour l''ocean non valable' + CALL abort_gcm(modname,abort_message,1) + ENDIF + + END SUBROUTINE pbl_surface_init +! +!**************************************************************************************** +! + + SUBROUTINE pbl_surface( & + dtime, date0, itap, jour, & + debut, lafin, & + rlon, rlat, rugoro, rmu0, & + rain_f, snow_f, solsw_m, sollw_m, & + t, q, u, v, & + pplay, paprs, pctsrf, & + ts, alb1, alb2, u10m, v10m, & + lwdown_m, cdragh, cdragm, zu1, zv1, & + alb1_m, alb2_m, zxsens, zxevap, & + zxtsol, zxfluxlat, zt2m, qsat2m, & + d_t, d_q, d_u, d_v, & + zcoefh, slab_wfbils, & + qsol_d, zq2m, s_pblh, s_plcl, & + s_capCL, s_oliqCL, s_cteiCL, s_pblT, & + s_therm, s_trmb1, s_trmb2, s_trmb3, & + zxrugs, zu10m, zv10m, fder_print, & + zxqsurf, rh2m, zxfluxu, zxfluxv, & + rugos_d, agesno_d, sollw, solsw, & + d_ts, evap_d, fluxlat, t2m, & + wfbils, wfbilo, flux_t, flux_u, flux_v,& + dflux_t, dflux_q, zxsnow, & + zxfluxt, zxfluxq, q2m, flux_q, tke ) +!**************************************************************************************** +! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +! Objet: interface de "couche limite" (diffusion verticale) +! +!AA REM: +!AA----- +!AA Tout ce qui a trait au traceurs est dans phytrac maintenant +!AA pour l'instant le calcul de la couche limite pour les traceurs +!AA se fait avec cltrac et ne tient pas compte de la differentiation +!AA des sous-fraction de sol. +!AA REM bis : +!AA---------- +!AA Pour pouvoir extraire les coefficient d'echanges et le vent +!AA dans la premiere couche, 3 champs supplementaires ont ete crees +!AA zcoefh, zu1 et zv1. Pour l'instant nous avons moyenne les valeurs +!AA de ces trois champs sur les 4 subsurfaces du modele. Dans l'avenir +!AA si les informations des subsurfaces doivent etre prises en compte +!AA il faudra sortir ces memes champs en leur ajoutant une dimension, +!AA c'est a dire nbsrf (nbre de subsurface). +! +! Arguments: +! +! dtime----input-R- interval du temps (secondes) +! itap-----input-I- numero du pas de temps +! date0----input-R- jour initial +! t--------input-R- temperature (K) +! q--------input-R- vapeur d'eau (kg/kg) +! u--------input-R- vitesse u +! v--------input-R- vitesse v +! ts-------input-R- temperature du sol (en Kelvin) +! paprs----input-R- pression a intercouche (Pa) +! pplay----input-R- pression au milieu de couche (Pa) +! rlat-----input-R- latitude en degree +! rugos----input-R- longeur de rugosite (en m) +! +! d_t------output-R- le changement pour "t" +! d_q------output-R- le changement pour "q" +! d_u------output-R- le changement pour "u" +! d_v------output-R- le changement pour "v" +! d_ts-----output-R- le changement pour "ts" +! flux_t---output-R- flux de chaleur sensible (CpT) J/m**2/s (W/m**2) +! (orientation positive vers le bas) +! tke---input/output-R- tke (kg/m**2/s) +! flux_q---output-R- flux de vapeur d'eau (kg/m**2/s) +! flux_u---output-R- tension du vent X: (kg m/s)/(m**2 s) ou Pascal +! flux_v---output-R- tension du vent Y: (kg m/s)/(m**2 s) ou Pascal +! dflux_t--output-R- derive du flux sensible +! dflux_q--output-R- derive du flux latent +! zu1------output-R- le vent dans la premiere couche +! zv1------output-R- le vent dans la premiere couche +! trmb1----output-R- deep_cape +! trmb2----output-R- inhibition +! trmb3----output-R- Point Omega +! cteiCL---output-R- Critere d'instab d'entrainmt des nuages de CL +! plcl-----output-R- Niveau de condensation +! pblh-----output-R- HCL +! pblT-----output-R- T au nveau HCL +! + USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, co2_send + IMPLICIT NONE + + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + INCLUDE "YOMCST.h" + INCLUDE "iniprint.h" + INCLUDE "FCTTRE.h" + INCLUDE "clesphys.h" + INCLUDE "compbl.h" + INCLUDE "dimensions.h" + INCLUDE "YOETHF.h" + INCLUDE "temps.h" + INCLUDE "control.h" +! Input variables +!**************************************************************************************** + REAL, INTENT(IN) :: dtime ! time interval (s) + REAL, INTENT(IN) :: date0 ! initial day + INTEGER, INTENT(IN) :: itap ! time step + INTEGER, INTENT(IN) :: jour ! current day of the year + LOGICAL, INTENT(IN) :: debut ! true if first run step + LOGICAL, INTENT(IN) :: lafin ! true if last run step + REAL, DIMENSION(klon), INTENT(IN) :: rlon ! longitudes in degrees + REAL, DIMENSION(klon), INTENT(IN) :: rlat ! latitudes in degrees + REAL, DIMENSION(klon), INTENT(IN) :: rugoro ! rugosity length + REAL, DIMENSION(klon), INTENT(IN) :: rmu0 ! cosine of solar zenith angle + REAL, DIMENSION(klon), INTENT(IN) :: rain_f ! rain fall + REAL, DIMENSION(klon), INTENT(IN) :: snow_f ! snow fall + REAL, DIMENSION(klon), INTENT(IN) :: solsw_m ! net shortwave radiation at mean surface + REAL, DIMENSION(klon), INTENT(IN) :: sollw_m ! net longwave radiation at mean surface + REAL, DIMENSION(klon,klev), INTENT(IN) :: t ! temperature (K) + REAL, DIMENSION(klon,klev), INTENT(IN) :: q ! water vapour (kg/kg) + REAL, DIMENSION(klon,klev), INTENT(IN) :: u ! u speed + REAL, DIMENSION(klon,klev), INTENT(IN) :: v ! v speed + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay ! mid-layer pression (Pa) + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs ! pression between layers (Pa) + REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: pctsrf ! sub-surface fraction + +! Input/Output variables +!**************************************************************************************** + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: ts ! temperature at surface (K) + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: alb1 ! albedo in visible SW interval + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: alb2 ! albedo in near infra-red SW interval + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: u10m ! u speed at 10m + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: v10m ! v speed at 10m + REAL, DIMENSION(klon, klev+1, nbsrf), INTENT(INOUT) :: tke + +! Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: lwdown_m ! Downcoming longwave radiation + REAL, DIMENSION(klon), INTENT(OUT) :: cdragh ! drag coefficient for T and Q + REAL, DIMENSION(klon), INTENT(OUT) :: cdragm ! drag coefficient for wind + REAL, DIMENSION(klon), INTENT(OUT) :: zu1 ! u wind speed in first layer + REAL, DIMENSION(klon), INTENT(OUT) :: zv1 ! v wind speed in first layer + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_m ! mean albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(OUT) :: alb2_m ! mean albedo in near IR SW interval + REAL, DIMENSION(klon), INTENT(OUT) :: zxsens ! sensible heat flux at surface with inversed sign + ! (=> positive sign upwards) + REAL, DIMENSION(klon), INTENT(OUT) :: zxevap ! water vapour flux at surface, positiv upwards + REAL, DIMENSION(klon), INTENT(OUT) :: zxtsol ! temperature at surface, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: zxfluxlat ! latent flux, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: zt2m ! temperature at 2m, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: qsat2m + REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_t ! change in temperature + REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_q ! change in water vapour + REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_u ! change in u speed + REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_v ! change in v speed + REAL, DIMENSION(klon, klev), INTENT(OUT) :: zcoefh ! coef for turbulent diffusion of T and Q, mean for each grid point + +! Output only for diagnostics + REAL, DIMENSION(klon), INTENT(OUT) :: slab_wfbils! heat balance at surface only for slab at ocean points + REAL, DIMENSION(klon), INTENT(OUT) :: qsol_d ! water height in the soil (mm) + REAL, DIMENSION(klon), INTENT(OUT) :: zq2m ! water vapour at 2m, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: s_pblh ! height of the planetary boundary layer(HPBL) + REAL, DIMENSION(klon), INTENT(OUT) :: s_plcl ! condensation level + REAL, DIMENSION(klon), INTENT(OUT) :: s_capCL ! CAPE of PBL + REAL, DIMENSION(klon), INTENT(OUT) :: s_oliqCL ! liquid water intergral of PBL + REAL, DIMENSION(klon), INTENT(OUT) :: s_cteiCL ! cloud top instab. crit. of PBL + REAL, DIMENSION(klon), INTENT(OUT) :: s_pblT ! temperature at PBLH + REAL, DIMENSION(klon), INTENT(OUT) :: s_therm ! thermal virtual temperature excess + REAL, DIMENSION(klon), INTENT(OUT) :: s_trmb1 ! deep cape, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: s_trmb2 ! inhibition, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: s_trmb3 ! point Omega, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: zxrugs ! rugosity at surface (m), mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: zu10m ! u speed at 10m, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: zv10m ! v speed at 10m, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: fder_print ! fder for printing (=fder(i) + dflux_t(i) + dflux_q(i)) + REAL, DIMENSION(klon), INTENT(OUT) :: zxqsurf ! humidity at surface, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: rh2m ! relative humidity at 2m + REAL, DIMENSION(klon, klev), INTENT(OUT) :: zxfluxu ! u wind tension, mean for each grid point + REAL, DIMENSION(klon, klev), INTENT(OUT) :: zxfluxv ! v wind tension, mean for each grid point + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: rugos_d ! rugosity length (m) + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: agesno_d ! age of snow at surface + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: solsw ! net shortwave radiation at surface + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: sollw ! net longwave radiation at surface + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: d_ts ! change in temperature at surface + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: evap_d ! evaporation at surface + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: fluxlat ! latent flux + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: t2m ! temperature at 2 meter height + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: wfbils ! heat balance at surface + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: wfbilo ! water balance at surface + REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_t ! sensible heat flux (CpT) J/m**2/s (W/m**2) + ! positve orientation downwards + REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_u ! u wind tension (kg m/s)/(m**2 s) or Pascal + REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_v ! v wind tension (kg m/s)/(m**2 s) or Pascal + +! Output not needed + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_t ! change of sensible heat flux + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_q ! change of water vapour flux + REAL, DIMENSION(klon), INTENT(OUT) :: zxsnow ! snow at surface, mean for each grid point + REAL, DIMENSION(klon, klev), INTENT(OUT) :: zxfluxt ! sensible heat flux, mean for each grid point + REAL, DIMENSION(klon, klev), INTENT(OUT) :: zxfluxq ! water vapour flux, mean for each grid point + REAL, DIMENSION(klon, nbsrf),INTENT(OUT) :: q2m ! water vapour at 2 meter height + REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_q ! water vapour flux(latent flux) (kg/m**2/s) + + +! Local variables with attribute SAVE +!**************************************************************************************** + INTEGER, SAVE :: nhoridbg, nidbg ! variables for IOIPSL +!$OMP THREADPRIVATE(nhoridbg, nidbg) + LOGICAL, SAVE :: debugindex=.FALSE. +!$OMP THREADPRIVATE(debugindex) + LOGICAL, SAVE :: first_call=.TRUE. +!$OMP THREADPRIVATE(first_call) + CHARACTER(len=8), DIMENSION(nbsrf), SAVE :: cl_surf +!$OMP THREADPRIVATE(cl_surf) + +! Other local variables +!**************************************************************************************** + INTEGER :: i, k, nsrf + INTEGER :: knon, j + INTEGER :: idayref + INTEGER , DIMENSION(klon) :: ni + REAL :: zx_alf1, zx_alf2 !valeur ambiante par extrapola + REAL :: amn, amx + REAL :: f1 ! fraction de longeurs visibles parmi tout SW intervalle + REAL, DIMENSION(klon) :: r_co2_ppm ! taux CO2 atmosphere + REAL, DIMENSION(klon) :: yts, yrugos, ypct, yz0_new + REAL, DIMENSION(klon) :: yalb, yalb1, yalb2 + REAL, DIMENSION(klon) :: yu1, yv1 + REAL, DIMENSION(klon) :: ysnow, yqsurf, yagesno, yqsol + REAL, DIMENSION(klon) :: yrain_f, ysnow_f + REAL, DIMENSION(klon) :: ysolsw, ysollw + REAL, DIMENSION(klon) :: yfder + REAL, DIMENSION(klon) :: yrugoro + REAL, DIMENSION(klon) :: yfluxlat + REAL, DIMENSION(klon) :: y_d_ts + REAL, DIMENSION(klon) :: y_flux_t1, y_flux_q1 + REAL, DIMENSION(klon) :: y_dflux_t, y_dflux_q + REAL, DIMENSION(klon) :: y_flux_u1, y_flux_v1 + REAL, DIMENSION(klon) :: yt2m, yq2m, yu10m + REAL, DIMENSION(klon) :: yustar + REAL, DIMENSION(klon) :: ywindsp + REAL, DIMENSION(klon) :: yt10m, yq10m + REAL, DIMENSION(klon) :: ypblh + REAL, DIMENSION(klon) :: ylcl + REAL, DIMENSION(klon) :: ycapCL + REAL, DIMENSION(klon) :: yoliqCL + REAL, DIMENSION(klon) :: ycteiCL + REAL, DIMENSION(klon) :: ypblT + REAL, DIMENSION(klon) :: ytherm + REAL, DIMENSION(klon) :: ytrmb1 + REAL, DIMENSION(klon) :: ytrmb2 + REAL, DIMENSION(klon) :: ytrmb3 + REAL, DIMENSION(klon) :: uzon, vmer + REAL, DIMENSION(klon) :: tair1, qair1, tairsol + REAL, DIMENSION(klon) :: psfce, patm + REAL, DIMENSION(klon) :: qairsol, zgeo1 + REAL, DIMENSION(klon) :: rugo1 + REAL, DIMENSION(klon) :: yfluxsens + REAL, DIMENSION(klon) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon) :: ypsref + REAL, DIMENSION(klon) :: yevap, ytsurf_new, yalb1_new, yalb2_new + REAL, DIMENSION(klon) :: ztsol + REAL, DIMENSION(klon) :: alb_m ! mean albedo for whole SW interval + REAL, DIMENSION(klon,klev) :: y_d_t, y_d_q + REAL, DIMENSION(klon,klev) :: y_d_u, y_d_v + REAL, DIMENSION(klon,klev) :: y_flux_t, y_flux_q + REAL, DIMENSION(klon,klev) :: y_flux_u, y_flux_v + REAL, DIMENSION(klon,klev) :: ycoefh, ycoefm + REAL, DIMENSION(klon) :: ycdragh, ycdragm + REAL, DIMENSION(klon,klev) :: yu, yv + REAL, DIMENSION(klon,klev) :: yt, yq + REAL, DIMENSION(klon,klev) :: ypplay, ydelp + REAL, DIMENSION(klon,klev) :: delp + REAL, DIMENSION(klon,klev+1) :: ypaprs + REAL, DIMENSION(klon,klev+1) :: ytke + REAL, DIMENSION(klon,nsoilmx) :: ytsoil + CHARACTER(len=80) :: abort_message + CHARACTER(len=20) :: modname = 'pbl_surface' + LOGICAL, PARAMETER :: zxli=.FALSE. ! utiliser un jeu de fonctions simples + LOGICAL, PARAMETER :: check=.FALSE. + +! For debugging with IOIPSL + INTEGER, DIMENSION(iim*(jjm+1)) :: ndexbg + REAL :: zjulian + REAL, DIMENSION(klon) :: tabindx + REAL, DIMENSION(iim,jjm+1) :: zx_lon, zx_lat + REAL, DIMENSION(iim,jjm+1) :: debugtab + + + REAL, DIMENSION(klon,nbsrf) :: pblh ! height of the planetary boundary layer + REAL, DIMENSION(klon,nbsrf) :: plcl ! condensation level + REAL, DIMENSION(klon,nbsrf) :: capCL + REAL, DIMENSION(klon,nbsrf) :: oliqCL + REAL, DIMENSION(klon,nbsrf) :: cteiCL + REAL, DIMENSION(klon,nbsrf) :: pblT + REAL, DIMENSION(klon,nbsrf) :: therm + REAL, DIMENSION(klon,nbsrf) :: trmb1 ! deep cape + REAL, DIMENSION(klon,nbsrf) :: trmb2 ! inhibition + REAL, DIMENSION(klon,nbsrf) :: trmb3 ! point Omega + REAL, DIMENSION(klon,nbsrf) :: zx_rh2m, zx_qsat2m + REAL, DIMENSION(klon,nbsrf) :: zx_t1 + REAL, DIMENSION(klon, nbsrf) :: alb ! mean albedo for whole SW interval + REAL, DIMENSION(klon) :: ylwdown ! jg : temporary (ysollwdown) + + REAL :: zx_qs1, zcor1, zdelta1 + +!**************************************************************************************** +! Declarations specifiques pour le 1D. A reprendre + REAL :: fsens,flat + LOGICAL :: ok_flux_surf=.FALSE. + COMMON /flux_arp/fsens,flat,ok_flux_surf +!**************************************************************************************** +! End of declarations +!**************************************************************************************** + + +!**************************************************************************************** +! 1) Initialisation and validation tests +! Only done first time entering this subroutine +! +!**************************************************************************************** + + IF (first_call) THEN + first_call=.FALSE. + + ! Initilize debug IO + IF (debugindex .AND. mpi_size==1) THEN + ! initialize IOIPSL output + idayref = day_ini + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) + CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon) + DO i = 1, iim + zx_lon(i,1) = rlon(i+1) + zx_lon(i,jjm+1) = rlon(i+1) + ENDDO + CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat) + CALL histbeg("sous_index", iim,zx_lon(:,1),jjm+1,zx_lat(1,:), & + 1,iim,1,jjm+1, & + itau_phy,zjulian,dtime,nhoridbg,nidbg) + ! no vertical axis + cl_surf(1)='ter' + cl_surf(2)='lic' + cl_surf(3)='oce' + cl_surf(4)='sic' + DO nsrf=1,nbsrf + CALL histdef(nidbg, cl_surf(nsrf),cl_surf(nsrf), "-",iim, & + jjm+1,nhoridbg, 1, 1, 1, -99, 32, "inst", dtime,dtime) + END DO + + CALL histend(nidbg) + CALL histsync(nidbg) + + END IF + + ENDIF + +!**************************************************************************************** +! Force soil water content to qsol0 if qsol0>0 and VEGET=F (use bucket +! instead of ORCHIDEE) + IF (qsol0>0.) THEN + PRINT*,'WARNING : On impose qsol=',qsol0 + qsol(:)=qsol0 + ENDIF +!**************************************************************************************** + +!**************************************************************************************** +! 2) Initialization to zero +! Done for all local variables that will be compressed later +! and argument with INTENT(OUT) +!**************************************************************************************** + cdragh = 0.0 ; cdragm = 0.0 ; dflux_t = 0.0 ; dflux_q = 0.0 + ypct = 0.0 ; yts = 0.0 ; ysnow = 0.0 + zv1 = 0.0 ; yqsurf = 0.0 ; yalb1 = 0.0 ; yalb2 = 0.0 + yrain_f = 0.0 ; ysnow_f = 0.0 ; yfder = 0.0 ; ysolsw = 0.0 + ysollw = 0.0 ; yrugos = 0.0 ; yu1 = 0.0 + yv1 = 0.0 ; ypaprs = 0.0 ; ypplay = 0.0 + ydelp = 0.0 ; yu = 0.0 ; yv = 0.0 ; yt = 0.0 + yq = 0.0 ; y_dflux_t = 0.0 ; y_dflux_q = 0.0 + yrugoro = 0.0 ; ywindsp = 0.0 + d_ts = 0.0 ; yfluxlat=0.0 ; flux_t = 0.0 ; flux_q = 0.0 + flux_u = 0.0 ; flux_v = 0.0 ; d_t = 0.0 ; d_q = 0.0 + d_u = 0.0 ; d_v = 0.0 ; yqsol = 0.0 + ytherm = 0.0 ; ytke=0. + + zcoefh(:,:) = 0.0 + zcoefh(:,1) = 999999. ! zcoefh(:,k=1) should never be used + ytsoil = 999999. + + rh2m(:) = 0. + qsat2m(:) = 0. +!**************************************************************************************** +! 3) - Calculate pressure thickness of each layer +! - Calculate the wind at first layer +! - Mean calculations of albedo +! - Calculate net radiance at sub-surface +!**************************************************************************************** + DO k = 1, klev + DO i = 1, klon + delp(i,k) = paprs(i,k)-paprs(i,k+1) + ENDDO + ENDDO + +!**************************************************************************************** +! Test for rugos........ from physiq.. A la fin plutot??? +! +!**************************************************************************************** + + zxrugs(:) = 0.0 + DO nsrf = 1, nbsrf + DO i = 1, klon + rugos(i,nsrf) = MAX(rugos(i,nsrf),0.000015) + zxrugs(i) = zxrugs(i) + rugos(i,nsrf)*pctsrf(i,nsrf) + ENDDO + ENDDO + +! Mean calculations of albedo +! +! Albedo at sub-surface +! * alb1 : albedo in visible SW interval +! * alb2 : albedo in near infrared SW interval +! * alb : mean albedo for whole SW interval +! +! Mean albedo for grid point +! * alb1_m : albedo in visible SW interval +! * alb2_m : albedo in near infrared SW interval +! * alb_m : mean albedo at whole SW interval + + alb1_m(:) = 0.0 + alb2_m(:) = 0.0 + DO nsrf = 1, nbsrf + DO i = 1, klon + alb1_m(i) = alb1_m(i) + alb1(i,nsrf) * pctsrf(i,nsrf) + alb2_m(i) = alb2_m(i) + alb2(i,nsrf) * pctsrf(i,nsrf) + ENDDO + ENDDO + +! We here suppose the fraction f1 of incoming radiance of visible radiance +! as a fraction of all shortwave radiance + f1 = 0.5 +! f1 = 1 ! put f1=1 to recreate old calculations + + DO nsrf = 1, nbsrf + DO i = 1, klon + alb(i,nsrf) = f1*alb1(i,nsrf) + (1-f1)*alb2(i,nsrf) + ENDDO + ENDDO + + DO i = 1, klon + alb_m(i) = f1*alb1_m(i) + (1-f1)*alb2_m(i) + END DO + +! Calculation of mean temperature at surface grid points + ztsol(:) = 0.0 + DO nsrf = 1, nbsrf + DO i = 1, klon + ztsol(i) = ztsol(i) + ts(i,nsrf)*pctsrf(i,nsrf) + ENDDO + ENDDO + +! Linear distrubution on sub-surface of long- and shortwave net radiance + DO nsrf = 1, nbsrf + DO i = 1, klon + sollw(i,nsrf) = sollw_m(i) + 4.0*RSIGMA*ztsol(i)**3 * (ztsol(i)-ts(i,nsrf)) + solsw(i,nsrf) = solsw_m(i) * (1.-alb(i,nsrf)) / (1.-alb_m(i)) + ENDDO + ENDDO + + +! Downwelling longwave radiation at mean surface + lwdown_m(:) = 0.0 + DO i = 1, klon + lwdown_m(i) = sollw_m(i) + RSIGMA*ztsol(i)**4 + ENDDO + +!**************************************************************************************** +! 4) Loop over different surfaces +! +! Only points containing a fraction of the sub surface will be threated. +! +!**************************************************************************************** + + loop_nbsrf: DO nsrf = 1, nbsrf + +! Search for index(ni) and size(knon) of domaine to treat + ni(:) = 0 + knon = 0 + DO i = 1, klon + IF (pctsrf(i,nsrf) > 0.) THEN + knon = knon + 1 + ni(knon) = i + ENDIF + ENDDO + + ! write index, with IOIPSL + IF (debugindex .AND. mpi_size==1) THEN + tabindx(:)=0. + DO i=1,knon + tabindx(i)=FLOAT(i) + END DO + debugtab(:,:) = 0. + ndexbg(:) = 0 + CALL gath2cpl(tabindx,debugtab,knon,ni) + CALL histwrite(nidbg,cl_surf(nsrf),itap,debugtab,iim*(jjm+1), ndexbg) + ENDIF + +!**************************************************************************************** +! 5) Compress variables +! +!**************************************************************************************** + + DO j = 1, knon + i = ni(j) + ypct(j) = pctsrf(i,nsrf) + yts(j) = ts(i,nsrf) + ysnow(j) = snow(i,nsrf) + yqsurf(j) = qsurf(i,nsrf) + yalb(j) = alb(i,nsrf) + yalb1(j) = alb1(i,nsrf) + yalb2(j) = alb2(i,nsrf) + yrain_f(j) = rain_f(i) + ysnow_f(j) = snow_f(i) + yagesno(j) = agesno(i,nsrf) + yfder(j) = fder(i) + ysolsw(j) = solsw(i,nsrf) + ysollw(j) = sollw(i,nsrf) + yrugos(j) = rugos(i,nsrf) + yrugoro(j) = rugoro(i) + yu1(j) = u(i,1) + yv1(j) = v(i,1) + ypaprs(j,klev+1) = paprs(i,klev+1) + ywindsp(j) = SQRT(u10m(i,nsrf)**2 + v10m(i,nsrf)**2 ) + END DO + + DO k = 1, klev + DO j = 1, knon + i = ni(j) + ypaprs(j,k) = paprs(i,k) + ypplay(j,k) = pplay(i,k) + ydelp(j,k) = delp(i,k) + ytke(j,k) = tke(i,k,nsrf) + yu(j,k) = u(i,k) + yv(j,k) = v(i,k) + yt(j,k) = t(i,k) + yq(j,k) = q(i,k) + ENDDO + ENDDO + + DO k = 1, nsoilmx + DO j = 1, knon + i = ni(j) + ytsoil(j,k) = ftsoil(i,k,nsrf) + END DO + END DO + + ! qsol(water height in soil) only for bucket continental model + IF ( nsrf .EQ. is_ter .AND. .NOT. ok_veget ) THEN + DO j = 1, knon + i = ni(j) + yqsol(j) = qsol(i) + END DO + ENDIF + +!**************************************************************************************** +! 6a) Calculate coefficients for turbulent diffusion at surface, cdragh et cdragm. +! +!**************************************************************************************** + + CALL clcdrag( knon, nsrf, ypaprs, ypplay, & + yu(:,1), yv(:,1), yt(:,1), yq(:,1), & + yts, yqsurf, yrugos, & + ycdragm, ycdragh ) + +!**************************************************************************************** +! 6b) Calculate coefficients for turbulent diffusion in the atmosphere, ycoefm et ycoefm. +! +!**************************************************************************************** + + CALL coef_diff_turb(dtime, nsrf, knon, ni, & + ypaprs, ypplay, yu, yv, yq, yt, yts, yrugos, yqsurf, ycdragm, & + ycoefm, ycoefh, ytke) + +!**************************************************************************************** +! +! 8) "La descente" - "The downhill" +! +! climb_hq_down and climb_wind_down calculate the coefficients +! Ccoef_X et Dcoef_X for X=[H, Q, U, V]. +! Only the coefficients at surface for H and Q are returned. +! +!**************************************************************************************** + +! - Calculate the coefficients Ccoef_H, Ccoef_Q, Dcoef_H and Dcoef_Q + CALL climb_hq_down(knon, ycoefh, ypaprs, ypplay, & + ydelp, yt, yq, dtime, & + AcoefH, AcoefQ, BcoefH, BcoefQ) + +! - Calculate the coefficients Ccoef_U, Ccoef_V, Dcoef_U and Dcoef_V + CALL climb_wind_down(knon, dtime, ycoefm, ypplay, ypaprs, yt, ydelp, yu, yv, & + AcoefU, AcoefV, BcoefU, BcoefV) + + +!**************************************************************************************** +! 9) Small calculations +! +!**************************************************************************************** + +! - Reference pressure is given the values at surface level + ypsref(:) = ypaprs(:,1) + +! - CO2 field on 2D grid to be sent to ORCHIDEE +! Transform to compressed field + IF (carbon_cycle_cpl) THEN + DO i=1,knon + r_co2_ppm(i) = co2_send(ni(i)) + END DO + ELSE + r_co2_ppm(:) = co2_ppm ! Constant field + END IF + +!**************************************************************************************** +! +! Calulate t2m and q2m for the case of calculation at land grid points +! t2m and q2m are needed as input to ORCHIDEE +! +!**************************************************************************************** + IF (nsrf == is_ter) THEN + + DO i = 1, knon + zgeo1(i) = RD * yt(i,1) / (0.5*(ypaprs(i,1)+ypplay(i,1))) & + * (ypaprs(i,1)-ypplay(i,1)) + END DO + + ! Calculate the temperature et relative humidity at 2m and the wind at 10m + CALL stdlevvar(klon, knon, is_ter, zxli, & + yu(:,1), yv(:,1), yt(:,1), yq(:,1), zgeo1, & + yts, yqsurf, yrugos, ypaprs(:,1), ypplay(:,1), & + yt2m, yq2m, yt10m, yq10m, yu10m, yustar) + + END IF + +!**************************************************************************************** +! +! 10) Switch selon current surface +! It is necessary to start with the continental surfaces because the ocean +! needs their run-off. +! +!**************************************************************************************** + SELECT CASE(nsrf) + + CASE(is_ter) + ! ylwdown : to be removed, calculation is now done at land surface in surf_land + ylwdown(:)=0.0 + DO i=1,knon + ylwdown(i)=lwdown_m(ni(i)) + END DO + CALL surf_land(itap, dtime, date0, jour, knon, ni,& + rlon, rlat, & + debut, lafin, ydelp(:,1), r_co2_ppm, ysolsw, ysollw, yalb, & + yts, ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ypsref, yu1, yv1, yrugoro, pctsrf, & + ylwdown, yq2m, yt2m, & + ysnow, yqsol, yagesno, ytsoil, & + yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, & + yqsurf, ytsurf_new, y_dflux_t, y_dflux_q, & + y_flux_u1, y_flux_v1 ) + + + CASE(is_lic) + CALL surf_landice(itap, dtime, knon, ni, & + ysolsw, ysollw, yts, ypplay(:,1), & + ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ypsref, yu1, yv1, yrugoro, pctsrf, & + ysnow, yqsurf, yqsol, yagesno, & + ytsoil, yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, & + ytsurf_new, y_dflux_t, y_dflux_q, & + y_flux_u1, y_flux_v1) + + CASE(is_oce) + CALL surf_ocean(rlon, rlat, ysolsw, ysollw, yalb1, & + yrugos, ywindsp, rmu0, yfder, yts, & + itap, dtime, jour, knon, ni, & + ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ypsref, yu1, yv1, yrugoro, pctsrf, & + ysnow, yqsurf, yagesno, & + yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, & + ytsurf_new, y_dflux_t, y_dflux_q, slab_wfbils, & + y_flux_u1, y_flux_v1) + + CASE(is_sic) + CALL surf_seaice( & + rlon, rlat, ysolsw, ysollw, yalb1, yfder, & + itap, dtime, jour, knon, ni, & + lafin, & + yts, ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ypsref, yu1, yv1, yrugoro, pctsrf, & + ysnow, yqsurf, yqsol, yagesno, ytsoil, & + yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, & + ytsurf_new, y_dflux_t, y_dflux_q, & + y_flux_u1, y_flux_v1) + + + CASE DEFAULT + WRITE(lunout,*) 'Surface index = ', nsrf + abort_message = 'Surface index not valid' + CALL abort_gcm(modname,abort_message,1) + END SELECT + + +!**************************************************************************************** +! 11) - Calcul the increment of surface temperature +! +!**************************************************************************************** + y_d_ts(1:knon) = ytsurf_new(1:knon) - yts(1:knon) + +!**************************************************************************************** +! +! 12) "La remontee" - "The uphill" +! +! The fluxes (y_flux_X) and tendancy (y_d_X) are calculated +! for X=H, Q, U and V, for all vertical levels. +! +!**************************************************************************************** +! H and Q + IF (ok_flux_surf) THEN + PRINT *,'pbl_surface: fsens flat RLVTT=',fsens,flat,RLVTT + y_flux_t1(:) = fsens + y_flux_q1(:) = flat/RLVTT + yfluxlat(:) = flat + ELSE + y_flux_t1(:) = yfluxsens(:) + y_flux_q1(:) = -yevap(:) + ENDIF + + CALL climb_hq_up(knon, dtime, yt, yq, & + y_flux_q1, y_flux_t1, ypaprs, ypplay, & + y_flux_q(:,:), y_flux_t(:,:), y_d_q(:,:), y_d_t(:,:)) + + + CALL climb_wind_up(knon, dtime, yu, yv, y_flux_u1, y_flux_v1, & + y_flux_u, y_flux_v, y_d_u, y_d_v) + + + DO j = 1, knon + y_dflux_t(j) = y_dflux_t(j) * ypct(j) + y_dflux_q(j) = y_dflux_q(j) * ypct(j) + ENDDO + +!**************************************************************************************** +! 13) Transform variables for output format : +! - Decompress +! - Multiply with pourcentage of current surface +! - Cumulate in global variable +! +!**************************************************************************************** + + tke(:,:,nsrf) = 0. + DO k = 1, klev + DO j = 1, knon + i = ni(j) + y_d_t(j,k) = y_d_t(j,k) * ypct(j) + y_d_q(j,k) = y_d_q(j,k) * ypct(j) + y_d_u(j,k) = y_d_u(j,k) * ypct(j) + y_d_v(j,k) = y_d_v(j,k) * ypct(j) + + flux_t(i,k,nsrf) = y_flux_t(j,k) + flux_q(i,k,nsrf) = y_flux_q(j,k) + flux_u(i,k,nsrf) = y_flux_u(j,k) + flux_v(i,k,nsrf) = y_flux_v(j,k) + + tke(i,k,nsrf) = ytke(j,k) + + ENDDO + ENDDO + + evap(:,nsrf) = - flux_q(:,1,nsrf) + + alb1(:, nsrf) = 0. + alb2(:, nsrf) = 0. + snow(:, nsrf) = 0. + qsurf(:, nsrf) = 0. + rugos(:, nsrf) = 0. + fluxlat(:,nsrf) = 0. + DO j = 1, knon + i = ni(j) + d_ts(i,nsrf) = y_d_ts(j) + alb1(i,nsrf) = yalb1_new(j) + alb2(i,nsrf) = yalb2_new(j) + snow(i,nsrf) = ysnow(j) + qsurf(i,nsrf) = yqsurf(j) + rugos(i,nsrf) = yz0_new(j) + fluxlat(i,nsrf) = yfluxlat(j) + agesno(i,nsrf) = yagesno(j) + cdragh(i) = cdragh(i) + ycdragh(j)*ypct(j) + cdragm(i) = cdragm(i) + ycdragm(j)*ypct(j) + dflux_t(i) = dflux_t(i) + y_dflux_t(j) + dflux_q(i) = dflux_q(i) + y_dflux_q(j) + END DO + + DO k = 2, klev + DO j = 1, knon + i = ni(j) + zcoefh(i,k) = zcoefh(i,k) + ycoefh(j,k)*ypct(j) + END DO + END DO + + IF ( nsrf .EQ. is_ter ) THEN + DO j = 1, knon + i = ni(j) + qsol(i) = yqsol(j) + END DO + END IF + + ftsoil(:,:,nsrf) = 0. + DO k = 1, nsoilmx + DO j = 1, knon + i = ni(j) + ftsoil(i, k, nsrf) = ytsoil(j,k) + END DO + END DO + + + DO k = 1, klev + DO j = 1, knon + i = ni(j) + d_t(i,k) = d_t(i,k) + y_d_t(j,k) + d_q(i,k) = d_q(i,k) + y_d_q(j,k) + d_u(i,k) = d_u(i,k) + y_d_u(j,k) + d_v(i,k) = d_v(i,k) + y_d_v(j,k) + END DO + END DO + +!**************************************************************************************** +! 14) Calculate the temperature et relative humidity at 2m and the wind at 10m +! Call HBTM +! +!**************************************************************************************** + t2m(:,nsrf) = 0. + q2m(:,nsrf) = 0. + u10m(:,nsrf) = 0. + v10m(:,nsrf) = 0. + + pblh(:,nsrf) = 0. ! Hauteur de couche limite + plcl(:,nsrf) = 0. ! Niveau de condensation de la CLA + capCL(:,nsrf) = 0. ! CAPE de couche limite + oliqCL(:,nsrf) = 0. ! eau_liqu integree de couche limite + cteiCL(:,nsrf) = 0. ! cloud top instab. crit. couche limite + pblt(:,nsrf) = 0. ! T a la Hauteur de couche limite + therm(:,nsrf) = 0. + trmb1(:,nsrf) = 0. ! deep_cape + trmb2(:,nsrf) = 0. ! inhibition + trmb3(:,nsrf) = 0. ! Point Omega + +#undef T2m +#define T2m +#ifdef T2m +! Calculations of diagnostic t,q at 2m and u, v at 10m + + DO j=1, knon + i = ni(j) + uzon(j) = yu(j,1) + y_d_u(j,1) + vmer(j) = yv(j,1) + y_d_v(j,1) + tair1(j) = yt(j,1) + y_d_t(j,1) + qair1(j) = yq(j,1) + y_d_q(j,1) + zgeo1(j) = RD * tair1(j) / (0.5*(ypaprs(j,1)+ypplay(j,1))) & + * (ypaprs(j,1)-ypplay(j,1)) + tairsol(j) = yts(j) + y_d_ts(j) + rugo1(j) = yrugos(j) + IF(nsrf.EQ.is_oce) THEN + rugo1(j) = rugos(i,nsrf) + ENDIF + psfce(j)=ypaprs(j,1) + patm(j)=ypplay(j,1) + qairsol(j) = yqsurf(j) + END DO + + +! Calculate the temperature et relative humidity at 2m and the wind at 10m + CALL stdlevvar(klon, knon, nsrf, zxli, & + uzon, vmer, tair1, qair1, zgeo1, & + tairsol, qairsol, rugo1, psfce, patm, & + yt2m, yq2m, yt10m, yq10m, yu10m, yustar) + + DO j=1, knon + i = ni(j) + t2m(i,nsrf)=yt2m(j) + q2m(i,nsrf)=yq2m(j) + + ! u10m, v10m : composantes du vent a 10m sans spirale de Ekman + u10m(i,nsrf)=(yu10m(j) * uzon(j))/SQRT(uzon(j)**2+vmer(j)**2) + v10m(i,nsrf)=(yu10m(j) * vmer(j))/SQRT(uzon(j)**2+vmer(j)**2) + END DO + +!IM Calcule de l'humidite relative a 2m (rh2m) pour diagnostique +!IM Ajoute dependance type surface + IF (thermcep) THEN + DO j = 1, knon + i=ni(j) + zdelta1 = MAX(0.,SIGN(1., rtt-yt2m(j) )) + zx_qs1 = r2es * FOEEW(yt2m(j),zdelta1)/paprs(i,1) + zx_qs1 = MIN(0.5,zx_qs1) + zcor1 = 1./(1.-RETV*zx_qs1) + zx_qs1 = zx_qs1*zcor1 + + rh2m(i) = rh2m(i) + yq2m(j)/zx_qs1 * pctsrf(i,nsrf) + qsat2m(i) = qsat2m(i) + zx_qs1 * pctsrf(i,nsrf) + END DO + END IF + + CALL HBTM(knon, ypaprs, ypplay, & + yt2m,yt10m,yq2m,yq10m,yustar, & + y_flux_t,y_flux_q,yu,yv,yt,yq, & + ypblh,ycapCL,yoliqCL,ycteiCL,ypblT, & + ytherm,ytrmb1,ytrmb2,ytrmb3,ylcl) + + DO j=1, knon + i = ni(j) + pblh(i,nsrf) = ypblh(j) + plcl(i,nsrf) = ylcl(j) + capCL(i,nsrf) = ycapCL(j) + oliqCL(i,nsrf) = yoliqCL(j) + cteiCL(i,nsrf) = ycteiCL(j) + pblT(i,nsrf) = ypblT(j) + therm(i,nsrf) = ytherm(j) + trmb1(i,nsrf) = ytrmb1(j) + trmb2(i,nsrf) = ytrmb2(j) + trmb3(i,nsrf) = ytrmb3(j) + END DO + +#else +! T2m not defined +! No calculation + PRINT*,' Warning !!! No T2m calculation. Output is set to zero.' +#endif + +!**************************************************************************************** +! 15) End of loop over different surfaces +! +!**************************************************************************************** + END DO loop_nbsrf + +!**************************************************************************************** +! 16) Calculate the mean value over all sub-surfaces for som variables +! +!**************************************************************************************** + + zxfluxt(:,:) = 0.0 ; zxfluxq(:,:) = 0.0 + zxfluxu(:,:) = 0.0 ; zxfluxv(:,:) = 0.0 + DO nsrf = 1, nbsrf + DO k = 1, klev + DO i = 1, klon + zxfluxt(i,k) = zxfluxt(i,k) + flux_t(i,k,nsrf) * pctsrf(i,nsrf) + zxfluxq(i,k) = zxfluxq(i,k) + flux_q(i,k,nsrf) * pctsrf(i,nsrf) + zxfluxu(i,k) = zxfluxu(i,k) + flux_u(i,k,nsrf) * pctsrf(i,nsrf) + zxfluxv(i,k) = zxfluxv(i,k) + flux_v(i,k,nsrf) * pctsrf(i,nsrf) + END DO + END DO + END DO + + DO i = 1, klon + zxsens(i) = - zxfluxt(i,1) ! flux de chaleur sensible au sol + zxevap(i) = - zxfluxq(i,1) ! flux d'evaporation au sol + fder_print(i) = fder(i) + dflux_t(i) + dflux_q(i) + ENDDO + +! +! Incrementer la temperature du sol +! + zxtsol(:) = 0.0 ; zxfluxlat(:) = 0.0 + zt2m(:) = 0.0 ; zq2m(:) = 0.0 + zu10m(:) = 0.0 ; zv10m(:) = 0.0 + s_pblh(:) = 0.0 ; s_plcl(:) = 0.0 + s_capCL(:) = 0.0 ; s_oliqCL(:) = 0.0 + s_cteiCL(:) = 0.0; s_pblT(:) = 0.0 + s_therm(:) = 0.0 ; s_trmb1(:) = 0.0 + s_trmb2(:) = 0.0 ; s_trmb3(:) = 0.0 + + + DO nsrf = 1, nbsrf + DO i = 1, klon + ts(i,nsrf) = ts(i,nsrf) + d_ts(i,nsrf) + + wfbils(i,nsrf) = ( solsw(i,nsrf) + sollw(i,nsrf) & + + flux_t(i,1,nsrf) + fluxlat(i,nsrf) ) * pctsrf(i,nsrf) + wfbilo(i,nsrf) = (evap(i,nsrf) - (rain_f(i) + snow_f(i))) * & + pctsrf(i,nsrf) + + zxtsol(i) = zxtsol(i) + ts(i,nsrf) * pctsrf(i,nsrf) + zxfluxlat(i) = zxfluxlat(i) + fluxlat(i,nsrf) * pctsrf(i,nsrf) + + zt2m(i) = zt2m(i) + t2m(i,nsrf) * pctsrf(i,nsrf) + zq2m(i) = zq2m(i) + q2m(i,nsrf) * pctsrf(i,nsrf) + zu10m(i) = zu10m(i) + u10m(i,nsrf) * pctsrf(i,nsrf) + zv10m(i) = zv10m(i) + v10m(i,nsrf) * pctsrf(i,nsrf) + + s_pblh(i) = s_pblh(i) + pblh(i,nsrf) * pctsrf(i,nsrf) + s_plcl(i) = s_plcl(i) + plcl(i,nsrf) * pctsrf(i,nsrf) + s_capCL(i) = s_capCL(i) + capCL(i,nsrf) * pctsrf(i,nsrf) + s_oliqCL(i) = s_oliqCL(i) + oliqCL(i,nsrf)* pctsrf(i,nsrf) + s_cteiCL(i) = s_cteiCL(i) + cteiCL(i,nsrf)* pctsrf(i,nsrf) + s_pblT(i) = s_pblT(i) + pblT(i,nsrf) * pctsrf(i,nsrf) + s_therm(i) = s_therm(i) + therm(i,nsrf) * pctsrf(i,nsrf) + s_trmb1(i) = s_trmb1(i) + trmb1(i,nsrf) * pctsrf(i,nsrf) + s_trmb2(i) = s_trmb2(i) + trmb2(i,nsrf) * pctsrf(i,nsrf) + s_trmb3(i) = s_trmb3(i) + trmb3(i,nsrf) * pctsrf(i,nsrf) + END DO + END DO + + IF (check) THEN + amn=MIN(ts(1,is_ter),1000.) + amx=MAX(ts(1,is_ter),-1000.) + DO i=2, klon + amn=MIN(ts(i,is_ter),amn) + amx=MAX(ts(i,is_ter),amx) + ENDDO + PRINT*,' debut apres d_ts min max ftsol(ts)',itap,amn,amx + ENDIF + +!jg ? +!!$! +!!$! If a sub-surface does not exsist for a grid point, the mean value for all +!!$! sub-surfaces is distributed. +!!$! +!!$ DO nsrf = 1, nbsrf +!!$ DO i = 1, klon +!!$ IF ((pctsrf_new(i,nsrf) .LT. epsfra) .OR. (t2m(i,nsrf).EQ.0.)) THEN +!!$ ts(i,nsrf) = zxtsol(i) +!!$ t2m(i,nsrf) = zt2m(i) +!!$ q2m(i,nsrf) = zq2m(i) +!!$ u10m(i,nsrf) = zu10m(i) +!!$ v10m(i,nsrf) = zv10m(i) +!!$ +!!$! Les variables qui suivent sont plus utilise, donc peut-etre pas la peine a les mettre ajour +!!$ pblh(i,nsrf) = s_pblh(i) +!!$ plcl(i,nsrf) = s_plcl(i) +!!$ capCL(i,nsrf) = s_capCL(i) +!!$ oliqCL(i,nsrf) = s_oliqCL(i) +!!$ cteiCL(i,nsrf) = s_cteiCL(i) +!!$ pblT(i,nsrf) = s_pblT(i) +!!$ therm(i,nsrf) = s_therm(i) +!!$ trmb1(i,nsrf) = s_trmb1(i) +!!$ trmb2(i,nsrf) = s_trmb2(i) +!!$ trmb3(i,nsrf) = s_trmb3(i) +!!$ ENDIF +!!$ ENDDO +!!$ ENDDO + + + DO i = 1, klon + fder(i) = - 4.0*RSIGMA*zxtsol(i)**3 + ENDDO + + zxqsurf(:) = 0.0 + zxsnow(:) = 0.0 + DO nsrf = 1, nbsrf + DO i = 1, klon + zxqsurf(i) = zxqsurf(i) + qsurf(i,nsrf) * pctsrf(i,nsrf) + zxsnow(i) = zxsnow(i) + snow(i,nsrf) * pctsrf(i,nsrf) + END DO + END DO + +! Premier niveau de vent sortie dans physiq.F + zu1(:) = u(:,1) + zv1(:) = v(:,1) + +! Some of the module declared variables are returned for printing in physiq.F + qsol_d(:) = qsol(:) + evap_d(:,:) = evap(:,:) + rugos_d(:,:) = rugos(:,:) + agesno_d(:,:) = agesno(:,:) + + + END SUBROUTINE pbl_surface +! +!**************************************************************************************** +! + SUBROUTINE pbl_surface_final(qsol_rst, fder_rst, snow_rst, qsurf_rst, & + evap_rst, rugos_rst, agesno_rst, ftsoil_rst) + + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + +! Ouput variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsol_rst + REAL, DIMENSION(klon), INTENT(OUT) :: fder_rst + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: snow_rst + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: qsurf_rst + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: evap_rst + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: rugos_rst + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: agesno_rst + REAL, DIMENSION(klon, nsoilmx, nbsrf), INTENT(OUT) :: ftsoil_rst + + +!**************************************************************************************** +! Return module variables for writing to restart file +! +!**************************************************************************************** + qsol_rst(:) = qsol(:) + fder_rst(:) = fder(:) + snow_rst(:,:) = snow(:,:) + qsurf_rst(:,:) = qsurf(:,:) + evap_rst(:,:) = evap(:,:) + rugos_rst(:,:) = rugos(:,:) + agesno_rst(:,:) = agesno(:,:) + ftsoil_rst(:,:,:) = ftsoil(:,:,:) + +!**************************************************************************************** +! Deallocate module variables +! +!**************************************************************************************** + DEALLOCATE(qsol, fder, snow, qsurf, evap, rugos, agesno, ftsoil) + + END SUBROUTINE pbl_surface_final +! +!**************************************************************************************** +! + SUBROUTINE pbl_surface_newfrac(itime, pctsrf_new, pctsrf_old, tsurf, alb1, alb2, u10m, v10m, tke) + + ! Give default values where new fraction has appread + + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + INCLUDE "clesphys.h" + INCLUDE "compbl.h" + +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf_new, pctsrf_old + +! InOutput variables +!**************************************************************************************** + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: tsurf + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: alb1, alb2 + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: u10m, v10m + REAL, DIMENSION(klon,klev+1,nbsrf), INTENT(INOUT) :: tke + +! Local variables +!**************************************************************************************** + INTEGER :: nsrf, nsrf_comp1, nsrf_comp2, nsrf_comp3, i + CHARACTER(len=80) :: abort_message + CHARACTER(len=20) :: modname = 'pbl_surface_newfrac' + INTEGER, DIMENSION(nbsrf) :: nfois=0, mfois=0, pfois=0 +! +! All at once !! +!**************************************************************************************** + + DO nsrf = 1, nbsrf + ! First decide complement sub-surfaces + SELECT CASE (nsrf) + CASE(is_oce) + nsrf_comp1=is_sic + nsrf_comp2=is_ter + nsrf_comp3=is_lic + CASE(is_sic) + nsrf_comp1=is_oce + nsrf_comp2=is_ter + nsrf_comp3=is_lic + CASE(is_ter) + nsrf_comp1=is_lic + nsrf_comp2=is_oce + nsrf_comp3=is_sic + CASE(is_lic) + nsrf_comp1=is_ter + nsrf_comp2=is_oce + nsrf_comp3=is_sic + END SELECT + + ! Initialize all new fractions + DO i=1, klon + IF (pctsrf_new(i,nsrf) > 0. .AND. pctsrf_old(i,nsrf) == 0.) THEN + + IF (pctsrf_old(i,nsrf_comp1) > 0.) THEN + ! Use the complement sub-surface, keeping the continents unchanged + qsurf(i,nsrf) = qsurf(i,nsrf_comp1) + evap(i,nsrf) = evap(i,nsrf_comp1) + rugos(i,nsrf) = rugos(i,nsrf_comp1) + tsurf(i,nsrf) = tsurf(i,nsrf_comp1) + alb1(i,nsrf) = alb1(i,nsrf_comp1) + alb2(i,nsrf) = alb2(i,nsrf_comp1) + u10m(i,nsrf) = u10m(i,nsrf_comp1) + v10m(i,nsrf) = v10m(i,nsrf_comp1) + if (iflag_pbl > 1) then + tke(i,:,nsrf) = tke(i,:,nsrf_comp1) + endif + mfois(nsrf) = mfois(nsrf) + 1 + ELSE + ! The continents have changed. The new fraction receives the mean sum of the existent fractions + qsurf(i,nsrf) = qsurf(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + qsurf(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3) + evap(i,nsrf) = evap(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + evap(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3) + rugos(i,nsrf) = rugos(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + rugos(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3) + tsurf(i,nsrf) = tsurf(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + tsurf(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3) + alb1(i,nsrf) = alb1(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + alb1(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3) + alb2(i,nsrf) = alb2(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + alb2(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3) + u10m(i,nsrf) = u10m(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + u10m(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3) + v10m(i,nsrf) = v10m(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + v10m(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3) + if (iflag_pbl > 1) then + tke(i,:,nsrf) = tke(i,:,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + tke(i,:,nsrf_comp3)*pctsrf_old(i,nsrf_comp3) + endif + + ! Security abort. This option has never been tested. To test, comment the following line. +! abort_message='The fraction of the continents have changed!' +! CALL abort_gcm(modname,abort_message,1) + nfois(nsrf) = nfois(nsrf) + 1 + END IF + snow(i,nsrf) = 0. + agesno(i,nsrf) = 0. + ftsoil(i,:,nsrf) = tsurf(i,nsrf) + ELSE + pfois(nsrf) = pfois(nsrf)+ 1 + END IF + END DO + + END DO + + END SUBROUTINE pbl_surface_newfrac + +! +!**************************************************************************************** +! + +END MODULE pbl_surface_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phyetat0.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phyetat0.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phyetat0.F (revision 1280) @@ -0,0 +1,1048 @@ +! +! $Header$ +! +c +c + SUBROUTINE phyetat0 (fichnom, + . clesphy0, + . tabcntr0) + + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE iophy + USE ocean_cpl_mod, ONLY : ocean_cpl_init + USE fonte_neige_mod, ONLY : fonte_neige_init + USE pbl_surface_mod, ONLY : pbl_surface_init + USE surface_data, ONLY : type_ocean + USE phys_state_var_mod + USE iostart + USE write_field_phy + USE infotrac + USE traclmdz_mod, ONLY : traclmdz_from_restart + USE carbon_cycle_mod,ONLY : carbon_cycle_tr, carbon_cycle_cpl + + IMPLICIT none +c====================================================================== +c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: Lecture de l'etat initial pour la physique +c====================================================================== +#include "dimensions.h" +#include "netcdf.inc" +#include "indicesol.h" +#include "dimsoil.h" +#include "clesphys.h" +#include "temps.h" +#include "thermcell.h" +#include "compbl.h" +c====================================================================== + CHARACTER*(*) fichnom + +c les variables globales lues dans le fichier restart + + REAL tsoil(klon,nsoilmx,nbsrf) + REAL tslab(klon), seaice(klon) + REAL qsurf(klon,nbsrf) + REAL qsol(klon) + REAL snow(klon,nbsrf) + REAL evap(klon,nbsrf) + real fder(klon) + REAL frugs(klon,nbsrf) + REAL agesno(klon,nbsrf) + REAL run_off_lic_0(klon) + REAL fractint(klon) + REAL trs(klon,nbtr) + + CHARACTER*6 ocean_in + LOGICAL ok_veget_in + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) +c + REAL xmin, xmax +c + INTEGER nid, nvarid + INTEGER ierr, i, nsrf, isoil ,k + INTEGER length + PARAMETER (length=100) + INTEGER it, iiq + REAL tab_cntrl(length), tabcntr0(length) + CHARACTER*7 str7 + CHARACTER*2 str2 + LOGICAL :: found + +c FH1D +c real iolat(jjm+1) + real iolat(jjm+1-1/iim) +c +c Ouvrir le fichier contenant l'etat initial: +c + + + CALL open_startphy(fichnom) + + +c +c Lecture des parametres de controle: +c + CALL get_var("controle",tab_cntrl) + +c +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +! Les constantes de la physiques sont lues dans la physique seulement. +! Les egalites du type +! tab_cntrl( 5 )=clesphy0(1) +! sont remplacees par +! clesphy0(1)=tab_cntrl( 5 ) +! On inverse aussi la logique. +! On remplit les tab_cntrl avec les parametres lus dans les .def +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + DO i = 1, length + tabcntr0( i ) = tab_cntrl( i ) + ENDDO +c + tab_cntrl(1)=dtime + tab_cntrl(2)=radpas + +c co2_ppm : value from the previous time step + IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN + co2_ppm = tab_cntrl(3) + RCO2 = co2_ppm * 1.0e-06 * 44.011/28.97 +c ELSE : keep value from .def + END IF + +c co2_ppm0 : initial value of atmospheric CO2 (from create_etat0_limit.e .def) + co2_ppm0 = tab_cntrl(16) + + solaire_etat0 = tab_cntrl(4) + tab_cntrl(5)=iflag_con + tab_cntrl(6)=nbapp_rad + + if (cycle_diurne) tab_cntrl( 7) =1. + if (soil_model) tab_cntrl( 8) =1. + if (new_oliq) tab_cntrl( 9) =1. + if (ok_orodr) tab_cntrl(10) =1. + if (ok_orolf) tab_cntrl(11) =1. + if (ok_limitvrai) tab_cntrl(12) =1. + + + itau_phy = tab_cntrl(15) + + + + IF( clesphy0(1).NE.tab_cntrl( 5 ) ) THEN + clesphy0(1)=tab_cntrl( 5 ) + ENDIF + + IF( clesphy0(2).NE.tab_cntrl( 6 ) ) THEN + clesphy0(2)=tab_cntrl( 6 ) + ENDIF + + IF( clesphy0(3).NE.tab_cntrl( 7 ) ) THEN + clesphy0(3)=tab_cntrl( 7 ) + ENDIF + + IF( clesphy0(4).NE.tab_cntrl( 8 ) ) THEN + clesphy0(4)=tab_cntrl( 8 ) + ENDIF + + IF( clesphy0(5).NE.tab_cntrl( 9 ) ) THEN + clesphy0(5)=tab_cntrl( 9 ) + ENDIF + + IF( clesphy0(6).NE.tab_cntrl( 10 ) ) THEN + clesphy0(6)=tab_cntrl( 10 ) + ENDIF + + IF( clesphy0(7).NE.tab_cntrl( 11 ) ) THEN + clesphy0(7)=tab_cntrl( 11 ) + ENDIF + + IF( clesphy0(8).NE.tab_cntrl( 12 ) ) THEN + clesphy0(8)=tab_cntrl( 12 ) + ENDIF + + +c +c Lecture des latitudes (coordonnees): +c + CALL get_field("latitude",rlat) + +c +c Lecture des longitudes (coordonnees): +c + CALL get_field("longitude",rlon) + +C +C +C Lecture du masque terre mer +C + CALL get_field("masque",zmasq,found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT *, 'fichier startphy non compatible avec phyetat0' + ENDIF + + +C Lecture des fractions pour chaque sous-surface +C +C initialisation des sous-surfaces +C + pctsrf = 0. +C +C fraction de terre +C + + CALL get_field("FTER",pctsrf(:,is_ter),found) + IF (.NOT. found) PRINT*, 'phyetat0: Le champ est absent' + +C +C fraction de glace de terre +C + CALL get_field("FLIC",pctsrf(:,is_lic),found) + IF (.NOT. found) PRINT*, 'phyetat0: Le champ est absent' + +C +C fraction d'ocean +C + CALL get_field("FOCE",pctsrf(:,is_oce),found) + IF (.NOT. found) PRINT*, 'phyetat0: Le champ est absent' + +C +C fraction glace de mer +C + CALL get_field("FSIC",pctsrf(:,is_sic),found) + IF (.NOT. found) PRINT*, 'phyetat0: Le champ est absent' + +C +C Verification de l'adequation entre le masque et les sous-surfaces +C + fractint( 1 : klon) = pctsrf(1 : klon, is_ter) + $ + pctsrf(1 : klon, is_lic) + DO i = 1 , klon + IF ( abs(fractint(i) - zmasq(i) ) .GT. EPSFRA ) THEN + WRITE(*,*) 'phyetat0: attention fraction terre pas ', + $ 'coherente ', i, zmasq(i), pctsrf(i, is_ter) + $ ,pctsrf(i, is_lic) + ENDIF + END DO + fractint (1 : klon) = pctsrf(1 : klon, is_oce) + $ + pctsrf(1 : klon, is_sic) + DO i = 1 , klon + IF ( abs( fractint(i) - (1. - zmasq(i))) .GT. EPSFRA ) THEN + WRITE(*,*) 'phyetat0 attention fraction ocean pas ', + $ 'coherente ', i, zmasq(i) , pctsrf(i, is_oce) + $ ,pctsrf(i, is_sic) + ENDIF + END DO + +C +c Lecture des temperatures du sol: +c + + CALL get_field("TS",ftsol(:,1),found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Mais je vais essayer de lire TS**' + DO nsrf = 1, nbsrf + IF (nsrf.GT.99) THEN + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') nsrf + CALL get_field("TS"//str2,ftsol(:,nsrf)) + + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(ftsol(i,nsrf),xmin) + xmax = MAX(ftsol(i,nsrf),xmax) + ENDDO + PRINT*,'Temperature du sol TS**:', nsrf, xmin, xmax + ENDDO + ELSE + PRINT*, 'phyetat0: Le champ est present' + PRINT*, ' J ignore donc les autres temperatures TS**' + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(ftsol(i,1),xmin) + xmax = MAX(ftsol(i,1),xmax) + ENDDO + PRINT*,'Temperature du sol ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + ftsol(i,nsrf) = ftsol(i,1) + ENDDO + ENDDO + ENDIF + +c +c Lecture des temperatures du sol profond: +c + DO nsrf = 1, nbsrf + DO isoil=1, nsoilmx + IF (isoil.GT.99 .AND. nsrf.GT.99) THEN + PRINT*, "Trop de couches ou sous-mailles" + CALL abort + ENDIF + WRITE(str7,'(i2.2,"srf",i2.2)') isoil, nsrf + + CALL get_field('Tsoil'//str7,tsoil(:,isoil,nsrf),found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, " Il prend donc la valeur de surface" + DO i=1, klon + tsoil(i,isoil,nsrf)=ftsol(i,nsrf) + ENDDO + ENDIF + ENDDO + ENDDO +c +c Lecture de l'humidite de l'air juste au dessus du sol: +c + + CALL get_field("QS",qsurf(:,1),found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Mais je vais essayer de lire QS**' + DO nsrf = 1, nbsrf + IF (nsrf.GT.99) THEN + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') nsrf + CALL get_field("QS"//str2,qsurf(:,nsrf)) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(qsurf(i,nsrf),xmin) + xmax = MAX(qsurf(i,nsrf),xmax) + ENDDO + PRINT*,'Humidite pres du sol QS**:', nsrf, xmin, xmax + ENDDO + ELSE + PRINT*, 'phyetat0: Le champ est present' + PRINT*, ' J ignore donc les autres humidites QS**' + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(qsurf(i,1),xmin) + xmax = MAX(qsurf(i,1),xmax) + ENDDO + PRINT*,'Humidite pres du sol ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + qsurf(i,nsrf) = qsurf(i,1) + ENDDO + ENDDO + ENDIF + +C +C Eau dans le sol (pour le modele de sol "bucket") +C + CALL get_field("QSOL",qsol,found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Valeur par defaut nulle' + qsol(:)=0. + ENDIF + + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(qsol(i),xmin) + xmax = MAX(qsol(i),xmax) + ENDDO + PRINT*,'Eau dans le sol (mm) ', xmin, xmax + +c +c Lecture de neige au sol: +c + + CALL get_field("SNOW",snow(:,1),found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Mais je vais essayer de lire SNOW**' + DO nsrf = 1, nbsrf + IF (nsrf.GT.99) THEN + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') nsrf + CALL get_field( "SNOW"//str2,snow(:,nsrf)) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(snow(i,nsrf),xmin) + xmax = MAX(snow(i,nsrf),xmax) + ENDDO + PRINT*,'Neige du sol SNOW**:', nsrf, xmin, xmax + ENDDO + ELSE + PRINT*, 'phyetat0: Le champ est present' + PRINT*, ' J ignore donc les autres neiges SNOW**' + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(snow(i,1),xmin) + xmax = MAX(snow(i,1),xmax) + ENDDO + PRINT*,'Neige du sol ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + snow(i,nsrf) = snow(i,1) + ENDDO + ENDDO + ENDIF +c +c Lecture de albedo de l'interval visible au sol: +c + CALL get_field("ALBE",falb1(:,1),found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Mais je vais essayer de lire ALBE**' + DO nsrf = 1, nbsrf + IF (nsrf.GT.99) THEN + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') nsrf + CALL get_field("ALBE"//str2,falb1(:,nsrf)) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(falb1(i,nsrf),xmin) + xmax = MAX(falb1(i,nsrf),xmax) + ENDDO + PRINT*,'Albedo du sol ALBE**:', nsrf, xmin, xmax + ENDDO + ELSE + PRINT*, 'phyetat0: Le champ est present' + PRINT*, ' J ignore donc les autres ALBE**' + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(falb1(i,1),xmin) + xmax = MAX(falb1(i,1),xmax) + ENDDO + PRINT*,'Neige du sol ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + falb1(i,nsrf) = falb1(i,1) + ENDDO + ENDDO + ENDIF + +c +c Lecture de albedo au sol dans l'interval proche infra-rouge: +c + CALL get_field("ALBLW",falb2(:,1),found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Mais je vais prendre ALBE**' + DO nsrf = 1, nbsrf + DO i = 1, klon + falb2(i,nsrf) = falb1(i,nsrf) + ENDDO + ENDDO + ELSE + PRINT*, 'phyetat0: Le champ est present' + PRINT*, ' J ignore donc les autres ALBLW**' + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(falb2(i,1),xmin) + xmax = MAX(falb2(i,1),xmax) + ENDDO + PRINT*,'Neige du sol ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + falb2(i,nsrf) = falb2(i,1) + ENDDO + ENDDO + ENDIF +c +c Lecture de evaporation: +c + CALL get_field("EVAP",evap(:,1),found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Mais je vais essayer de lire EVAP**' + DO nsrf = 1, nbsrf + IF (nsrf.GT.99) THEN + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') nsrf + CALL get_field("EVAP"//str2, evap(:,nsrf)) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(evap(i,nsrf),xmin) + xmax = MAX(evap(i,nsrf),xmax) + ENDDO + PRINT*,'evap du sol EVAP**:', nsrf, xmin, xmax + ENDDO + ELSE + PRINT*, 'phyetat0: Le champ est present' + PRINT*, ' J ignore donc les autres EVAP**' + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(evap(i,1),xmin) + xmax = MAX(evap(i,1),xmax) + ENDDO + PRINT*,'Evap du sol ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + evap(i,nsrf) = evap(i,1) + ENDDO + ENDDO + ENDIF +c +c Lecture precipitation liquide: +c + CALL get_field("rain_f",rain_fall) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(rain_fall(i),xmin) + xmax = MAX(rain_fall(i),xmax) + ENDDO + PRINT*,'Precipitation liquide rain_f:', xmin, xmax +c +c Lecture precipitation solide: +c + CALL get_field("snow_f",snow_fall) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(snow_fall(i),xmin) + xmax = MAX(snow_fall(i),xmax) + ENDDO + PRINT*,'Precipitation solide snow_f:', xmin, xmax +c +c Lecture rayonnement solaire au sol: +c + CALL get_field("solsw",solsw,found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + solsw(:) = 0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(solsw(i),xmin) + xmax = MAX(solsw(i),xmax) + ENDDO + PRINT*,'Rayonnement solaire au sol solsw:', xmin, xmax +c +c Lecture rayonnement IF au sol: +c + CALL get_field("sollw",sollw,found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + sollw = 0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(sollw(i),xmin) + xmax = MAX(sollw(i),xmax) + ENDDO + PRINT*,'Rayonnement IF au sol sollw:', xmin, xmax + +c +c Lecture derive des flux: +c + CALL get_field("fder",fder,found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + fder = 0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(fder(i),xmin) + xmax = MAX(fder(i),xmax) + ENDDO + PRINT*,'Derive des flux fder:', xmin, xmax + +c +c Lecture du rayonnement net au sol: +c + CALL get_field("RADS",radsol) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(radsol(i),xmin) + xmax = MAX(radsol(i),xmax) + ENDDO + PRINT*,'Rayonnement net au sol radsol:', xmin, xmax +c +c Lecture de la longueur de rugosite +c +c + CALL get_field("RUG",frugs(:,1),found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Mais je vais essayer de lire RUG**' + DO nsrf = 1, nbsrf + IF (nsrf.GT.99) THEN + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') nsrf + CALL get_field("RUG"//str2,frugs(:,nsrf)) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(frugs(i,nsrf),xmin) + xmax = MAX(frugs(i,nsrf),xmax) + ENDDO + PRINT*,'rugosite du sol RUG**:', nsrf, xmin, xmax + ENDDO + ELSE + PRINT*, 'phyetat0: Le champ est present' + PRINT*, ' J ignore donc les autres RUG**' + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(frugs(i,1),xmin) + xmax = MAX(frugs(i,1),xmax) + ENDDO + PRINT*,'rugosite ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + frugs(i,nsrf) = frugs(i,1) + ENDDO + ENDDO + ENDIF + +c +c Lecture de l'age de la neige: +c + CALL get_field("AGESNO",agesno(:,1),found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Mais je vais essayer de lire AGESNO**' + DO nsrf = 1, nbsrf + IF (nsrf.GT.99) THEN + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') nsrf + CALL get_field("AGESNO"//str2,agesno(:,nsrf),found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + agesno = 50.0 + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(agesno(i,nsrf),xmin) + xmax = MAX(agesno(i,nsrf),xmax) + ENDDO + PRINT*,'Age de la neige AGESNO**:', nsrf, xmin, xmax + ENDDO + ELSE + PRINT*, 'phyetat0: Le champ est present' + PRINT*, ' J ignore donc les autres AGESNO**' + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(agesno(i,1),xmin) + xmax = MAX(agesno(i,1),xmax) + ENDDO + PRINT*,'Age de la neige ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + agesno(i,nsrf) = agesno(i,1) + ENDDO + ENDDO + ENDIF + +c + CALL get_field("ZMEA", zmea) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zmea(i),xmin) + xmax = MAX(zmea(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zmea:', xmin, xmax +c +c + CALL get_field("ZSTD",zstd) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zstd(i),xmin) + xmax = MAX(zstd(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zstd:', xmin, xmax +c +c + CALL get_field("ZSIG",zsig) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zsig(i),xmin) + xmax = MAX(zsig(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zsig:', xmin, xmax +c +c + CALL get_field("ZGAM",zgam) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zgam(i),xmin) + xmax = MAX(zgam(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zgam:', xmin, xmax +c +c + CALL get_field("ZTHE",zthe) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zthe(i),xmin) + xmax = MAX(zthe(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zthe:', xmin, xmax +c +c + CALL get_field("ZPIC",zpic) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zpic(i),xmin) + xmax = MAX(zpic(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zpic:', xmin, xmax +c + CALL get_field("ZVAL",zval) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zval(i),xmin) + xmax = MAX(zval(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zval:', xmin, xmax +c +c + CALL get_field("RUGSREL",rugoro) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(rugoro(i),xmin) + xmax = MAX(rugoro(i),xmax) + ENDDO + PRINT*,'Rugosite relief (ecart-type) rugsrel:', xmin, xmax +c +c + +c + ancien_ok = .TRUE. + + CALL get_field("TANCIEN",t_ancien,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ancien_ok = .FALSE. + ENDIF + + + CALL get_field("QANCIEN",q_ancien,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ancien_ok = .FALSE. + ENDIF + + u_ancien = 0.0 !AXC: We don't have u_ancien and v_ancien in the start + v_ancien = 0.0 !AXC: files, therefore they have to be initialized. +c + + clwcon=0. + CALL get_field("CLWCON",clwcon(:,1),found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ CLWCON est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(clwcon) + xmax = MAXval(clwcon) + PRINT*,'Eau liquide convective (ecart-type) clwcon:', xmin, xmax +c + rnebcon = 0. + CALL get_field("RNEBCON",rnebcon(:,1),found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ RNEBCON est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(rnebcon) + xmax = MAXval(rnebcon) + PRINT*,'Nebulosite convective (ecart-type) rnebcon:', xmin, xmax + +c +c Lecture ratqs +c + ratqs=0. + CALL get_field("RATQS",ratqs(:,1),found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(ratqs) + xmax = MAXval(ratqs) + PRINT*,'(ecart-type) ratqs:', xmin, xmax +c +c Lecture run_off_lic_0 +c + CALL get_field("RUNOFFLIC0",run_off_lic_0,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + run_off_lic_0 = 0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(run_off_lic_0) + xmax = MAXval(run_off_lic_0) + PRINT*,'(ecart-type) run_off_lic_0:', xmin, xmax + + +c Lecture de l'energie cinetique turbulente +c + + IF (iflag_pbl>1) then + DO nsrf = 1, nbsrf + IF (nsrf.GT.99) THEN + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') nsrf + CALL get_field("TKE"//str2,pbl_tke(:,1:klev,nsrf),found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: est absent" + pbl_tke(:,:,nsrf)=1.e-8 + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO k = 1, klev + DO i = 1, klon + xmin = MIN(pbl_tke(i,k,nsrf),xmin) + xmax = MAX(pbl_tke(i,k,nsrf),xmax) + ENDDO + ENDDO + PRINT*,'Temperature du sol TKE**:', nsrf, xmin, xmax + ENDDO + ENDIF +c +c zmax0 + CALL get_field("ZMAX0",zmax0,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + zmax0=40. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(zmax0) + xmax = MAXval(zmax0) + PRINT*,'(ecart-type) zmax0:', xmin, xmax +c +c f0(ig)=1.e-5 +c f0 + CALL get_field("F0",f0,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + f0=1.e-5 + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(f0) + xmax = MAXval(f0) + PRINT*,'(ecart-type) f0:', xmin, xmax +c +c ema_work1 +c + CALL get_field("EMA_WORK1",ema_work1,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ema_work1=0. + ELSE + xmin = 1.0E+20 + xmax = -1.0E+20 + DO k = 1, klev + DO i = 1, klon + xmin = MIN(ema_work1(i,k),xmin) + xmax = MAX(ema_work1(i,k),xmax) + ENDDO + ENDDO + PRINT*,'ema_work1:', xmin, xmax + ENDIF +c +c ema_work2 +c + CALL get_field("EMA_WORK2",ema_work2,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ema_work2=0. + ELSE + xmin = 1.0E+20 + xmax = -1.0E+20 + DO k = 1, klev + DO i = 1, klon + xmin = MIN(ema_work2(i,k),xmin) + xmax = MAX(ema_work2(i,k),xmax) + ENDDO + ENDDO + PRINT*,'ema_work2:', xmin, xmax + ENDIF +c +c wake_deltat +c + CALL get_field("WAKE_DELTAT",wake_deltat,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + wake_deltat=0. + ELSE + xmin = 1.0E+20 + xmax = -1.0E+20 + DO k = 1, klev + DO i = 1, klon + xmin = MIN(wake_deltat(i,k),xmin) + xmax = MAX(wake_deltat(i,k),xmax) + ENDDO + ENDDO + PRINT*,'wake_deltat:', xmin, xmax + ENDIF +c +c wake_deltaq +c + CALL get_field("WAKE_DELTAQ",wake_deltaq,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + wake_deltaq=0. + ELSE + xmin = 1.0E+20 + xmax = -1.0E+20 + DO k = 1, klev + DO i = 1, klon + xmin = MIN(wake_deltaq(i,k),xmin) + xmax = MAX(wake_deltaq(i,k),xmax) + ENDDO + ENDDO + PRINT*,'wake_deltaq:', xmin, xmax + ENDIF +c +c wake_s +c + CALL get_field("WAKE_S",wake_s,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + wake_s=0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(wake_s) + xmax = MAXval(wake_s) + PRINT*,'(ecart-type) wake_s:', xmin, xmax +c +c wake_cstar +c + CALL get_field("WAKE_CSTAR",wake_cstar,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + wake_cstar=0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(wake_cstar) + xmax = MAXval(wake_cstar) + PRINT*,'(ecart-type) wake_cstar:', xmin, xmax +c +c wake_fip +c + CALL get_field("WAKE_FIP",wake_fip,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + wake_fip=0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(wake_fip) + xmax = MAXval(wake_fip) + PRINT*,'(ecart-type) wake_fip:', xmin, xmax +c +c Read and send field trs to traclmdz +c + IF (type_trac == 'lmdz') THEN + DO it=1,nbtr + iiq=niadv(it+2) + CALL get_field("trs_"//tname(iiq),trs(:,it),found) + IF (.NOT. found) THEN + PRINT*, + $ "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + trs(:,it) = 0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(trs(:,it)) + xmax = MAXval(trs(:,it)) + PRINT*,"(ecart-type) trs_"//tname(iiq)//" :", xmin, xmax + + END DO + + CALL traclmdz_from_restart(trs) + END IF + + +c on ferme le fichier + CALL close_startphy + + CALL init_iophy_new(rlat,rlon) + + +c +c Initialize module pbl_surface_mod +c + CALL pbl_surface_init(qsol, fder, snow, qsurf, + $ evap, frugs, agesno, tsoil) + +c Initialize module ocean_cpl_mod for the case of coupled ocean + IF ( type_ocean == 'couple' ) THEN + CALL ocean_cpl_init(dtime, rlon, rlat) + ENDIF +c +c Initilialize module fonte_neige_mod +c + CALL fonte_neige_init(run_off_lic_0) + + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phyredem.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phyredem.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phyredem.F (revision 1280) @@ -0,0 +1,334 @@ +! +! $Header$ +! +c + SUBROUTINE phyredem (fichnom) + + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE fonte_neige_mod, ONLY : fonte_neige_final + USE pbl_surface_mod, ONLY : pbl_surface_final + USE phys_state_var_mod + USE iostart + USE traclmdz_mod, ONLY : traclmdz_to_restart + USE infotrac + + IMPLICIT none +c====================================================================== +c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: Ecriture de l'etat de redemarrage pour la physique +c====================================================================== +#include "netcdf.inc" +#include "indicesol.h" +#include "dimsoil.h" +#include "clesphys.h" +#include "control.h" +#include "temps.h" +#include "thermcell.h" +#include "compbl.h" +c====================================================================== + CHARACTER*(*) fichnom + +c les variables globales ecrites dans le fichier restart + + + REAL tsoil(klon,nsoilmx,nbsrf) + REAL tslab(klon), seaice(klon) + REAL qsurf(klon,nbsrf) + REAL qsol(klon) + REAL snow(klon,nbsrf) + REAL evap(klon,nbsrf) + real fder(klon) + REAL frugs(klon,nbsrf) + REAL agesno(klon,nbsrf) + REAL run_off_lic_0(klon) + REAL trs(klon,nbtr) +c + INTEGER nid, nvarid, idim1, idim2, idim3 + INTEGER ierr + INTEGER length + PARAMETER (length=100) + REAL tab_cntrl(length) +c + INTEGER isoil, nsrf + CHARACTER (len=7) :: str7 + CHARACTER (len=2) :: str2 + INTEGER :: it, iiq + +c====================================================================== +c +c Get variables which will be written to restart file from module +c pbl_surface_mod + CALL pbl_surface_final(qsol, fder, snow, qsurf, + $ evap, frugs, agesno, tsoil) + +c Get a variable calculated in module fonte_neige_mod + CALL fonte_neige_final(run_off_lic_0) + +c====================================================================== + + CALL open_restartphy(fichnom) + + DO ierr = 1, length + tab_cntrl(ierr) = 0.0 + ENDDO +CC tab_cntrl(1) = dtime + tab_cntrl(2) = radpas +c co2_ppm : current value of atmospheric CO2 + tab_cntrl(3) = co2_ppm + tab_cntrl(4) = solaire + tab_cntrl(5) = iflag_con + tab_cntrl(6) = nbapp_rad + + IF( cycle_diurne ) tab_cntrl( 7 ) = 1. + IF( soil_model ) tab_cntrl( 8 ) = 1. + IF( new_oliq ) tab_cntrl( 9 ) = 1. + IF( ok_orodr ) tab_cntrl(10 ) = 1. + IF( ok_orolf ) tab_cntrl(11 ) = 1. + + tab_cntrl(13) = day_end + tab_cntrl(14) = annee_ref + tab_cntrl(15) = itau_phy + +c co2_ppm0 : initial value of atmospheric CO2 + tab_cntrl(16) = co2_ppm0 +c + CALL put_var("controle","Parametres de controle",tab_cntrl) +c + + CALL put_field("longitude", + . "Longitudes de la grille physique",rlon) + + CALL put_field("latitude","Latitudes de la grille physique",rlat) + +c +C PB ajout du masque terre/mer +C + CALL put_field("masque","masque terre mer",zmasq) + +c BP ajout des fraction de chaque sous-surface +C +C 1. fraction de terre +C + CALL put_field("FTER","fraction de continent",pctsrf(:,is_ter)) +C +C 2. Fraction de glace de terre +C + CALL put_field("FLIC","fraction glace de terre",pctsrf(:,is_lic)) +C +C 3. fraction ocean +C + CALL put_field("FOCE","fraction ocean",pctsrf(:,is_oce)) +C +C 4. Fraction glace de mer +C + CALL put_field("FSIC","fraction glace mer",pctsrf(:,is_sic)) +C +C +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("TS"//str2,"Temperature de surface No."//str2, + . ftsol(:,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + ENDDO +c + DO nsrf = 1, nbsrf + DO isoil=1, nsoilmx + IF (isoil.LE.99 .AND. nsrf.LE.99) THEN + WRITE(str7,'(i2.2,"srf",i2.2)') isoil,nsrf + CALL put_field("Tsoil"//str7,"Temperature du sol No."//str7, + . tsoil(:,isoil,nsrf)) + ELSE + PRINT*, "Trop de couches" + CALL abort + ENDIF + ENDDO + ENDDO +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("QS"//str2,"Humidite de surface No."//str2, + . qsurf(:,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + END DO +C + CALL put_field("QSOL","Eau dans le sol (mm)",qsol) +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("ALBE"//str2,"albedo de surface No."//str2, + . falb1(:,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + ENDDO + + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("ALBLW"//str2,"albedo LW de surface No."//str2, + . falb2(:,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + ENDDO +c +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("EVAP"//str2,"Evaporation de surface No."//str2 + . ,evap(:,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + ENDDO + +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("SNOW"//str2,"Neige de surface No."//str2, + . snow(:,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + ENDDO + +c + CALL put_field("RADS","Rayonnement net a la surface",radsol) +c + CALL put_field("solsw","Rayonnement solaire a la surface",solsw) +c + CALL put_field("sollw","Rayonnement IF a la surface",sollw) +c + CALL put_field("fder","Derive de flux",fder) +c + CALL put_field("rain_f","precipitation liquide",rain_fall) +c + CALL put_field("snow_f", "precipitation solide",snow_fall) +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("RUG"//str2,"rugosite de surface No."//str2, + . frugs(:,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + ENDDO +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("AGESNO"//str2, + . "Age de la neige surface No."//str2, + . agesno(:,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + ENDDO +c + CALL put_field("ZMEA","",zmea) +c + CALL put_field("ZSTD","",zstd) + + CALL put_field("ZSIG","",zsig) + + CALL put_field("ZGAM","",zgam) + + CALL put_field("ZTHE","",zthe) + + CALL put_field("ZPIC","",zpic) + + CALL put_field("ZVAL","",zval) + + CALL put_field("RUGSREL","RUGSREL",rugoro) + + CALL put_field("TANCIEN","",t_ancien) + + CALL put_field("QANCIEN","",q_ancien) + + CALL put_field("RUGMER","Longueur de rugosite sur mer", + . frugs(:,is_oce)) + + CALL put_field("CLWCON","Eau liquide convective",clwcon(:,1)) + + CALL put_field("RNEBCON","Nebulosite convective",rnebcon(:,1)) + + CALL put_field("RATQS", "Ratqs",ratqs(:,1)) +c +c run_off_lic_0 +c + CALL put_field("RUNOFFLIC0","Runofflic0",run_off_lic_0) +c +c +!!!!!!!!!!!!!!!!!!!! DEB TKE PBL !!!!!!!!!!!!!!!!!!!!!!!!! +c + IF (iflag_pbl>1) then + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("TKE"//str2,"Energ. Cineti. Turb."//str2, + . pbl_tke(:,1:klev,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + ENDDO + ENDIF + +!!!!!!!!!!!!!!!!!!!! FIN TKE PBL !!!!!!!!!!!!!!!!!!!!!!!!! +cIM ajout zmax0, f0, ema_work1, ema_work2 +cIM wake_deltat, wake_deltaq, wake_s, wake_cstar, wake_fip + + CALL put_field("ZMAX0","",zmax0) + + CALL put_field("F0","",f0) + + CALL put_field("EMA_WORK1","",ema_work1) + + CALL put_field("EMA_WORK2","",ema_work2) + +c wake_deltat + CALL put_field("WAKE_DELTAT","",wake_deltat) + + CALL put_field("WAKE_DELTAQ","",wake_deltaq) + + CALL put_field("WAKE_S","",wake_s) + + CALL put_field("WAKE_CSTAR","",wake_cstar) + + CALL put_field("WAKE_FIP","",wake_fip) + + +! trs from traclmdz_mod + IF (type_trac == 'lmdz') THEN + CALL traclmdz_to_restart(trs) + DO it=1,nbtr + iiq=niadv(it+2) + CALL put_field("trs_"//tname(iiq),"",trs(:,it)) + END DO + END IF + + CALL close_restartphy +!$OMP BARRIER + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phys_cal_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phys_cal_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phys_cal_mod.F90 (revision 1280) @@ -0,0 +1,41 @@ +! $Id:$ +MODULE phys_cal_mod +! This module contains information on the calendar at the actual time step + + SAVE + + INTEGER :: year_cur ! current year + INTEGER :: mth_cur ! current month + INTEGER :: day_cur ! current day + INTEGER :: days_elapsed ! number of whole days since start of the simulation + INTEGER :: mth_len ! number of days in the current month + REAL :: hour + REAL :: jD_1jan + REAL :: jH_1jan + REAL :: xjour + + +CONTAINS + + SUBROUTINE phys_cal_update(jD_cur, jH_cur) + ! This subroutine updates the module saved variables. + + USE IOIPSL + + REAL, INTENT(IN) :: jD_cur ! jour courant a l'appel de la physique (jour julien) + REAL, INTENT(IN) :: jH_cur ! heure courante a l'appel de la physique (jour julien) + + CALL ju2ymds(jD_cur+jH_cur, year_cur, mth_cur, day_cur, hour) + CALL ymds2ju(year_cur, 1, 1, 0., jD_1jan) + + jH_1jan = jD_1jan - int (jD_1jan) + jD_1jan = int (jD_1jan) + xjour = jD_cur - jD_1jan + days_elapsed = jD_cur - jD_1jan + + ! Get lenght of acutual month + mth_len = ioget_mon_len(year_cur,mth_cur) + + END SUBROUTINE phys_cal_update + +END MODULE phys_cal_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phys_local_var_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phys_local_var_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phys_local_var_mod.F90 (revision 1280) @@ -0,0 +1,176 @@ +! +! $Id$ +! + MODULE phys_local_var_mod + +! Variables locales pour effectuer les appels en serie +!====================================================================== +! +! +!====================================================================== +! Declaration des variables + + REAL, SAVE, ALLOCATABLE :: t_seri(:,:), q_seri(:,:) + !$OMP THREADPRIVATE(t_seri, q_seri) + REAL, SAVE, ALLOCATABLE :: ql_seri(:,:),qs_seri(:,:) + !$OMP THREADPRIVATE(ql_seri,qs_seri) + REAL, SAVE, ALLOCATABLE :: u_seri(:,:), v_seri(:,:) + !$OMP THREADPRIVATE(u_seri, v_seri) + + REAL, SAVE, ALLOCATABLE :: tr_seri(:,:,:) + !$OMP THREADPRIVATE(tr_seri) + REAL, SAVE, ALLOCATABLE :: d_t_dyn(:,:), d_q_dyn(:,:) + !$OMP THREADPRIVATE(d_t_dyn, d_q_dyn) + REAL, SAVE, ALLOCATABLE :: d_u_dyn(:,:), d_v_dyn(:,:) + !$OMP THREADPRIVATE(d_u_dyn, d_v_dyn) + REAL, SAVE, ALLOCATABLE :: d_t_con(:,:),d_q_con(:,:) + !$OMP THREADPRIVATE(d_t_con,d_q_con) + REAL, SAVE, ALLOCATABLE :: d_u_con(:,:),d_v_con(:,:) + !$OMP THREADPRIVATE(d_u_con,d_v_con) + REAL, SAVE, ALLOCATABLE :: d_t_wake(:,:),d_q_wake(:,:) + !$OMP THREADPRIVATE( d_t_wake,d_q_wake) + REAL, SAVE, ALLOCATABLE :: d_t_lsc(:,:),d_q_lsc(:,:),d_ql_lsc(:,:) + !$OMP THREADPRIVATE(d_t_lsc,d_q_lsc,d_ql_lsc) + REAL, SAVE, ALLOCATABLE :: d_t_ajsb(:,:), d_q_ajsb(:,:) + !$OMP THREADPRIVATE(d_t_ajsb, d_q_ajsb) + REAL, SAVE, ALLOCATABLE :: d_t_ajs(:,:), d_q_ajs(:,:) + !$OMP THREADPRIVATE(d_t_ajs, d_q_ajs) + REAL, SAVE, ALLOCATABLE :: d_u_ajs(:,:), d_v_ajs(:,:) + !$OMP THREADPRIVATE(d_u_ajs, d_v_ajs) + REAL, SAVE, ALLOCATABLE :: d_t_eva(:,:),d_q_eva(:,:) + !$OMP THREADPRIVATE(d_t_eva,d_q_eva) +!tendances dues a oro et lif + REAL, SAVE, ALLOCATABLE :: d_t_oli(:,:) + !$OMP THREADPRIVATE(d_t_oli) + REAL, SAVE, ALLOCATABLE :: d_u_oli(:,:), d_v_oli(:,:) + !$OMP THREADPRIVATE(d_u_oli, d_v_oli) + REAL, SAVE, ALLOCATABLE :: d_t_vdf(:,:), d_q_vdf(:,:) + !$OMP THREADPRIVATE( d_t_vdf, d_q_vdf) + REAL, SAVE, ALLOCATABLE :: d_u_vdf(:,:), d_v_vdf(:,:) + !$OMP THREADPRIVATE(d_u_vdf, d_v_vdf) + REAL, SAVE, ALLOCATABLE :: d_t_oro(:,:) + !$OMP THREADPRIVATE(d_t_oro) + REAL, SAVE, ALLOCATABLE :: d_u_oro(:,:), d_v_oro(:,:) + !$OMP THREADPRIVATE(d_u_oro, d_v_oro) + REAL, SAVE, ALLOCATABLE :: d_t_lif(:,:) + !$OMP THREADPRIVATE(d_t_lif) + REAL, SAVE, ALLOCATABLE :: d_u_lif(:,:), d_v_lif(:,:) + !$OMP THREADPRIVATE(d_u_lif, d_v_lif) +! Tendances Ondes de G non oro (runs strato). + REAL, SAVE, ALLOCATABLE :: d_u_hin(:,:) + !$OMP THREADPRIVATE(d_u_hin) + REAL, SAVE, ALLOCATABLE :: d_v_hin(:,:) + !$OMP THREADPRIVATE(d_v_hin) + REAL, SAVE, ALLOCATABLE :: d_t_hin(:,:) + !$OMP THREADPRIVATE(d_t_hin) + +! tendance du a la conersion Ec -> E thermique + REAL, SAVE, ALLOCATABLE :: d_t_ec(:,:) + !$OMP THREADPRIVATE(d_t_ec) + REAL, SAVE, ALLOCATABLE :: d_ts(:,:), d_tr(:,:,:) + !$OMP THREADPRIVATE(d_ts, d_tr) + +! diagnostique pour le rayonnement + REAL, SAVE, ALLOCATABLE :: topswad_aero(:), solswad_aero(:) ! diag + !$OMP THREADPRIVATE(topswad_aero,solswad_aero) + REAL, SAVE, ALLOCATABLE :: topswai_aero(:), solswai_aero(:) ! diag + !$OMP THREADPRIVATE(topswai_aero,solswai_aero) + REAL, SAVE, ALLOCATABLE :: topswad0_aero(:), solswad0_aero(:) ! diag + !$OMP THREADPRIVATE(topswad0_aero,solswad0_aero) + REAL, SAVE, ALLOCATABLE :: topsw_aero(:,:), solsw_aero(:,:) ! diag + !$OMP THREADPRIVATE(topsw_aero,solsw_aero) + REAL, SAVE, ALLOCATABLE :: topsw0_aero(:,:), solsw0_aero(:,:) ! diag + !$OMP THREADPRIVATE(topsw0_aero,solsw0_aero) + REAL, SAVE, ALLOCATABLE :: topswcf_aero(:,:), solswcf_aero(:,:) ! diag + !$OMP THREADPRIVATE(topswcf_aero,solswcf_aero) + REAL, SAVE, ALLOCATABLE :: tausum_aero(:,:,:) + !$OMP THREADPRIVATE(tausum_aero) + REAL, SAVE, ALLOCATABLE :: tau3d_aero(:,:,:,:) + !$OMP THREADPRIVATE(tau3d_aero) + +CONTAINS + +!====================================================================== +SUBROUTINE phys_local_var_init +use dimphy +use infotrac, ONLY : nbtr +USE aero_mod + +IMPLICIT NONE +#include "indicesol.h" + allocate(t_seri(klon,klev),q_seri(klon,klev),ql_seri(klon,klev),qs_seri(klon,klev)) + allocate(u_seri(klon,klev),v_seri(klon,klev)) + + allocate(tr_seri(klon,klev,nbtr)) + allocate(d_t_dyn(klon,klev),d_q_dyn(klon,klev)) + allocate(d_u_dyn(klon,klev),d_v_dyn(klon,klev)) + allocate(d_t_con(klon,klev),d_q_con(klon,klev)) + allocate(d_u_con(klon,klev),d_v_con(klon,klev)) + allocate(d_t_wake(klon,klev),d_q_wake(klon,klev)) + allocate(d_t_lsc(klon,klev),d_q_lsc(klon,klev)) + allocate(d_ql_lsc(klon,klev)) + allocate(d_t_ajsb(klon,klev),d_q_ajsb(klon,klev)) + allocate(d_t_ajs(klon,klev),d_q_ajs(klon,klev)) + allocate(d_u_ajs(klon,klev),d_v_ajs(klon,klev)) + allocate(d_t_eva(klon,klev),d_q_eva(klon,klev)) + allocate(d_t_vdf(klon,klev),d_q_vdf(klon,klev)) + allocate(d_u_vdf(klon,klev),d_v_vdf(klon,klev)) + allocate(d_t_oli(klon,klev),d_t_oro(klon,klev)) + allocate(d_u_oli(klon,klev),d_v_oli(klon,klev)) + allocate(d_u_oro(klon,klev),d_v_oro(klon,klev)) + allocate(d_t_lif(klon,klev),d_t_ec(klon,klev)) + allocate(d_u_lif(klon,klev),d_v_lif(klon,klev)) + allocate(d_ts(klon,klev), d_tr(klon,klev,nbtr)) + allocate(topswad_aero(klon), solswad_aero(klon)) + allocate(topswai_aero(klon), solswai_aero(klon)) + allocate(topswad0_aero(klon), solswad0_aero(klon)) + allocate(topsw_aero(klon,naero_grp), solsw_aero(klon,naero_grp)) + allocate(topsw0_aero(klon,naero_grp), solsw0_aero(klon,naero_grp)) + allocate(topswcf_aero(klon,3), solswcf_aero(klon,3)) + allocate(d_u_hin(klon,klev),d_v_hin(klon,klev),d_t_hin(klon,klev)) + allocate(tausum_aero(klon,nwave,naero_spc)) + allocate(tau3d_aero(klon,klev,nwave,naero_spc)) + +END SUBROUTINE phys_local_var_init + +!====================================================================== +SUBROUTINE phys_local_var_end +use dimphy +IMPLICIT NONE +#include "indicesol.h" + deallocate(t_seri,q_seri,ql_seri,qs_seri) + deallocate(u_seri,v_seri) + + deallocate(tr_seri) + deallocate(d_t_dyn,d_q_dyn) + deallocate(d_u_dyn,d_v_dyn) + deallocate(d_t_con,d_q_con) + deallocate(d_u_con,d_v_con) + deallocate(d_t_wake,d_q_wake) + deallocate(d_t_lsc,d_q_lsc) + deallocate(d_ql_lsc) + deallocate(d_t_ajsb,d_q_ajsb) + deallocate(d_t_ajs,d_q_ajs) + deallocate(d_u_ajs,d_v_ajs) + deallocate(d_t_eva,d_q_eva) + deallocate(d_t_vdf,d_q_vdf) + deallocate(d_u_vdf,d_v_vdf) + deallocate(d_t_oli,d_t_oro) + deallocate(d_u_oli,d_v_oli) + deallocate(d_u_oro,d_v_oro) + deallocate(d_t_lif,d_t_ec) + deallocate(d_u_lif,d_v_lif) + deallocate(d_ts, d_tr) + deallocate(topswad_aero,solswad_aero) + deallocate(topswai_aero,solswai_aero) + deallocate(topswad0_aero,solswad0_aero) + deallocate(topsw_aero,solsw_aero) + deallocate(topsw0_aero,solsw0_aero) + deallocate(topswcf_aero,solswcf_aero) + deallocate(tausum_aero) + deallocate(tau3d_aero) + deallocate(d_u_hin,d_v_hin,d_t_hin) + +END SUBROUTINE phys_local_var_end + +END MODULE phys_local_var_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phys_output_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phys_output_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phys_output_mod.F90 (revision 1280) @@ -0,0 +1,1260 @@ +! +! $Id$ +! +! Abderrahmane 12 2007 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! Ecreture des Sorties du modele dans les fichiers Netcdf : +! histmth.nc : moyennes mensuelles +! histday.nc : moyennes journalieres +! histhf.nc : moyennes toutes les 3 heures +! histins.nc : valeurs instantanees +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MODULE phys_output_mod + + IMPLICIT NONE + + private histdef2d, histdef3d, conf_physoutputs + + + integer, parameter :: nfiles = 5 + logical, dimension(nfiles), save :: clef_files + integer, dimension(nfiles), save :: lev_files + integer, dimension(nfiles), save :: nid_files +!!$OMP THREADPRIVATE(clef_files, lev_files,nid_files) + + integer, dimension(nfiles), private, save :: nhorim, nvertm + integer, dimension(nfiles), private, save :: nvertap, nvertbp, nvertAlt +! integer, dimension(nfiles), private, save :: nvertp0 + real, dimension(nfiles), private, save :: zoutm + real, private, save :: zdtime + CHARACTER(len=20), dimension(nfiles), private, save :: type_ecri +!$OMP THREADPRIVATE(nhorim, nvertm, zoutm,zdtime,type_ecri) + +! integer, save :: nid_hf3d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition pour chaque variable du niveau d ecriture dans chaque fichier +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!/ histmth, histday, histhf, histins /),'!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer, private:: levmin(nfiles) = 1 + integer, private:: levmax(nfiles) + + TYPE ctrl_out + integer,dimension(5) :: flag + character(len=20) :: name + END TYPE ctrl_out + +!!! Comosentes de la coordonnee sigma-hybride +!!! Ap et Bp + type(ctrl_out),save :: o_Ahyb = ctrl_out((/ 1, 1, 1, 1, 1 /), 'Ap') + type(ctrl_out),save :: o_Bhyb = ctrl_out((/ 1, 1, 1, 1, 1 /), 'Bp') + type(ctrl_out),save :: o_Alt = ctrl_out((/ 1, 1, 1, 1, 1 /), 'Alt') + +!!! 1D + type(ctrl_out),save :: o_phis = ctrl_out((/ 1, 1, 10, 1, 1 /), 'phis') + type(ctrl_out),save :: o_aire = ctrl_out((/ 1, 1, 10, 1, 1 /),'aire') + type(ctrl_out),save :: o_contfracATM = ctrl_out((/ 10, 1, 1, 10, 10 /),'contfracATM') + type(ctrl_out),save :: o_contfracOR = ctrl_out((/ 10, 1, 1, 10, 10 /),'contfracOR') + type(ctrl_out),save :: o_aireTER = ctrl_out((/ 10, 10, 1, 10, 10 /),'aireTER') + +!!! 2D + type(ctrl_out),save :: o_flat = ctrl_out((/ 10, 1, 10, 10, 1 /),'flat') + type(ctrl_out),save :: o_slp = ctrl_out((/ 1, 1, 1, 10, 1 /),'slp') + type(ctrl_out),save :: o_tsol = ctrl_out((/ 1, 1, 1, 1, 1 /),'tsol') + type(ctrl_out),save :: o_t2m = ctrl_out((/ 1, 1, 1, 1, 1 /),'t2m') + type(ctrl_out),save :: o_t2m_min = ctrl_out((/ 1, 1, 10, 10, 10 /),'t2m_min') + type(ctrl_out),save :: o_t2m_max = ctrl_out((/ 1, 1, 10, 10, 10 /),'t2m_max') + type(ctrl_out),save,dimension(4) :: o_t2m_srf = (/ ctrl_out((/ 10, 4, 10, 10, 10 /),'t2m_ter'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'t2m_lic'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'t2m_oce'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'t2m_sic') /) + + type(ctrl_out),save :: o_wind10m = ctrl_out((/ 1, 1, 1, 10, 10 /),'wind10m') + type(ctrl_out),save :: o_wind10max = ctrl_out((/ 10, 1, 10, 10, 10 /),'wind10max') + type(ctrl_out),save :: o_sicf = ctrl_out((/ 1, 1, 10, 10, 10 /),'sicf') + type(ctrl_out),save :: o_q2m = ctrl_out((/ 1, 1, 1, 1, 1 /),'q2m') + type(ctrl_out),save :: o_u10m = ctrl_out((/ 1, 1, 1, 1, 1 /),'u10m') + type(ctrl_out),save :: o_v10m = ctrl_out((/ 1, 1, 1, 1, 1 /),'v10m') + type(ctrl_out),save :: o_psol = ctrl_out((/ 1, 1, 1, 1, 1 /),'psol') + type(ctrl_out),save :: o_qsurf = ctrl_out((/ 1, 10, 10, 10, 10 /),'qsurf') + + type(ctrl_out),save,dimension(4) :: o_u10m_srf = (/ ctrl_out((/ 10, 4, 10, 10, 10 /),'u10m_ter'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'u10m_lic'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'u10m_oce'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'u10m_sic') /) + + type(ctrl_out),save,dimension(4) :: o_v10m_srf = (/ ctrl_out((/ 10, 4, 10, 10, 10 /),'v10m_ter'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'v10m_lic'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'v10m_oce'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'v10m_sic') /) + + type(ctrl_out),save :: o_qsol = ctrl_out((/ 1, 10, 10, 1, 1 /),'qsol') + + type(ctrl_out),save :: o_ndayrain = ctrl_out((/ 1, 10, 10, 10, 10 /),'ndayrain') + type(ctrl_out),save :: o_precip = ctrl_out((/ 1, 1, 1, 1, 1 /),'precip') + type(ctrl_out),save :: o_plul = ctrl_out((/ 1, 1, 1, 1, 10 /),'plul') + + type(ctrl_out),save :: o_pluc = ctrl_out((/ 1, 1, 1, 1, 10 /),'pluc') + type(ctrl_out),save :: o_snow = ctrl_out((/ 1, 1, 10, 1, 10 /),'snow') + type(ctrl_out),save :: o_evap = ctrl_out((/ 1, 1, 10, 1, 10 /),'evap') + type(ctrl_out),save :: o_tops = ctrl_out((/ 1, 1, 10, 10, 10 /),'tops') + type(ctrl_out),save :: o_tops0 = ctrl_out((/ 1, 5, 10, 10, 10 /),'tops0') + type(ctrl_out),save :: o_topl = ctrl_out((/ 1, 1, 10, 1, 10 /),'topl') + type(ctrl_out),save :: o_topl0 = ctrl_out((/ 1, 5, 10, 10, 10 /),'topl0') + type(ctrl_out),save :: o_SWupTOA = ctrl_out((/ 1, 4, 10, 10, 10 /),'SWupTOA') + type(ctrl_out),save :: o_SWupTOAclr = ctrl_out((/ 1, 4, 10, 10, 10 /),'SWupTOAclr') + type(ctrl_out),save :: o_SWdnTOA = ctrl_out((/ 1, 4, 10, 10, 10 /),'SWdnTOA') + type(ctrl_out),save :: o_SWdnTOAclr = ctrl_out((/ 1, 4, 10, 10, 10 /),'SWdnTOAclr') + type(ctrl_out),save :: o_SWup200 = ctrl_out((/ 1, 10, 10, 10, 10 /),'SWup200') + type(ctrl_out),save :: o_SWup200clr = ctrl_out((/ 10, 1, 10, 10, 10 /),'SWup200clr') + type(ctrl_out),save :: o_SWdn200 = ctrl_out((/ 1, 10, 10, 10, 10 /),'SWdn200') + type(ctrl_out),save :: o_SWdn200clr = ctrl_out((/ 10, 1, 10, 10, 10 /),'SWdn200clr') + +! arajouter +! type(ctrl_out),save :: o_LWupTOA = ctrl_out((/ 1, 4, 10, 10, 10 /),'LWupTOA') +! type(ctrl_out),save :: o_LWupTOAclr = ctrl_out((/ 1, 4, 10, 10, 10 /),'LWupTOAclr') +! type(ctrl_out),save :: o_LWdnTOA = ctrl_out((/ 1, 4, 10, 10, 10 /),'LWdnTOA') +! type(ctrl_out),save :: o_LWdnTOAclr = ctrl_out((/ 1, 4, 10, 10, 10 /),'LWdnTOAclr') + + type(ctrl_out),save :: o_LWup200 = ctrl_out((/ 1, 10, 10, 10, 10 /),'LWup200') + type(ctrl_out),save :: o_LWup200clr = ctrl_out((/ 1, 10, 10, 10, 10 /),'LWup200clr') + type(ctrl_out),save :: o_LWdn200 = ctrl_out((/ 1, 10, 10, 10, 10 /),'LWdn200') + type(ctrl_out),save :: o_LWdn200clr = ctrl_out((/ 1, 10, 10, 10, 10 /),'LWdn200clr') + type(ctrl_out),save :: o_sols = ctrl_out((/ 1, 1, 10, 1, 10 /),'sols') + type(ctrl_out),save :: o_sols0 = ctrl_out((/ 1, 5, 10, 10, 10 /),'sols0') + type(ctrl_out),save :: o_soll = ctrl_out((/ 1, 1, 10, 1, 10 /),'soll') + type(ctrl_out),save :: o_soll0 = ctrl_out((/ 1, 5, 10, 10, 10 /),'soll0') + type(ctrl_out),save :: o_radsol = ctrl_out((/ 1, 1, 10, 10, 10 /),'radsol') + type(ctrl_out),save :: o_SWupSFC = ctrl_out((/ 1, 4, 10, 10, 10 /),'SWupSFC') + type(ctrl_out),save :: o_SWupSFCclr = ctrl_out((/ 1, 4, 10, 10, 10 /),'SWupSFCclr') + type(ctrl_out),save :: o_SWdnSFC = ctrl_out((/ 1, 1, 10, 10, 10 /),'SWdnSFC') + type(ctrl_out),save :: o_SWdnSFCclr = ctrl_out((/ 1, 4, 10, 10, 10 /),'SWdnSFCclr') + type(ctrl_out),save :: o_LWupSFC = ctrl_out((/ 1, 4, 10, 10, 10 /),'LWupSFC') + type(ctrl_out),save :: o_LWupSFCclr = ctrl_out((/ 1, 4, 10, 10, 10 /),'LWupSFCclr') + type(ctrl_out),save :: o_LWdnSFC = ctrl_out((/ 1, 4, 10, 10, 10 /),'LWdnSFC') + type(ctrl_out),save :: o_LWdnSFCclr = ctrl_out((/ 1, 4, 10, 10, 10 /),'LWdnSFCclr') + type(ctrl_out),save :: o_bils = ctrl_out((/ 1, 2, 10, 1, 10 /),'bils') + type(ctrl_out),save :: o_sens = ctrl_out((/ 1, 1, 10, 1, 1 /),'sens') + type(ctrl_out),save :: o_fder = ctrl_out((/ 1, 2, 10, 1, 10 /),'fder') + type(ctrl_out),save :: o_ffonte = ctrl_out((/ 1, 10, 10, 10, 10 /),'ffonte') + type(ctrl_out),save :: o_fqcalving = ctrl_out((/ 1, 10, 10, 10, 10 /),'fqcalving') + type(ctrl_out),save :: o_fqfonte = ctrl_out((/ 1, 10, 10, 10, 10 /),'fqfonte') + + type(ctrl_out),save,dimension(4) :: o_taux_srf = (/ ctrl_out((/ 1, 4, 10, 1, 10 /),'taux_ter'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'taux_lic'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'taux_oce'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'taux_sic') /) + + type(ctrl_out),save,dimension(4) :: o_tauy_srf = (/ ctrl_out((/ 1, 4, 10, 1, 10 /),'tauy_ter'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'tauy_lic'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'tauy_oce'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'tauy_sic') /) + + + type(ctrl_out),save,dimension(4) :: o_pourc_srf = (/ ctrl_out((/ 1, 4, 10, 1, 10 /),'pourc_ter'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'pourc_lic'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'pourc_oce'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'pourc_sic') /) + + type(ctrl_out),save,dimension(4) :: o_fract_srf = (/ ctrl_out((/ 1, 4, 10, 1, 10 /),'fract_ter'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'fract_lic'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'fract_oce'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'fract_sic') /) + + type(ctrl_out),save,dimension(4) :: o_tsol_srf = (/ ctrl_out((/ 1, 4, 10, 1, 10 /),'tsol_ter'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'tsol_lic'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'tsol_oce'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'tsol_sic') /) + + type(ctrl_out),save,dimension(4) :: o_sens_srf = (/ ctrl_out((/ 1, 4, 10, 1, 10 /),'sens_ter'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'sens_lic'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'sens_oce'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'sens_sic') /) + + type(ctrl_out),save,dimension(4) :: o_lat_srf = (/ ctrl_out((/ 1, 4, 10, 1, 10 /),'lat_ter'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'lat_lic'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'lat_oce'), & + ctrl_out((/ 1, 4, 10, 1, 10 /),'lat_sic') /) + + type(ctrl_out),save,dimension(4) :: o_flw_srf = (/ ctrl_out((/ 1, 10, 10, 10, 10 /),'flw_ter'), & + ctrl_out((/ 1, 10, 10, 10, 10 /),'flw_lic'), & + ctrl_out((/ 1, 10, 10, 10, 10 /),'flw_oce'), & + ctrl_out((/ 1, 10, 10, 10, 10 /),'flw_sic') /) + + type(ctrl_out),save,dimension(4) :: o_fsw_srf = (/ ctrl_out((/ 1, 10, 10, 10, 10 /),'fsw_ter'), & + ctrl_out((/ 1, 10, 10, 10, 10 /),'fsw_lic'), & + ctrl_out((/ 1, 10, 10, 10, 10 /),'fsw_oce'), & + ctrl_out((/ 1, 10, 10, 10, 10 /),'fsw_sic') /) + + type(ctrl_out),save,dimension(4) :: o_wbils_srf = (/ ctrl_out((/ 1, 10, 10, 10, 10 /),'wbils_ter'), & + ctrl_out((/ 1, 10, 10, 10, 10 /),'wbils_lic'), & + ctrl_out((/ 1, 10, 10, 10, 10 /),'wbils_oce'), & + ctrl_out((/ 1, 10, 10, 10, 10 /),'wbils_sic') /) + + type(ctrl_out),save,dimension(4) :: o_wbilo_srf = (/ ctrl_out((/ 1, 10, 10, 10, 10 /),'wbilo_ter'), & + ctrl_out((/ 1, 10, 10, 10, 10 /),'wbilo_lic'), & + ctrl_out((/ 1, 10, 10, 10, 10 /),'wbilo_oce'), & + ctrl_out((/ 1, 10, 10, 10, 10 /),'wbilo_sic') /) + + + type(ctrl_out),save :: o_cdrm = ctrl_out((/ 1, 10, 10, 1, 10 /),'cdrm') + type(ctrl_out),save :: o_cdrh = ctrl_out((/ 1, 10, 10, 1, 10 /),'cdrh') + type(ctrl_out),save :: o_cldl = ctrl_out((/ 1, 1, 10, 10, 10 /),'cldl') + type(ctrl_out),save :: o_cldm = ctrl_out((/ 1, 1, 10, 10, 10 /),'cldm') + type(ctrl_out),save :: o_cldh = ctrl_out((/ 1, 1, 10, 10, 10 /),'cldh') + type(ctrl_out),save :: o_cldt = ctrl_out((/ 1, 1, 2, 10, 10 /),'cldt') + type(ctrl_out),save :: o_cldq = ctrl_out((/ 1, 1, 10, 10, 10 /),'cldq') + type(ctrl_out),save :: o_lwp = ctrl_out((/ 1, 5, 10, 10, 10 /),'lwp') + type(ctrl_out),save :: o_iwp = ctrl_out((/ 1, 5, 10, 10, 10 /),'iwp') + type(ctrl_out),save :: o_ue = ctrl_out((/ 1, 10, 10, 10, 10 /),'ue') + type(ctrl_out),save :: o_ve = ctrl_out((/ 1, 10, 10, 10, 10 /),'ve') + type(ctrl_out),save :: o_uq = ctrl_out((/ 1, 10, 10, 10, 10 /),'uq') + type(ctrl_out),save :: o_vq = ctrl_out((/ 1, 10, 10, 10, 10 /),'vq') + + type(ctrl_out),save :: o_cape = ctrl_out((/ 1, 10, 10, 10, 10 /),'cape') + type(ctrl_out),save :: o_pbase = ctrl_out((/ 1, 10, 10, 10, 10 /),'pbase') + type(ctrl_out),save :: o_ptop = ctrl_out((/ 1, 4, 10, 10, 10 /),'ptop') + type(ctrl_out),save :: o_fbase = ctrl_out((/ 1, 10, 10, 10, 10 /),'fbase') + type(ctrl_out),save :: o_prw = ctrl_out((/ 1, 1, 10, 10, 10 /),'prw') + + type(ctrl_out),save :: o_s_pblh = ctrl_out((/ 1, 10, 10, 1, 1 /),'s_pblh') + type(ctrl_out),save :: o_s_pblt = ctrl_out((/ 1, 10, 10, 1, 1 /),'s_pblt') + type(ctrl_out),save :: o_s_lcl = ctrl_out((/ 1, 10, 10, 1, 10 /),'s_lcl') + type(ctrl_out),save :: o_s_capCL = ctrl_out((/ 1, 10, 10, 1, 10 /),'s_capCL') + type(ctrl_out),save :: o_s_oliqCL = ctrl_out((/ 1, 10, 10, 1, 10 /),'s_oliqCL') + type(ctrl_out),save :: o_s_cteiCL = ctrl_out((/ 1, 10, 10, 1, 1 /),'s_cteiCL') + type(ctrl_out),save :: o_s_therm = ctrl_out((/ 1, 10, 10, 1, 1 /),'s_therm') + type(ctrl_out),save :: o_s_trmb1 = ctrl_out((/ 1, 10, 10, 1, 10 /),'s_trmb1') + type(ctrl_out),save :: o_s_trmb2 = ctrl_out((/ 1, 10, 10, 1, 10 /),'s_trmb2') + type(ctrl_out),save :: o_s_trmb3 = ctrl_out((/ 1, 10, 10, 1, 10 /),'s_trmb3') + + type(ctrl_out),save :: o_slab_bils = ctrl_out((/ 1, 1, 10, 10, 10 /),'slab_bils_oce') + + type(ctrl_out),save :: o_ale_bl = ctrl_out((/ 1, 1, 1, 1, 10 /),'ale_bl') + type(ctrl_out),save :: o_alp_bl = ctrl_out((/ 1, 1, 1, 1, 10 /),'alp_bl') + type(ctrl_out),save :: o_ale_wk = ctrl_out((/ 1, 1, 1, 1, 10 /),'ale_wk') + type(ctrl_out),save :: o_alp_wk = ctrl_out((/ 1, 1, 1, 1, 10 /),'alp_wk') + + type(ctrl_out),save :: o_ale = ctrl_out((/ 1, 1, 1, 1, 10 /),'ale') + type(ctrl_out),save :: o_alp = ctrl_out((/ 1, 1, 1, 1, 10 /),'alp') + type(ctrl_out),save :: o_cin = ctrl_out((/ 1, 1, 1, 1, 10 /),'cin') + type(ctrl_out),save :: o_wape = ctrl_out((/ 1, 1, 1, 1, 10 /),'wape') + + +! Champs interpolles sur des niveaux de pression ??? a faire correctement + + type(ctrl_out),save,dimension(6) :: o_uSTDlevs = (/ ctrl_out((/ 1, 1, 3, 10, 10 /),'u850'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'u700'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'u500'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'u200'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'u50'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'u10') /) + + + type(ctrl_out),save,dimension(6) :: o_vSTDlevs = (/ ctrl_out((/ 1, 1, 3, 10, 10 /),'v850'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'v700'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'v500'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'v200'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'v50'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'v10') /) + + type(ctrl_out),save,dimension(6) :: o_wSTDlevs = (/ ctrl_out((/ 1, 1, 3, 10, 10 /),'w850'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'w700'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'w500'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'w200'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'w50'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'w10') /) + + type(ctrl_out),save,dimension(6) :: o_tSTDlevs = (/ ctrl_out((/ 1, 1, 3, 10, 10 /),'t850'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'t700'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'t500'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'t200'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'t50'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'t10') /) + + type(ctrl_out),save,dimension(6) :: o_qSTDlevs = (/ ctrl_out((/ 1, 1, 3, 10, 10 /),'q850'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'q700'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'q500'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'q200'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'q50'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'q10') /) + + type(ctrl_out),save,dimension(6) :: o_phiSTDlevs = (/ ctrl_out((/ 1, 1, 3, 10, 10 /),'phi850'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'phi700'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'phi500'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'phi200'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'phi50'), & + ctrl_out((/ 1, 1, 3, 10, 10 /),'phi10') /) + + + type(ctrl_out),save :: o_t_oce_sic = ctrl_out((/ 1, 10, 10, 10, 10 /),'t_oce_sic') + + type(ctrl_out),save :: o_weakinv = ctrl_out((/ 10, 1, 10, 10, 10 /),'weakinv') + type(ctrl_out),save :: o_dthmin = ctrl_out((/ 10, 1, 10, 10, 10 /),'dthmin') + type(ctrl_out),save,dimension(4) :: o_u10_srf = (/ ctrl_out((/ 10, 4, 10, 10, 10 /),'u10_ter'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'u10_lic'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'u10_oce'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'u10_sic') /) + + type(ctrl_out),save,dimension(4) :: o_v10_srf = (/ ctrl_out((/ 10, 4, 10, 10, 10 /),'v10_ter'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'v10_lic'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'v10_oce'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'v10_sic') /) + + type(ctrl_out),save :: o_cldtau = ctrl_out((/ 10, 5, 10, 10, 10 /),'cldtau') + type(ctrl_out),save :: o_cldemi = ctrl_out((/ 10, 5, 10, 10, 10 /),'cldemi') + type(ctrl_out),save :: o_rh2m = ctrl_out((/ 10, 5, 10, 10, 10 /),'rh2m') + type(ctrl_out),save :: o_qsat2m = ctrl_out((/ 10, 5, 10, 10, 10 /),'qsat2m') + type(ctrl_out),save :: o_tpot = ctrl_out((/ 10, 5, 10, 10, 10 /),'tpot') + type(ctrl_out),save :: o_tpote = ctrl_out((/ 10, 5, 10, 10, 10 /),'tpote') + type(ctrl_out),save :: o_tke = ctrl_out((/ 4, 10, 10, 10, 10 /),'tke ') + type(ctrl_out),save :: o_tke_max = ctrl_out((/ 4, 10, 10, 10, 10 /),'tke_max') + + type(ctrl_out),save,dimension(4) :: o_tke_srf = (/ ctrl_out((/ 10, 4, 10, 10, 10 /),'tke_ter'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'tke_lic'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'tke_oce'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'tke_sic') /) + + type(ctrl_out),save,dimension(4) :: o_tke_max_srf = (/ ctrl_out((/ 10, 4, 10, 10, 10 /),'tke_max_ter'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'tke_max_lic'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'tke_max_oce'), & + ctrl_out((/ 10, 4, 10, 10, 10 /),'tke_max_sic') /) + + type(ctrl_out),save :: o_kz = ctrl_out((/ 4, 10, 10, 10, 10 /),'kz') + type(ctrl_out),save :: o_kz_max = ctrl_out((/ 4, 10, 10, 10, 10 /),'kz_max') + type(ctrl_out),save :: o_SWnetOR = ctrl_out((/ 10, 10, 2, 10, 10 /),'SWnetOR') + type(ctrl_out),save :: o_SWdownOR = ctrl_out((/ 10, 10, 2, 10, 10 /),'SWdownOR') + type(ctrl_out),save :: o_LWdownOR = ctrl_out((/ 10, 10, 2, 10, 10 /),'LWdownOR') + + type(ctrl_out),save :: o_snowl = ctrl_out((/ 10, 1, 10, 10, 10 /),'snowl') + type(ctrl_out),save :: o_cape_max = ctrl_out((/ 10, 1, 10, 10, 10 /),'cape_max') + type(ctrl_out),save :: o_solldown = ctrl_out((/ 10, 1, 10, 1, 10 /),'solldown') + + type(ctrl_out),save :: o_dtsvdfo = ctrl_out((/ 10, 10, 10, 1, 10 /),'dtsvdfo') + type(ctrl_out),save :: o_dtsvdft = ctrl_out((/ 10, 10, 10, 1, 10 /),'dtsvdft') + type(ctrl_out),save :: o_dtsvdfg = ctrl_out((/ 10, 10, 10, 1, 10 /),'dtsvdfg') + type(ctrl_out),save :: o_dtsvdfi = ctrl_out((/ 10, 10, 10, 1, 10 /),'dtsvdfi') + type(ctrl_out),save :: o_rugs = ctrl_out((/ 10, 10, 10, 1, 1 /),'rugs') + + type(ctrl_out),save :: o_topswad = ctrl_out((/ 4, 10, 10, 10, 10 /),'topswad') + type(ctrl_out),save :: o_topswai = ctrl_out((/ 4, 10, 10, 10, 10 /),'topswai') + type(ctrl_out),save :: o_solswad = ctrl_out((/ 4, 10, 10, 10, 10 /),'solswad') + type(ctrl_out),save :: o_solswai = ctrl_out((/ 4, 10, 10, 10, 10 /),'solswai') + + type(ctrl_out),save,dimension(10) :: o_tausumaero = (/ ctrl_out((/ 4, 10, 10, 10, 10 /),'OD550_ASBCM'), & + ctrl_out((/ 4, 10, 10, 10, 10 /),'OD550_ASPOMM'), & + ctrl_out((/ 4, 10, 10, 10, 10 /),'OD550_ASSO4M'), & + ctrl_out((/ 4, 10, 10, 10, 10 /),'OD550_CSSO4M'), & + ctrl_out((/ 4, 10, 10, 10, 10 /),'OD550_SSSSM'), & + ctrl_out((/ 4, 10, 10, 10, 10 /),'OD550_ASSSM'), & + ctrl_out((/ 4, 10, 10, 10, 10 /),'OD550_CSSSM'), & + ctrl_out((/ 4, 10, 10, 10, 10 /),'OD550_CIDUSTM'), & + ctrl_out((/ 4, 10, 10, 10, 10 /),'OD550_AIBCM'), & + ctrl_out((/ 4, 10, 10, 10, 10 /),'OD550_AIPOMM') /) + + type(ctrl_out),save :: o_swtoaas_nat = ctrl_out((/ 4, 10, 10, 10, 10 /),'swtoaas_nat') + type(ctrl_out),save :: o_swsrfas_nat = ctrl_out((/ 4, 10, 10, 10, 10 /),'swsrfas_nat') + type(ctrl_out),save :: o_swtoacs_nat = ctrl_out((/ 4, 10, 10, 10, 10 /),'swtoacs_nat') + type(ctrl_out),save :: o_swsrfcs_nat = ctrl_out((/ 4, 10, 10, 10, 10 /),'swsrfcs_nat') + + type(ctrl_out),save :: o_swtoaas_ant = ctrl_out((/ 4, 10, 10, 10, 10 /),'swtoaas_ant') + type(ctrl_out),save :: o_swsrfas_ant = ctrl_out((/ 4, 10, 10, 10, 10 /),'swsrfas_ant') + type(ctrl_out),save :: o_swtoacs_ant = ctrl_out((/ 4, 10, 10, 10, 10 /),'swtoacs_ant') + type(ctrl_out),save :: o_swsrfcs_ant = ctrl_out((/ 4, 10, 10, 10, 10 /),'swsrfcs_ant') + + type(ctrl_out),save :: o_swtoacf_nat = ctrl_out((/ 4, 10, 10, 10, 10 /),'swtoacf_nat') + type(ctrl_out),save :: o_swsrfcf_nat = ctrl_out((/ 4, 10, 10, 10, 10 /),'swsrfcf_nat') + type(ctrl_out),save :: o_swtoacf_ant = ctrl_out((/ 4, 10, 10, 10, 10 /),'swtoacf_ant') + type(ctrl_out),save :: o_swsrfcf_ant = ctrl_out((/ 4, 10, 10, 10, 10 /),'swsrfcf_ant') + type(ctrl_out),save :: o_swtoacf_zero = ctrl_out((/ 4, 10, 10, 10, 10 /),'swtoacf_zero') + type(ctrl_out),save :: o_swsrfcf_zero = ctrl_out((/ 4, 10, 10, 10, 10 /),'swsrfcf_zero') + + +!!!!!!!!!!!!!!!!!!!!!! 3D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + type(ctrl_out),save :: o_lwcon = ctrl_out((/ 2, 5, 10, 10, 1 /),'lwcon') + type(ctrl_out),save :: o_iwcon = ctrl_out((/ 2, 5, 10, 10, 10 /),'iwcon') + type(ctrl_out),save :: o_temp = ctrl_out((/ 2, 3, 4, 1, 1 /),'temp') + type(ctrl_out),save :: o_theta = ctrl_out((/ 2, 3, 4, 1, 1 /),'theta') + type(ctrl_out),save :: o_ovap = ctrl_out((/ 2, 3, 4, 1, 1 /),'ovap') + type(ctrl_out),save :: o_ovapinit = ctrl_out((/ 2, 3, 4, 1, 1 /),'ovapinit') + type(ctrl_out),save :: o_wvapp = ctrl_out((/ 2, 10, 10, 10, 10 /),'wvapp') + type(ctrl_out),save :: o_geop = ctrl_out((/ 2, 3, 10, 1, 1 /),'geop') + type(ctrl_out),save :: o_vitu = ctrl_out((/ 2, 3, 4, 1, 1 /),'vitu') + type(ctrl_out),save :: o_vitv = ctrl_out((/ 2, 3, 4, 1, 1 /),'vitv') + type(ctrl_out),save :: o_vitw = ctrl_out((/ 2, 3, 10, 10, 1 /),'vitw') + type(ctrl_out),save :: o_pres = ctrl_out((/ 2, 3, 10, 1, 1 /),'pres') + type(ctrl_out),save :: o_rneb = ctrl_out((/ 2, 5, 10, 10, 1 /),'rneb') + type(ctrl_out),save :: o_rnebcon = ctrl_out((/ 2, 5, 10, 10, 1 /),'rnebcon') + type(ctrl_out),save :: o_rhum = ctrl_out((/ 2, 10, 10, 10, 10 /),'rhum') + type(ctrl_out),save :: o_ozone = ctrl_out((/ 2, 10, 10, 10, 10 /),'ozone') + type(ctrl_out),save :: o_ozone_light = ctrl_out((/ 2, 10, 10, 10, 10 /),'ozone_daylight') + type(ctrl_out),save :: o_upwd = ctrl_out((/ 2, 10, 10, 10, 10 /),'upwd') + type(ctrl_out),save :: o_dtphy = ctrl_out((/ 2, 10, 10, 10, 1 /),'dtphy') + type(ctrl_out),save :: o_dqphy = ctrl_out((/ 2, 10, 10, 10, 1 /),'dqphy') + type(ctrl_out),save :: o_pr_con_l = ctrl_out((/ 2, 10, 10, 10, 10 /),'pr_con_l') + type(ctrl_out),save :: o_pr_con_i = ctrl_out((/ 2, 10, 10, 10, 10 /),'pr_con_i') + type(ctrl_out),save :: o_pr_lsc_l = ctrl_out((/ 2, 10, 10, 10, 10 /),'pr_lsc_l') + type(ctrl_out),save :: o_pr_lsc_i = ctrl_out((/ 2, 10, 10, 10, 10 /),'pr_lsc_i') +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + type(ctrl_out),save,dimension(4) :: o_albe_srf = (/ ctrl_out((/ 3, 4, 10, 1, 10 /),'albe_ter'), & + ctrl_out((/ 3, 4, 10, 1, 10 /),'albe_lic'), & + ctrl_out((/ 3, 4, 10, 1, 10 /),'albe_oce'), & + ctrl_out((/ 3, 4, 10, 1, 10 /),'albe_sic') /) + + type(ctrl_out),save,dimension(4) :: o_ages_srf = (/ ctrl_out((/ 3, 10, 10, 10, 10 /),'ages_ter'), & + ctrl_out((/ 3, 10, 10, 10, 10 /),'ages_lic'), & + ctrl_out((/ 3, 10, 10, 10, 10 /),'ages_oce'), & + ctrl_out((/ 3, 10, 10, 10, 10 /),'ages_sic') /) + + type(ctrl_out),save,dimension(4) :: o_rugs_srf = (/ ctrl_out((/ 3, 4, 10, 1, 10 /),'rugs_ter'), & + ctrl_out((/ 3, 4, 10, 1, 10 /),'rugs_lic'), & + ctrl_out((/ 3, 4, 10, 1, 10 /),'rugs_oce'), & + ctrl_out((/ 3, 4, 10, 1, 10 /),'rugs_sic') /) + + type(ctrl_out),save :: o_albs = ctrl_out((/ 3, 10, 10, 1, 10 /),'albs') + type(ctrl_out),save :: o_albslw = ctrl_out((/ 3, 10, 10, 1, 10 /),'albslw') + + type(ctrl_out),save :: o_clwcon = ctrl_out((/ 4, 10, 10, 10, 10 /),'clwcon') + type(ctrl_out),save :: o_Ma = ctrl_out((/ 4, 10, 10, 10, 10 /),'Ma') + type(ctrl_out),save :: o_dnwd = ctrl_out((/ 4, 10, 10, 10, 10 /),'dnwd') + type(ctrl_out),save :: o_dnwd0 = ctrl_out((/ 4, 10, 10, 10, 10 /),'dnwd0') + type(ctrl_out),save :: o_dtdyn = ctrl_out((/ 4, 10, 10, 10, 1 /),'dtdyn') + type(ctrl_out),save :: o_dqdyn = ctrl_out((/ 4, 10, 10, 10, 1 /),'dqdyn') + type(ctrl_out),save :: o_dudyn = ctrl_out((/ 4, 10, 10, 10, 1 /),'dudyn') !AXC + type(ctrl_out),save :: o_dvdyn = ctrl_out((/ 4, 10, 10, 10, 1 /),'dvdyn') !AXC + type(ctrl_out),save :: o_dtcon = ctrl_out((/ 4, 5, 10, 10, 10 /),'dtcon') + type(ctrl_out),save :: o_ducon = ctrl_out((/ 4, 10, 10, 10, 10 /),'ducon') + type(ctrl_out),save :: o_dqcon = ctrl_out((/ 4, 5, 10, 10, 10 /),'dqcon') + type(ctrl_out),save :: o_dtwak = ctrl_out((/ 4, 5, 10, 10, 10 /),'dtwak') + type(ctrl_out),save :: o_dqwak = ctrl_out((/ 4, 5, 10, 10, 10 /),'dqwak') + type(ctrl_out),save :: o_wake_h = ctrl_out((/ 4, 5, 10, 10, 10 /),'wake_h') + type(ctrl_out),save :: o_wake_s = ctrl_out((/ 4, 5, 10, 10, 10 /),'wake_s') + type(ctrl_out),save :: o_wake_deltat = ctrl_out((/ 4, 5, 10, 10, 10 /),'wake_deltat') + type(ctrl_out),save :: o_wake_deltaq = ctrl_out((/ 4, 5, 10, 10, 10 /),'wake_deltaq') + type(ctrl_out),save :: o_wake_omg = ctrl_out((/ 4, 5, 10, 10, 10 /),'wake_omg') + type(ctrl_out),save :: o_Vprecip = ctrl_out((/ 10, 10, 10, 10, 10 /),'Vprecip') + type(ctrl_out),save :: o_ftd = ctrl_out((/ 4, 5, 10, 10, 10 /),'ftd') + type(ctrl_out),save :: o_fqd = ctrl_out((/ 4, 5, 10, 10, 10 /),'fqd') + type(ctrl_out),save :: o_dtlsc = ctrl_out((/ 4, 10, 10, 10, 10 /),'dtlsc') + type(ctrl_out),save :: o_dtlschr = ctrl_out((/ 4, 10, 10, 10, 10 /),'dtlschr') + type(ctrl_out),save :: o_dqlsc = ctrl_out((/ 4, 10, 10, 10, 10 /),'dqlsc') + type(ctrl_out),save :: o_dtvdf = ctrl_out((/ 4, 10, 10, 1, 10 /),'dtvdf') + type(ctrl_out),save :: o_dqvdf = ctrl_out((/ 4, 10, 10, 1, 10 /),'dqvdf') + type(ctrl_out),save :: o_dteva = ctrl_out((/ 4, 10, 10, 10, 10 /),'dteva') + type(ctrl_out),save :: o_dqeva = ctrl_out((/ 4, 10, 10, 10, 10 /),'dqeva') + type(ctrl_out),save :: o_ptconv = ctrl_out((/ 4, 10, 10, 10, 10 /),'ptconv') + type(ctrl_out),save :: o_ratqs = ctrl_out((/ 4, 10, 10, 10, 10 /),'ratqs') + type(ctrl_out),save :: o_dtthe = ctrl_out((/ 4, 10, 10, 10, 10 /),'dtthe') + type(ctrl_out),save :: o_f_th = ctrl_out((/ 4, 10, 10, 10, 10 /),'f_th') + type(ctrl_out),save :: o_e_th = ctrl_out((/ 4, 10, 10, 10, 10 /),'e_th') + type(ctrl_out),save :: o_w_th = ctrl_out((/ 4, 10, 10, 10, 10 /),'w_th') + type(ctrl_out),save :: o_lambda_th = ctrl_out((/ 10, 10, 10, 10, 10 /),'lambda_th') + type(ctrl_out),save :: o_q_th = ctrl_out((/ 4, 10, 10, 10, 10 /),'q_th') + type(ctrl_out),save :: o_a_th = ctrl_out((/ 4, 10, 10, 10, 10 /),'a_th') + type(ctrl_out),save :: o_d_th = ctrl_out((/ 4, 10, 10, 10, 10 /),'d_th') + type(ctrl_out),save :: o_f0_th = ctrl_out((/ 4, 10, 10, 10, 10 /),'f0_th') + type(ctrl_out),save :: o_zmax_th = ctrl_out((/ 4, 10, 10, 10, 10 /),'zmax_th') + type(ctrl_out),save :: o_dqthe = ctrl_out((/ 4, 10, 10, 10, 1 /),'dqthe') + type(ctrl_out),save :: o_dtajs = ctrl_out((/ 4, 10, 10, 10, 10 /),'dtajs') + type(ctrl_out),save :: o_dqajs = ctrl_out((/ 4, 10, 10, 10, 10 /),'dqajs') + type(ctrl_out),save :: o_dtswr = ctrl_out((/ 4, 10, 10, 10, 1 /),'dtswr') + type(ctrl_out),save :: o_dtsw0 = ctrl_out((/ 4, 10, 10, 10, 10 /),'dtsw0') + type(ctrl_out),save :: o_dtlwr = ctrl_out((/ 4, 10, 10, 10, 1 /),'dtlwr') + type(ctrl_out),save :: o_dtlw0 = ctrl_out((/ 4, 10, 10, 10, 10 /),'dtlw0') + type(ctrl_out),save :: o_dtec = ctrl_out((/ 4, 10, 10, 10, 10 /),'dtec') + type(ctrl_out),save :: o_duvdf = ctrl_out((/ 4, 10, 10, 10, 10 /),'duvdf') + type(ctrl_out),save :: o_dvvdf = ctrl_out((/ 4, 10, 10, 10, 10 /),'dvvdf') + type(ctrl_out),save :: o_duoro = ctrl_out((/ 4, 10, 10, 10, 10 /),'duoro') + type(ctrl_out),save :: o_dvoro = ctrl_out((/ 4, 10, 10, 10, 10 /),'dvoro') + type(ctrl_out),save :: o_dulif = ctrl_out((/ 4, 10, 10, 10, 10 /),'dulif') + type(ctrl_out),save :: o_dvlif = ctrl_out((/ 4, 10, 10, 10, 10 /),'dvlif') + +! Attention a refaire correctement + type(ctrl_out),save,dimension(2) :: o_trac = (/ ctrl_out((/ 4, 10, 10, 10, 10 /),'trac01'), & + ctrl_out((/ 4, 10, 10, 10, 10 /),'trac02') /) + CONTAINS + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!! Ouverture des fichier et definition des variable de sortie !!!!!!!! +!! histbeg, histvert et histdef +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE phys_output_open(jjmp1,nlevSTD,clevSTD,nbteta, & + ctetaSTD,dtime, ok_veget, & + type_ocean, iflag_pbl,ok_mensuel,ok_journe, & + ok_hf,ok_instan,ok_LES,ok_ade,ok_aie, read_climoz, & + new_aod, aerosol_couple) + + + USE iophy + USE dimphy + USE infotrac + USE ioipsl + USE mod_phys_lmdz_para + USE aero_mod, only : naero_spc,name_aero + + IMPLICIT NONE + include "dimensions.h" + include "temps.h" + include "indicesol.h" + include "clesphys.h" + include "thermcell.h" + include "comvert.h" + + integer :: jjmp1 + integer :: nbteta, nlevSTD, radpas + logical :: ok_mensuel, ok_journe, ok_hf, ok_instan + logical :: ok_LES,ok_ade,ok_aie + logical :: new_aod, aerosol_couple + integer, intent(in):: read_climoz ! read ozone climatology + ! Allowed values are 0, 1 and 2 + ! 0: do not read an ozone climatology + ! 1: read a single ozone climatology that will be used day and night + ! 2: read two ozone climatologies, the average day and night + ! climatology and the daylight climatology + + real :: dtime + integer :: idayref + real :: zjulian + real, dimension(klev) :: Ahyb, Bhyb, Alt + character(len=4), dimension(nlevSTD) :: clevSTD + integer :: nsrf, k, iq, iiq, iff, i, j, ilev + integer :: naero + logical :: ok_veget + integer :: iflag_pbl + CHARACTER(len=4) :: bb2 + CHARACTER(len=2) :: bb3 + character(len=6) :: type_ocean + CHARACTER(len=3) :: ctetaSTD(nbteta) + real, dimension(nfiles) :: ecrit_files + CHARACTER(len=20), dimension(nfiles) :: phys_out_filenames + INTEGER, dimension(iim*jjmp1) :: ndex2d + INTEGER, dimension(iim*jjmp1*klev) :: ndex3d + integer :: imin_ins, imax_ins + integer :: jmin_ins, jmax_ins + integer, dimension(nfiles) :: phys_out_levmin, phys_out_levmax + integer, dimension(nfiles) :: phys_out_filelevels + CHARACTER(len=20), dimension(nfiles) :: type_ecri_files, phys_out_filetypes + character(len=20), dimension(nfiles) :: chtimestep = (/ 'DefFreq', 'DefFreq','DefFreq', 'DefFreq', 'DefFreq' /) + logical, dimension(nfiles) :: phys_out_filekeys + +!!!!!!!!!! stockage dans une region limitee pour chaque fichier !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! entre [phys_out_lonmin,phys_out_lonmax] et [phys_out_latmin,phys_out_latmax] + + logical, dimension(nfiles), save :: phys_out_regfkey = (/ .false., .false., .false., .false., .false. /) + real, dimension(nfiles), save :: phys_out_lonmin = (/ -180., -180., -180., -180., -180. /) + real, dimension(nfiles), save :: phys_out_lonmax = (/ 180., 180., 180., 180., 180. /) + real, dimension(nfiles), save :: phys_out_latmin = (/ -90., -90., -90., -90., -90. /) + real, dimension(nfiles), save :: phys_out_latmax = (/ 90., 90., 90., 90., 90. /) + + + +! + print*,'Debut phys_output_mod.F90' +! Initialisations (Valeurs par defaut + levmax = (/ klev, klev, klev, klev, klev /) + + phys_out_filenames(1) = 'histmth' + phys_out_filenames(2) = 'histday' + phys_out_filenames(3) = 'histhf' + phys_out_filenames(4) = 'histins' + phys_out_filenames(5) = 'histLES' + + type_ecri(1) = 'ave(X)' + type_ecri(2) = 'ave(X)' + type_ecri(3) = 'ave(X)' + type_ecri(4) = 'inst(X)' + type_ecri(5) = 'inst(X)' + + clef_files(1) = ok_mensuel + clef_files(2) = ok_journe + clef_files(3) = ok_hf + clef_files(4) = ok_instan + clef_files(5) = ok_LES + + lev_files(1) = lev_histmth + lev_files(2) = lev_histday + lev_files(3) = lev_histhf + lev_files(4) = lev_histins + lev_files(5) = lev_histLES + + + ecrit_files(1) = ecrit_mth + ecrit_files(2) = ecrit_day + ecrit_files(3) = ecrit_hf + ecrit_files(4) = ecrit_ins + ecrit_files(5) = ecrit_LES + +!! Lectures des parametres de sorties dans physiq.def + + call getin('phys_out_regfkey',phys_out_regfkey) + call getin('phys_out_lonmin',phys_out_lonmin) + call getin('phys_out_lonmax',phys_out_lonmax) + call getin('phys_out_latmin',phys_out_latmin) + call getin('phys_out_latmax',phys_out_latmax) + phys_out_levmin(:)=levmin(:) + call getin('phys_out_levmin',levmin) + phys_out_levmax(:)=levmax(:) + call getin('phys_out_levmax',levmax) + call getin('phys_out_filenames',phys_out_filenames) + phys_out_filekeys(:)=clef_files(:) + call getin('phys_out_filekeys',clef_files) + phys_out_filelevels(:)=lev_files(:) + call getin('phys_out_filelevels',lev_files) + call getin('phys_out_filetimesteps',chtimestep) + phys_out_filetypes(:)=type_ecri(:) + call getin('phys_out_filetypes',type_ecri) + + type_ecri_files(:)=type_ecri(:) + + print*,'phys_out_lonmin=',phys_out_lonmin + print*,'phys_out_lonmax=',phys_out_lonmax + print*,'phys_out_latmin=',phys_out_latmin + print*,'phys_out_latmax=',phys_out_latmax + print*,'phys_out_filenames=',phys_out_filenames + print*,'phys_out_filetypes=',type_ecri + print*,'phys_out_filekeys=',clef_files + print*,'phys_out_filelevels=',lev_files + +!!!!!!!!!!!!!!!!!!!!!!! Boucle sur les fichiers !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Appel de histbeg et histvert pour creer le fichier et les niveaux verticaux !! +! Appel des histbeg pour definir les variables (nom, moy ou inst, freq de sortie .. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + zdtime = dtime ! Frequence ou l on moyenne + +! Calcul des Ahyb, Bhyb et Alt + do k=1,klev + Ahyb(k)=(ap(k)+ap(k+1))/2. + Bhyb(k)=(bp(k)+bp(k+1))/2. + Alt(k)=log(preff/presnivs(k))*8. + enddo +! if(prt_level.ge.1) then + print*,'Ap Hybrid = ',Ahyb(1:klev) + print*,'Bp Hybrid = ',Bhyb(1:klev) + print*,'Alt approx des couches pour une haut d echelle de 8km = ',Alt(1:klev) +! endif + DO iff=1,nfiles + + IF (clef_files(iff)) THEN + + if ( chtimestep(iff).eq.'DefFreq' ) then +! Par defaut ecrit_files = (ecrit_mensuel ecrit_jour ecrit_hf ...)*86400. + ecrit_files(iff)=ecrit_files(iff)*86400. + else + call convers_timesteps(chtimestep(iff),ecrit_files(iff)) + endif + print*,'ecrit_files(',iff,')= ',ecrit_files(iff) + + zoutm(iff) = ecrit_files(iff) ! Frequence ou l on ecrit en seconde + + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) + +!!!!!!!!!!!!!!!!! Traitement dans le cas ou l'on veut stocker sur un domaine limite !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (phys_out_regfkey(iff)) then + + imin_ins=1 + imax_ins=iim + jmin_ins=1 + jmax_ins=jjmp1 + +! correction abderr + do i=1,iim + print*,'io_lon(i)=',io_lon(i) + if (io_lon(i).le.phys_out_lonmin(iff)) imin_ins=i + if (io_lon(i).le.phys_out_lonmax(iff)) imax_ins=i+1 + enddo + + do j=1,jjmp1 + print*,'io_lat(j)=',io_lat(j) + if (io_lat(j).ge.phys_out_latmin(iff)) jmax_ins=j+1 + if (io_lat(j).ge.phys_out_latmax(iff)) jmin_ins=j + enddo + + print*,'On stoke le fichier histoire numero ',iff,' sur ', & + imin_ins,imax_ins,jmin_ins,jmax_ins + print*,'longitudes : ', & + io_lon(imin_ins),io_lon(imax_ins), & + 'latitudes : ', & + io_lat(jmax_ins),io_lat(jmin_ins) + + CALL histbeg(phys_out_filenames(iff),iim,io_lon,jjmp1,io_lat, & + imin_ins,imax_ins-imin_ins+1, & + jmin_ins,jmax_ins-jmin_ins+1, & + itau_phy,zjulian,dtime,nhorim(iff),nid_files(iff)) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + else + CALL histbeg_phy(phys_out_filenames(iff),itau_phy,zjulian,dtime,nhorim(iff),nid_files(iff)) + endif + + CALL histvert(nid_files(iff), "presnivs", "Vertical levels", "mb", & + levmax(iff) - levmin(iff) + 1, & + presnivs(levmin(iff):levmax(iff))/100., nvertm(iff)) + +!!!!!!!!!!!!! Traitement des champs 3D pour histhf !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!! A Revoir plus tard !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! IF (iff.eq.3.and.lev_files(iff).ge.4) THEN +! CALL histbeg_phy("histhf3d",itau_phy, & +! & zjulian, dtime, & +! & nhorim, nid_hf3d) + +! CALL histvert(nid_hf3d, "presnivs", & +! & "Vertical levels", "mb", & +! & klev, presnivs/100., nvertm) +! ENDIF +! +!!!! Composentes de la coordonnee sigma-hybride + CALL histvert(nid_files(iff), "Ahyb","Ahyb comp of Hyb Cord ", "Pa", & + levmax(iff) - levmin(iff) + 1,Ahyb,nvertap(iff)) + + CALL histvert(nid_files(iff), "Bhyb","Bhyb comp of Hyb Cord", " ", & + levmax(iff) - levmin(iff) + 1,Bhyb,nvertbp(iff)) + + CALL histvert(nid_files(iff), "Alt","Height approx for scale heigh of 8km at levels", "Km", & + levmax(iff) - levmin(iff) + 1,Alt,nvertAlt(iff)) + +! CALL histvert(nid_files(iff), "preff","Reference pressure", "Pa", & +! 1,preff,nvertp0(iff)) +!!! Champs 1D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + CALL histdef2d(iff,o_phis%flag,o_phis%name,"Surface geop.height", "m2/s2") + type_ecri(1) = 'once' + type_ecri(2) = 'once' + type_ecri(3) = 'once' + type_ecri(4) = 'once' + type_ecri(5) = 'once' + CALL histdef2d(iff,o_aire%flag,o_aire%name,"Grid area", "-") + CALL histdef2d(iff,o_contfracATM%flag,o_contfracATM%name,"% sfce ter+lic", "-") + type_ecri(:) = type_ecri_files(:) + +!!! Champs 2D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + CALL histdef2d(iff,o_contfracOR%flag,o_contfracOR%name,"% sfce terre OR", "-" ) + CALL histdef2d(iff,o_aireTER%flag,o_aireTER%name,"Grid area CONT", "-" ) + CALL histdef2d(iff,o_flat%flag,o_flat%name, "Latent heat flux", "W/m2") + CALL histdef2d(iff,o_slp%flag,o_slp%name, "Sea Level Pressure", "Pa" ) + CALL histdef2d(iff,o_tsol%flag,o_tsol%name, "Surface Temperature", "K") + CALL histdef2d(iff,o_t2m%flag,o_t2m%name, "Temperature 2m", "K" ) + type_ecri(1) = 't_min(X)' + type_ecri(2) = 't_min(X)' + type_ecri(3) = 't_min(X)' + type_ecri(4) = 't_min(X)' + type_ecri(5) = 't_min(X)' + CALL histdef2d(iff,o_t2m_min%flag,o_t2m_min%name, "Temp 2m min", "K" ) + type_ecri(1) = 't_max(X)' + type_ecri(2) = 't_max(X)' + type_ecri(3) = 't_max(X)' + type_ecri(4) = 't_max(X)' + type_ecri(5) = 't_max(X)' + CALL histdef2d(iff,o_t2m_max%flag,o_t2m_max%name, "Temp 2m max", "K" ) + type_ecri(:) = type_ecri_files(:) + CALL histdef2d(iff,o_wind10m%flag,o_wind10m%name, "10-m wind speed", "m/s") + CALL histdef2d(iff,o_wind10max%flag,o_wind10max%name, "10m wind speed max", "m/s") + CALL histdef2d(iff,o_sicf%flag,o_sicf%name, "Sea-ice fraction", "-" ) + CALL histdef2d(iff,o_q2m%flag,o_q2m%name, "Specific humidity 2m", "kg/kg") + CALL histdef2d(iff,o_u10m%flag,o_u10m%name, "Vent zonal 10m", "m/s" ) + CALL histdef2d(iff,o_v10m%flag,o_v10m%name, "Vent meridien 10m", "m/s") + CALL histdef2d(iff,o_psol%flag,o_psol%name, "Surface Pressure", "Pa" ) + CALL histdef2d(iff,o_qsurf%flag,o_qsurf%name, "Surface Air humidity", "kg/kg") + + if (.not. ok_veget) then + CALL histdef2d(iff,o_qsol%flag,o_qsol%name, "Soil watter content", "mm" ) + endif + + CALL histdef2d(iff,o_ndayrain%flag,o_ndayrain%name, "Number of dayrain(liq+sol)", "-") + CALL histdef2d(iff,o_precip%flag,o_precip%name, "Precip Totale liq+sol", "kg/(s*m2)" ) + CALL histdef2d(iff,o_plul%flag,o_plul%name, "Large-scale Precip.", "kg/(s*m2)") + CALL histdef2d(iff,o_pluc%flag,o_pluc%name, "Convective Precip.", "kg/(s*m2)") + CALL histdef2d(iff,o_snow%flag,o_snow%name, "Snow fall", "kg/(s*m2)" ) + CALL histdef2d(iff,o_evap%flag,o_evap%name, "Evaporat", "kg/(s*m2)" ) + CALL histdef2d(iff,o_tops%flag,o_tops%name, "Solar rad. at TOA", "W/m2") + CALL histdef2d(iff,o_tops0%flag,o_tops0%name, "CS Solar rad. at TOA", "W/m2") + CALL histdef2d(iff,o_topl%flag,o_topl%name, "IR rad. at TOA", "W/m2" ) + CALL histdef2d(iff,o_topl0%flag,o_topl0%name, "IR rad. at TOA", "W/m2") + CALL histdef2d(iff,o_SWupTOA%flag,o_SWupTOA%name, "SWup at TOA", "W/m2") + CALL histdef2d(iff,o_SWupTOAclr%flag,o_SWupTOAclr%name, "SWup clear sky at TOA", "W/m2") + CALL histdef2d(iff,o_SWdnTOA%flag,o_SWdnTOA%name, "SWdn at TOA", "W/m2" ) + CALL histdef2d(iff,o_SWdnTOAclr%flag,o_SWdnTOAclr%name, "SWdn clear sky at TOA", "W/m2") + CALL histdef2d(iff,o_SWup200%flag,o_SWup200%name, "SWup at 200mb", "W/m2" ) + CALL histdef2d(iff,o_SWup200clr%flag,o_SWup200clr%name, "SWup clear sky at 200mb", "W/m2") + CALL histdef2d(iff,o_SWdn200%flag,o_SWdn200%name, "SWdn at 200mb", "W/m2" ) + CALL histdef2d(iff,o_SWdn200clr%flag,o_SWdn200clr%name, "SWdn clear sky at 200mb", "W/m2") + CALL histdef2d(iff,o_LWup200%flag,o_LWup200%name, "LWup at 200mb", "W/m2") + CALL histdef2d(iff,o_LWup200clr%flag,o_LWup200clr%name, "LWup clear sky at 200mb", "W/m2") + CALL histdef2d(iff,o_LWdn200%flag,o_LWdn200%name, "LWdn at 200mb", "W/m2") + CALL histdef2d(iff,o_LWdn200clr%flag,o_LWdn200clr%name, "LWdn clear sky at 200mb", "W/m2") + CALL histdef2d(iff,o_sols%flag,o_sols%name, "Solar rad. at surf.", "W/m2") + CALL histdef2d(iff,o_sols0%flag,o_sols0%name, "Solar rad. at surf.", "W/m2") + CALL histdef2d(iff,o_soll%flag,o_soll%name, "IR rad. at surface", "W/m2") + CALL histdef2d(iff,o_radsol%flag,o_radsol%name, "Rayonnement au sol", "W/m2") + CALL histdef2d(iff,o_soll0%flag,o_soll0%name, "IR rad. at surface", "W/m2") + CALL histdef2d(iff,o_SWupSFC%flag,o_SWupSFC%name, "SWup at surface", "W/m2") + CALL histdef2d(iff,o_SWupSFCclr%flag,o_SWupSFCclr%name, "SWup clear sky at surface", "W/m2") + CALL histdef2d(iff,o_SWdnSFC%flag,o_SWdnSFC%name, "SWdn at surface", "W/m2") + CALL histdef2d(iff,o_SWdnSFCclr%flag,o_SWdnSFCclr%name, "SWdn clear sky at surface", "W/m2") + CALL histdef2d(iff,o_LWupSFC%flag,o_LWupSFC%name, "Upwd. IR rad. at surface", "W/m2") + CALL histdef2d(iff,o_LWdnSFC%flag,o_LWdnSFC%name, "Down. IR rad. at surface", "W/m2") + CALL histdef2d(iff,o_LWupSFCclr%flag,o_LWupSFCclr%name, "CS Upwd. IR rad. at surface", "W/m2") + CALL histdef2d(iff,o_LWdnSFCclr%flag,o_LWdnSFCclr%name, "Down. CS IR rad. at surface", "W/m2") + CALL histdef2d(iff,o_bils%flag,o_bils%name, "Surf. total heat flux", "W/m2") + CALL histdef2d(iff,o_sens%flag,o_sens%name, "Sensible heat flux", "W/m2") + CALL histdef2d(iff,o_fder%flag,o_fder%name, "Heat flux derivation", "W/m2") + CALL histdef2d(iff,o_ffonte%flag,o_ffonte%name, "Thermal flux for snow melting", "W/m2") + CALL histdef2d(iff,o_fqcalving%flag,o_fqcalving%name, "Ice Calving", "kg/m2/s") + CALL histdef2d(iff,o_fqfonte%flag,o_fqfonte%name, "Land ice melt", "kg/m2/s") + + DO nsrf = 1, nbsrf + CALL histdef2d(iff,o_pourc_srf(nsrf)%flag,o_pourc_srf(nsrf)%name,"% "//clnsurf(nsrf),"%") + CALL histdef2d(iff,o_fract_srf(nsrf)%flag,o_fract_srf(nsrf)%name,"Fraction "//clnsurf(nsrf),"1") + CALL histdef2d(iff,o_taux_srf(nsrf)%flag,o_taux_srf(nsrf)%name,"Zonal wind stress"//clnsurf(nsrf),"Pa") + CALL histdef2d(iff,o_tauy_srf(nsrf)%flag,o_tauy_srf(nsrf)%name,"Meridional wind stress "//clnsurf(nsrf),"Pa") + CALL histdef2d(iff,o_tsol_srf(nsrf)%flag,o_tsol_srf(nsrf)%name,"Temperature "//clnsurf(nsrf),"K") + CALL histdef2d(iff,o_u10m_srf(nsrf)%flag,o_u10m_srf(nsrf)%name,"Vent Zonal 10m "//clnsurf(nsrf),"m/s") + CALL histdef2d(iff,o_v10m_srf(nsrf)%flag,o_v10m_srf(nsrf)%name,"Vent meredien 10m "//clnsurf(nsrf),"m/s") + CALL histdef2d(iff,o_t2m_srf(nsrf)%flag,o_t2m_srf(nsrf)%name,"Temp 2m "//clnsurf(nsrf),"K") + CALL histdef2d(iff,o_sens_srf(nsrf)%flag,o_sens_srf(nsrf)%name,"Sensible heat flux "//clnsurf(nsrf),"W/m2") + CALL histdef2d(iff,o_lat_srf(nsrf)%flag,o_lat_srf(nsrf)%name,"Latent heat flux "//clnsurf(nsrf),"W/m2") + CALL histdef2d(iff,o_flw_srf(nsrf)%flag,o_flw_srf(nsrf)%name,"LW "//clnsurf(nsrf),"W/m2") + CALL histdef2d(iff,o_fsw_srf(nsrf)%flag,o_fsw_srf(nsrf)%name,"SW "//clnsurf(nsrf),"W/m2") + CALL histdef2d(iff,o_wbils_srf(nsrf)%flag,o_wbils_srf(nsrf)%name,"Bilan sol "//clnsurf(nsrf),"W/m2" ) + CALL histdef2d(iff,o_wbilo_srf(nsrf)%flag,o_wbilo_srf(nsrf)%name,"Bilan eau "//clnsurf(nsrf),"kg/(m2*s)") + if (iflag_pbl>1 .and. lev_files(iff).gt.10 ) then + CALL histdef2d(iff,o_tke_srf(nsrf)%flag,o_tke_srf(nsrf)%name,"Max Turb. Kinetic Energy "//clnsurf(nsrf),"-") + type_ecri(1) = 't_max(X)' + type_ecri(2) = 't_max(X)' + type_ecri(3) = 't_max(X)' + type_ecri(4) = 't_max(X)' + type_ecri(5) = 't_max(X)' + CALL histdef2d(iff,o_tke_max_srf(nsrf)%flag,o_tke_max_srf(nsrf)%name,"Max Turb. Kinetic Energy "//clnsurf(nsrf),"-") + type_ecri(:) = type_ecri_files(:) + endif + CALL histdef2d(iff,o_albe_srf(nsrf)%flag,o_albe_srf(nsrf)%name,"Albedo surf. "//clnsurf(nsrf),"-") + CALL histdef2d(iff,o_rugs_srf(nsrf)%flag,o_rugs_srf(nsrf)%name,"Latent heat flux "//clnsurf(nsrf),"W/m2") + CALL histdef2d(iff,o_ages_srf(nsrf)%flag,o_ages_srf(nsrf)%name,"Snow age", "day") +END DO + +IF (new_aod .AND. (.NOT. aerosol_couple)) THEN + DO naero = 1, naero_spc + CALL histdef2d(iff,o_tausumaero(naero)%flag,o_tausumaero(naero)%name,"Aerosol Optical depth at 550 nm "//name_aero(naero),"1") + END DO +ENDIF + + IF (ok_ade) THEN + CALL histdef2d(iff,o_topswad%flag,o_topswad%name, "ADE at TOA", "W/m2") + CALL histdef2d(iff,o_solswad%flag,o_solswad%name, "ADE at SRF", "W/m2") + + CALL histdef2d(iff,o_swtoaas_nat%flag,o_swtoaas_nat%name, "Natural aerosol radiative forcing all-sky at TOA", "W/m2") + CALL histdef2d(iff,o_swsrfas_nat%flag,o_swsrfas_nat%name, "Natural aerosol radiative forcing all-sky at SRF", "W/m2") + CALL histdef2d(iff,o_swtoacs_nat%flag,o_swtoacs_nat%name, "Natural aerosol radiative forcing clear-sky at TOA", "W/m2") + CALL histdef2d(iff,o_swsrfcs_nat%flag,o_swsrfcs_nat%name, "Natural aerosol radiative forcing clear-sky at SRF", "W/m2") + + CALL histdef2d(iff,o_swtoaas_ant%flag,o_swtoaas_ant%name, "Anthropogenic aerosol radiative forcing all-sky at TOA", "W/m2") + CALL histdef2d(iff,o_swsrfas_ant%flag,o_swsrfas_ant%name, "Anthropogenic aerosol radiative forcing all-sky at SRF", "W/m2") + CALL histdef2d(iff,o_swtoacs_ant%flag,o_swtoacs_ant%name, "Anthropogenic aerosol radiative forcing clear-sky at TOA", "W/m2") + CALL histdef2d(iff,o_swsrfcs_ant%flag,o_swsrfcs_ant%name, "Anthropogenic aerosol radiative forcing clear-sky at SRF", "W/m2") + + IF (.NOT. aerosol_couple) THEN + CALL histdef2d(iff,o_swtoacf_nat%flag,o_swtoacf_nat%name, "Natural aerosol impact on cloud radiative forcing at TOA", "W/m2") + CALL histdef2d(iff,o_swsrfcf_nat%flag,o_swsrfcf_nat%name, "Natural aerosol impact on cloud radiative forcing at SRF", "W/m2") + CALL histdef2d(iff,o_swtoacf_ant%flag,o_swtoacf_ant%name, "Anthropogenic aerosol impact on cloud radiative forcing at TOA", "W/m2") + CALL histdef2d(iff,o_swsrfcf_ant%flag,o_swsrfcf_ant%name, "Anthropogenic aerosol impact on cloud radiative forcing at SRF", "W/m2") + CALL histdef2d(iff,o_swtoacf_zero%flag,o_swtoacf_zero%name, "Cloud radiative forcing (allsky-clearsky fluxes) at TOA", "W/m2") + CALL histdef2d(iff,o_swsrfcf_zero%flag,o_swsrfcf_zero%name, "Cloud radiative forcing (allsky-clearsky fluxes) at SRF", "W/m2") + ENDIF + + ENDIF + + IF (ok_aie) THEN + CALL histdef2d(iff,o_topswai%flag,o_topswai%name, "AIE at TOA", "W/m2") + CALL histdef2d(iff,o_solswai%flag,o_solswai%name, "AIE at SFR", "W/m2") + ENDIF + + + CALL histdef2d(iff,o_albs%flag,o_albs%name, "Surface albedo", "-") + CALL histdef2d(iff,o_albslw%flag,o_albslw%name, "Surface albedo LW", "-") + CALL histdef2d(iff,o_cdrm%flag,o_cdrm%name, "Momentum drag coef.", "-") + CALL histdef2d(iff,o_cdrh%flag,o_cdrh%name, "Heat drag coef.", "-" ) + CALL histdef2d(iff,o_cldl%flag,o_cldl%name, "Low-level cloudiness", "-") + CALL histdef2d(iff,o_cldm%flag,o_cldm%name, "Mid-level cloudiness", "-") + CALL histdef2d(iff,o_cldh%flag,o_cldh%name, "High-level cloudiness", "-") + CALL histdef2d(iff,o_cldt%flag,o_cldt%name, "Total cloudiness", "%") + CALL histdef2d(iff,o_cldq%flag,o_cldq%name, "Cloud liquid water path", "kg/m2") + CALL histdef2d(iff,o_lwp%flag,o_lwp%name, "Cloud water path", "kg/m2") + CALL histdef2d(iff,o_iwp%flag,o_iwp%name, "Cloud ice water path", "kg/m2" ) + CALL histdef2d(iff,o_ue%flag,o_ue%name, "Zonal energy transport", "-") + CALL histdef2d(iff,o_ve%flag,o_ve%name, "Merid energy transport", "-") + CALL histdef2d(iff,o_uq%flag,o_uq%name, "Zonal humidity transport", "-") + CALL histdef2d(iff,o_vq%flag,o_vq%name, "Merid humidity transport", "-") + + IF(iflag_con.GE.3) THEN ! sb + CALL histdef2d(iff,o_cape%flag,o_cape%name, "Conv avlbl pot ener", "J/kg") + CALL histdef2d(iff,o_pbase%flag,o_pbase%name, "Cld base pressure", "mb") + CALL histdef2d(iff,o_ptop%flag,o_ptop%name, "Cld top pressure", "mb") + CALL histdef2d(iff,o_fbase%flag,o_fbase%name, "Cld base mass flux", "kg/m2/s") + CALL histdef2d(iff,o_prw%flag,o_prw%name, "Precipitable water", "kg/m2") + type_ecri(1) = 't_max(X)' + type_ecri(2) = 't_max(X)' + type_ecri(3) = 't_max(X)' + type_ecri(4) = 't_max(X)' + type_ecri(5) = 't_max(X)' + CALL histdef2d(iff,o_cape_max%flag,o_cape_max%name, "CAPE max.", "J/kg") + type_ecri(:) = type_ecri_files(:) + CALL histdef3d(iff,o_upwd%flag,o_upwd%name, "saturated updraft", "kg/m2/s") + CALL histdef3d(iff,o_Ma%flag,o_Ma%name, "undilute adiab updraft", "kg/m2/s") + CALL histdef3d(iff,o_dnwd%flag,o_dnwd%name, "saturated downdraft", "kg/m2/s") + CALL histdef3d(iff,o_dnwd0%flag,o_dnwd0%name, "unsat. downdraft", "kg/m2/s") + ENDIF !iflag_con .GE. 3 + + CALL histdef2d(iff,o_s_pblh%flag,o_s_pblh%name, "Boundary Layer Height", "m") + CALL histdef2d(iff,o_s_pblt%flag,o_s_pblt%name, "t at Boundary Layer Height", "K") + CALL histdef2d(iff,o_s_lcl%flag,o_s_lcl%name, "Condensation level", "m") + CALL histdef2d(iff,o_s_capCL%flag,o_s_capCL%name, "Conv avlbl pot enerfor ABL", "J/m2" ) + CALL histdef2d(iff,o_s_oliqCL%flag,o_s_oliqCL%name, "Liq Water in BL", "kg/m2") + CALL histdef2d(iff,o_s_cteiCL%flag,o_s_cteiCL%name, "Instability criteria(ABL)", "K") + CALL histdef2d(iff,o_s_therm%flag,o_s_therm%name, "Exces du thermique", "K") + CALL histdef2d(iff,o_s_trmb1%flag,o_s_trmb1%name, "deep_cape(HBTM2)", "J/m2") + CALL histdef2d(iff,o_s_trmb2%flag,o_s_trmb2%name, "inhibition (HBTM2)", "J/m2") + CALL histdef2d(iff,o_s_trmb3%flag,o_s_trmb3%name, "Point Omega (HBTM2)", "m") + +! Champs interpolles sur des niveaux de pression + + type_ecri(1) = 'inst(X)' + type_ecri(2) = 'inst(X)' + type_ecri(3) = 'inst(X)' + type_ecri(4) = 'inst(X)' + type_ecri(5) = 'inst(X)' + +! Attention a reverifier + + ilev=0 + DO k=1, nlevSTD +! IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k) + bb2=clevSTD(k) + IF(bb2.EQ."850".OR.bb2.EQ."700".OR.bb2.EQ."500".OR.bb2.EQ."200".OR.bb2.EQ."50".OR.bb2.EQ."10")THEN + ilev=ilev+1 + print*,'ilev k bb2 flag name ',ilev,k, bb2,o_uSTDlevs(ilev)%flag,o_uSTDlevs(ilev)%name + CALL histdef2d(iff,o_uSTDlevs(ilev)%flag,o_uSTDlevs(ilev)%name,"Zonal wind "//bb2//"mb", "m/s") + CALL histdef2d(iff,o_vSTDlevs(ilev)%flag,o_vSTDlevs(ilev)%name,"Meridional wind "//bb2//"mb", "m/s") + CALL histdef2d(iff,o_wSTDlevs(ilev)%flag,o_wSTDlevs(ilev)%name,"Vertical wind "//bb2//"mb", "Pa/s") + CALL histdef2d(iff,o_phiSTDlevs(ilev)%flag,o_phiSTDlevs(ilev)%name,"Geopotential "//bb2//"mb", "m") + CALL histdef2d(iff,o_qSTDlevs(ilev)%flag,o_qSTDlevs(ilev)%name,"Specific humidity "//bb2//"mb", "kg/kg" ) + CALL histdef2d(iff,o_tSTDlevs(ilev)%flag,o_tSTDlevs(ilev)%name,"Temperature "//bb2//"mb", "K") + ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR."500".OR.bb2.EQ."200".OR.bb2.EQ."50".OR.bb2.EQ."10") + ENDDO + type_ecri(:) = type_ecri_files(:) + + CALL histdef2d(iff,o_t_oce_sic%flag,o_t_oce_sic%name, "Temp mixte oce-sic", "K") + + IF (type_ocean=='slab') & + CALL histdef2d(iff,o_slab_bils%flag, o_slab_bils%name,"Bilan au sol sur ocean slab", "W/m2") + +! Couplage conv-CL + IF (iflag_con.GE.3) THEN + IF (iflag_coupl.EQ.1) THEN + CALL histdef2d(iff,o_ale_bl%flag,o_ale_bl%name, "ALE BL", "m2/s2") + CALL histdef2d(iff,o_alp_bl%flag,o_alp_bl%name, "ALP BL", "m2/s2") + ENDIF + ENDIF !(iflag_con.GE.3) + + CALL histdef2d(iff,o_weakinv%flag,o_weakinv%name, "Weak inversion", "-") + CALL histdef2d(iff,o_dthmin%flag,o_dthmin%name, "dTheta mini", "K/m") + CALL histdef2d(iff,o_rh2m%flag,o_rh2m%name, "Relative humidity at 2m", "%" ) + CALL histdef2d(iff,o_qsat2m%flag,o_qsat2m%name, "Saturant humidity at 2m", "%") + CALL histdef2d(iff,o_tpot%flag,o_tpot%name, "Surface air potential temperature", "K") + CALL histdef2d(iff,o_tpote%flag,o_tpote%name, "Surface air equivalent potential temperature", "K") + CALL histdef2d(iff,o_SWnetOR%flag,o_SWnetOR%name, "Sfce net SW radiation OR", "W/m2") + CALL histdef2d(iff,o_SWdownOR%flag,o_SWdownOR%name, "Sfce incident SW radiation OR", "W/m2") + CALL histdef2d(iff,o_LWdownOR%flag,o_LWdownOR%name, "Sfce incident LW radiation OR", "W/m2") + CALL histdef2d(iff,o_snowl%flag,o_snowl%name, "Solid Large-scale Precip.", "kg/(m2*s)") + + CALL histdef2d(iff,o_solldown%flag,o_solldown%name, "Down. IR rad. at surface", "W/m2") + CALL histdef2d(iff,o_dtsvdfo%flag,o_dtsvdfo%name, "Boundary-layer dTs(o)", "K/s") + CALL histdef2d(iff,o_dtsvdft%flag,o_dtsvdft%name, "Boundary-layer dTs(t)", "K/s") + CALL histdef2d(iff,o_dtsvdfg%flag,o_dtsvdfg%name, "Boundary-layer dTs(g)", "K/s") + CALL histdef2d(iff,o_dtsvdfi%flag,o_dtsvdfi%name, "Boundary-layer dTs(g)", "K/s") + CALL histdef2d(iff,o_rugs%flag,o_rugs%name, "rugosity", "-" ) + +! Champs 3D: + CALL histdef3d(iff,o_lwcon%flag,o_lwcon%name, "Cloud liquid water content", "kg/kg") + CALL histdef3d(iff,o_iwcon%flag,o_iwcon%name, "Cloud ice water content", "kg/kg") + CALL histdef3d(iff,o_temp%flag,o_temp%name, "Air temperature", "K" ) + CALL histdef3d(iff,o_theta%flag,o_theta%name, "Potential air temperature", "K" ) + CALL histdef3d(iff,o_ovap%flag,o_ovap%name, "Specific humidity + dqphy", "kg/kg" ) + CALL histdef3d(iff,o_ovapinit%flag,o_ovapinit%name, "Specific humidity", "kg/kg" ) + CALL histdef3d(iff,o_geop%flag,o_geop%name, "Geopotential height", "m2/s2") + CALL histdef3d(iff,o_vitu%flag,o_vitu%name, "Zonal wind", "m/s" ) + CALL histdef3d(iff,o_vitv%flag,o_vitv%name, "Meridional wind", "m/s" ) + CALL histdef3d(iff,o_vitw%flag,o_vitw%name, "Vertical wind", "Pa/s" ) + CALL histdef3d(iff,o_pres%flag,o_pres%name, "Air pressure", "Pa" ) + CALL histdef3d(iff,o_rneb%flag,o_rneb%name, "Cloud fraction", "-") + CALL histdef3d(iff,o_rnebcon%flag,o_rnebcon%name, "Convective Cloud Fraction", "-") + CALL histdef3d(iff,o_rhum%flag,o_rhum%name, "Relative humidity", "-") + CALL histdef3d(iff,o_ozone%flag,o_ozone%name, "Ozone mole fraction", "-") + if (read_climoz == 2) & + CALL histdef3d(iff,o_ozone_light%flag,o_ozone_light%name, & + "Daylight ozone mole fraction", "-") + CALL histdef3d(iff,o_dtphy%flag,o_dtphy%name, "Physics dT", "K/s") + CALL histdef3d(iff,o_dqphy%flag,o_dqphy%name, "Physics dQ", "(kg/kg)/s") + CALL histdef3d(iff,o_cldtau%flag,o_cldtau%name, "Cloud optical thickness", "1") + CALL histdef3d(iff,o_cldemi%flag,o_cldemi%name, "Cloud optical emissivity", "1") +!IM: bug ?? dimensionnement variables (klon,klev+1) pmflxr, pmflxs, prfl, psfl + CALL histdef3d(iff,o_pr_con_l%flag,o_pr_con_l%name, "Convective precipitation lic", " ") + CALL histdef3d(iff,o_pr_con_i%flag,o_pr_con_i%name, "Convective precipitation ice", " ") + CALL histdef3d(iff,o_pr_lsc_l%flag,o_pr_lsc_l%name, "Large scale precipitation lic", " ") + CALL histdef3d(iff,o_pr_lsc_i%flag,o_pr_lsc_i%name, "Large scale precipitation ice", " ") +!FH Sorties pour la couche limite + if (iflag_pbl>1) then + CALL histdef3d(iff,o_tke%flag,o_tke%name, "TKE", "m2/s2") + type_ecri(1) = 't_max(X)' + type_ecri(2) = 't_max(X)' + type_ecri(3) = 't_max(X)' + type_ecri(4) = 't_max(X)' + type_ecri(5) = 't_max(X)' + CALL histdef3d(iff,o_tke_max%flag,o_tke_max%name, "TKE max", "m2/s2") + type_ecri(:) = type_ecri_files(:) + endif + + CALL histdef3d(iff,o_kz%flag,o_kz%name, "Kz melange", "m2/s") + type_ecri(1) = 't_max(X)' + type_ecri(2) = 't_max(X)' + type_ecri(3) = 't_max(X)' + type_ecri(4) = 't_max(X)' + type_ecri(5) = 't_max(X)' + CALL histdef3d(iff,o_kz_max%flag,o_kz_max%name, "Kz melange max", "m2/s" ) + type_ecri(:) = type_ecri_files(:) + CALL histdef3d(iff,o_clwcon%flag,o_clwcon%name, "Convective Cloud Liquid water content", "kg/kg") + CALL histdef3d(iff,o_dtdyn%flag,o_dtdyn%name, "Dynamics dT", "K/s") + CALL histdef3d(iff,o_dqdyn%flag,o_dqdyn%name, "Dynamics dQ", "(kg/kg)/s") + CALL histdef3d(iff,o_dudyn%flag,o_dudyn%name, "Dynamics dU", "m/s2") + CALL histdef3d(iff,o_dvdyn%flag,o_dvdyn%name, "Dynamics dV", "m/s2") + CALL histdef3d(iff,o_dtcon%flag,o_dtcon%name, "Convection dT", "K/s") + CALL histdef3d(iff,o_ducon%flag,o_ducon%name, "Convection du", "m/s2") + CALL histdef3d(iff,o_dqcon%flag,o_dqcon%name, "Convection dQ", "(kg/kg)/s") + +! Wakes + IF(iflag_con.EQ.3) THEN + IF (iflag_wake == 1) THEN + CALL histdef2d(iff,o_ale_wk%flag,o_ale_wk%name, "ALE WK", "m2/s2") + CALL histdef2d(iff,o_alp_wk%flag,o_alp_wk%name, "ALP WK", "m2/s2") + CALL histdef2d(iff,o_ale%flag,o_ale%name, "ALE", "m2/s2") + CALL histdef2d(iff,o_alp%flag,o_alp%name, "ALP", "W/m2") + CALL histdef2d(iff,o_cin%flag,o_cin%name, "Convective INhibition", "m2/s2") + CALL histdef2d(iff,o_wape%flag,o_WAPE%name, "WAPE", "m2/s2") + CALL histdef2d(iff,o_wake_h%flag,o_wake_h%name, "wake_h", "-") + CALL histdef2d(iff,o_wake_s%flag,o_wake_s%name, "wake_s", "-") + CALL histdef3d(iff,o_dtwak%flag,o_dtwak%name, "Wake dT", "K/s") + CALL histdef3d(iff,o_dqwak%flag,o_dqwak%name, "Wake dQ", "(kg/kg)/s") + CALL histdef3d(iff,o_wake_deltat%flag,o_wake_deltat%name, "wake_deltat", " ") + CALL histdef3d(iff,o_wake_deltaq%flag,o_wake_deltaq%name, "wake_deltaq", " ") + CALL histdef3d(iff,o_wake_omg%flag,o_wake_omg%name, "wake_omg", " ") + ENDIF + CALL histdef3d(iff,o_Vprecip%flag,o_Vprecip%name, "precipitation vertical profile", "-") + CALL histdef3d(iff,o_ftd%flag,o_ftd%name, "tend temp due aux descentes precip", "-") + CALL histdef3d(iff,o_fqd%flag,o_fqd%name,"tend vap eau due aux descentes precip", "-") + ENDIF !(iflag_con.EQ.3) + + CALL histdef3d(iff,o_dtlsc%flag,o_dtlsc%name, "Condensation dT", "K/s") + CALL histdef3d(iff,o_dtlschr%flag,o_dtlschr%name,"Large-scale condensational heating rate","K/s") + CALL histdef3d(iff,o_dqlsc%flag,o_dqlsc%name, "Condensation dQ", "(kg/kg)/s") + CALL histdef3d(iff,o_dtvdf%flag,o_dtvdf%name, "Boundary-layer dT", "K/s") + CALL histdef3d(iff,o_dqvdf%flag,o_dqvdf%name, "Boundary-layer dQ", "(kg/kg)/s") + CALL histdef3d(iff,o_dteva%flag,o_dteva%name, "Reevaporation dT", "K/s") + CALL histdef3d(iff,o_dqeva%flag,o_dqeva%name, "Reevaporation dQ", "(kg/kg)/s") + CALL histdef3d(iff,o_ptconv%flag,o_ptconv%name, "POINTS CONVECTIFS", " ") + CALL histdef3d(iff,o_ratqs%flag,o_ratqs%name, "RATQS", " ") + CALL histdef3d(iff,o_dtthe%flag,o_dtthe%name, "Dry adjust. dT", "K/s") + +if(iflag_thermals.gt.1) THEN + CALL histdef3d(iff,o_f_th%flag,o_f_th%name, "Thermal plume mass flux", "K/s") + CALL histdef3d(iff,o_e_th%flag,o_e_th%name,"Thermal plume entrainment","K/s") + CALL histdef3d(iff,o_w_th%flag,o_w_th%name,"Thermal plume vertical velocity","m/s") + CALL histdef3d(iff,o_lambda_th%flag,o_lambda_th%name,"Thermal plume vertical velocity","m/s") + CALL histdef3d(iff,o_q_th%flag,o_q_th%name, "Thermal plume total humidity", "kg/kg") + CALL histdef3d(iff,o_a_th%flag,o_a_th%name, "Thermal plume fraction", "") + CALL histdef3d(iff,o_d_th%flag,o_d_th%name, "Thermal plume detrainment", "K/s") +endif !iflag_thermals.gt.1 + CALL histdef2d(iff,o_f0_th%flag,o_f0_th%name, "Thermal closure mass flux", "K/s") + CALL histdef2d(iff,o_zmax_th%flag,o_zmax_th%name, "Thermal plume height", "K/s") + CALL histdef3d(iff,o_dqthe%flag,o_dqthe%name, "Dry adjust. dQ", "(kg/kg)/s") + CALL histdef3d(iff,o_dtajs%flag,o_dtajs%name, "Dry adjust. dT", "K/s") + CALL histdef3d(iff,o_dqajs%flag,o_dqajs%name, "Dry adjust. dQ", "(kg/kg)/s") + CALL histdef3d(iff,o_dtswr%flag,o_dtswr%name, "SW radiation dT", "K/s") + CALL histdef3d(iff,o_dtsw0%flag,o_dtsw0%name, "CS SW radiation dT", "K/s") + CALL histdef3d(iff,o_dtlwr%flag,o_dtlwr%name, "LW radiation dT", "K/s") + CALL histdef3d(iff,o_dtlw0%flag,o_dtlw0%name, "CS LW radiation dT", "K/s") + CALL histdef3d(iff,o_dtec%flag,o_dtec%name, "Cinetic dissip dT", "K/s") + CALL histdef3d(iff,o_duvdf%flag,o_duvdf%name, "Boundary-layer dU", "m/s2") + CALL histdef3d(iff,o_dvvdf%flag,o_dvvdf%name, "Boundary-layer dV", "m/s2") + + IF (ok_orodr) THEN + CALL histdef3d(iff,o_duoro%flag,o_duoro%name, "Orography dU", "m/s2") + CALL histdef3d(iff,o_dvoro%flag,o_dvoro%name, "Orography dV", "m/s2") + ENDIF + + IF (ok_orolf) THEN + CALL histdef3d(iff,o_dulif%flag,o_dulif%name, "Orography dU", "m/s2") + CALL histdef3d(iff,o_dvlif%flag,o_dvlif%name, "Orography dV", "m/s2") + ENDIF + + if (nqtot>=3) THEN +!Attention DO iq=3,nqtot + DO iq=3,4 + iiq=niadv(iq) +! CALL histdef3d (iff, o_trac%flag,'o_'//tnom(iq)%name,ttext(iiq), "-" ) + CALL histdef3d (iff, o_trac(iq-2)%flag,o_trac(iq-2)%name,ttext(iiq), "-" ) + ENDDO + endif + + CALL histend(nid_files(iff)) + + ndex2d = 0 + ndex3d = 0 + + ENDIF ! clef_files + + ENDDO ! iff + print*,'Fin phys_output_mod.F90' + end subroutine phys_output_open + + SUBROUTINE histdef2d (iff,flag_var,nomvar,titrevar,unitvar) + + use ioipsl + USE dimphy + USE mod_phys_lmdz_para + + IMPLICIT NONE + + include "dimensions.h" + include "temps.h" + include "indicesol.h" + include "clesphys.h" + + integer :: iff + integer, dimension(nfiles) :: flag_var + character(len=20) :: nomvar + character(len=*) :: titrevar + character(len=*) :: unitvar + + real zstophym + + if (type_ecri(iff)=='inst(X)'.OR.type_ecri(iff)=='once') then + zstophym=zoutm(iff) + else + zstophym=zdtime + endif + +! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def + call conf_physoutputs(nomvar,flag_var) + + if ( flag_var(iff)<=lev_files(iff) ) then + call histdef (nid_files(iff),nomvar,titrevar,unitvar, & + iim,jj_nb,nhorim(iff), 1,1,1, -99, 32, & + type_ecri(iff), zstophym,zoutm(iff)) + endif + end subroutine histdef2d + + SUBROUTINE histdef3d (iff,flag_var,nomvar,titrevar,unitvar) + + use ioipsl + USE dimphy + USE mod_phys_lmdz_para + + IMPLICIT NONE + + include "dimensions.h" + include "temps.h" + include "indicesol.h" + include "clesphys.h" + + integer :: iff + integer, dimension(nfiles) :: flag_var + character(len=20) :: nomvar + character(len=*) :: titrevar + character(len=*) :: unitvar + + real zstophym + +! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def + call conf_physoutputs(nomvar,flag_var) + + if (type_ecri(iff)=='inst(X)'.OR.type_ecri(iff)=='once') then + zstophym=zoutm(iff) + else + zstophym=zdtime + endif + + if ( flag_var(iff)<=lev_files(iff) ) then + call histdef (nid_files(iff), nomvar, titrevar, unitvar, & + iim, jj_nb, nhorim(iff), klev, levmin(iff), & + levmax(iff)-levmin(iff)+1, nvertm(iff), 32, type_ecri(iff), & + zstophym, zoutm(iff)) + endif + end subroutine histdef3d + + SUBROUTINE conf_physoutputs(nam_var,flag_var) +!!! Lecture des noms et niveau de sortie des variables dans output.def +! en utilisant les routines getin de IOIPSL + use ioipsl + + IMPLICIT NONE + + include 'iniprint.h' + + character(len=20) :: nam_var + integer, dimension(nfiles) :: flag_var + + IF(prt_level>10) WRITE(lunout,*)'Avant getin: nam_var flag_var ',nam_var,flag_var(:) + call getin('flag_'//nam_var,flag_var) + call getin('name_'//nam_var,nam_var) + IF(prt_level>10) WRITE(lunout,*)'Apres getin: nam_var flag_var ',nam_var,flag_var(:) + + END SUBROUTINE conf_physoutputs + + SUBROUTINE convers_timesteps(str,timestep) + + use ioipsl + + IMPLICIT NONE + + character(len=20) :: str + character(len=10) :: type + integer :: ipos,il + real :: ttt,xxx,timestep,dayseconde + parameter (dayseconde=86400.) + include "temps.h" + include "comconst.h" + + ipos=scan(str,'0123456789.',.true.) +! + il=len_trim(str) + print*,ipos,il + read(str(1:ipos),*) ttt + print*,ttt + type=str(ipos+1:il) + + + if ( il == ipos ) then + type='day' + endif + + if ( type == 'day'.or.type == 'days'.or.type == 'jours'.or.type == 'jour' ) timestep = ttt * dayseconde + if ( type == 'mounths'.or.type == 'mth'.or.type == 'mois' ) then + print*,'annee_ref,day_ref mon_len',annee_ref,day_ref,ioget_mon_len(annee_ref,day_ref) + timestep = ttt * dayseconde * ioget_mon_len(annee_ref,day_ref) + endif + if ( type == 'hours'.or.type == 'hr'.or.type == 'heurs') timestep = ttt * dayseconde / 24. + if ( type == 'mn'.or.type == 'minutes' ) timestep = ttt * 60. + if ( type == 's'.or.type == 'sec'.or.type == 'secondes' ) timestep = ttt + if ( type == 'TS' ) timestep = dtphys + + print*,'type = ',type + print*,'nb j/h/m = ',ttt + print*,'timestep(s)=',timestep + + END SUBROUTINE convers_timesteps + +END MODULE phys_output_mod + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phys_output_write.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phys_output_write.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phys_output_write.h (revision 1280) @@ -0,0 +1,1305 @@ + itau_w = itau_phy + itap + + DO iff=1,nfiles + + IF (clef_files(iff)) THEN + ndex2d = 0 + ndex3d = 0 + +!!! Champs 1D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF (o_phis%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $ o_phis%name,itau_w,pphis) + ENDIF + + IF (o_aire%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_aire%name,itau_w,airephy) + ENDIF + + IF (o_contfracATM%flag(iff)<=lev_files(iff)) THEN + DO i=1, klon + zx_tmp_fi2d(i)=pctsrf(i,is_ter)+pctsrf(i,is_lic) + ENDDO + CALL histwrite_phy(nid_files(iff), + $ o_contfracATM%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_contfracOR%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_contfracOR%name,itau_w, + $ pctsrf(:,is_ter)) + ENDIF + + IF (o_aireTER%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $ o_aireTER%name,itau_w,paire_ter) + ENDIF + +!!! Champs 2D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + IF (o_flat%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_flat%name,itau_w,zxfluxlat) + ENDIF + + IF (o_slp%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_slp%name,itau_w,slp) + ENDIF + + IF (o_tsol%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_tsol%name,itau_w,zxtsol) + ENDIF + + IF (o_t2m%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_t2m%name,itau_w,zt2m) + ENDIF + + IF (o_t2m_min%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_t2m_min%name,itau_w,zt2m) + ENDIF + + IF (o_t2m_max%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_t2m_max%name,itau_w,zt2m) + ENDIF + + IF (o_wind10m%flag(iff)<=lev_files(iff)) THEN + DO i=1, klon + zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i)) + ENDDO + CALL histwrite_phy(nid_files(iff), + s o_wind10m%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_wind10max%flag(iff)<=lev_files(iff)) THEN + DO i=1, klon + zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i)) + ENDDO + CALL histwrite_phy(nid_files(iff),o_wind10max%name, + $ itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_sicf%flag(iff)<=lev_files(iff)) THEN + DO i = 1, klon + zx_tmp_fi2d(i) = pctsrf(i,is_sic) + ENDDO + CALL histwrite_phy(nid_files(iff), + $ o_sicf%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_q2m%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_q2m%name,itau_w,zq2m) + ENDIF + + IF (o_u10m%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_u10m%name,itau_w,zu10m) + ENDIF + + IF (o_v10m%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_v10m%name,itau_w,zv10m) + ENDIF + + IF (o_psol%flag(iff)<=lev_files(iff)) THEN + DO i = 1, klon + zx_tmp_fi2d(i) = paprs(i,1) + ENDDO + CALL histwrite_phy(nid_files(iff), + s o_psol%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_qsurf%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_qsurf%name,itau_w,zxqsurf) + ENDIF + + if (.not. ok_veget) then + IF (o_qsol%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_qsol%name,itau_w,qsol) + ENDIF + endif + + IF (o_precip%flag(iff)<=lev_files(iff)) THEN + DO i = 1, klon + zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i) + ENDDO + CALL histwrite_phy(nid_files(iff),o_precip%name, + s itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_ndayrain%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_ndayrain%name, + s itau_w,nday_rain) + ENDIF + + IF (o_plul%flag(iff)<=lev_files(iff)) THEN + DO i = 1, klon + zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i) + ENDDO + CALL histwrite_phy(nid_files(iff),o_plul%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_pluc%flag(iff)<=lev_files(iff)) THEN + DO i = 1, klon + zx_tmp_fi2d(i) = rain_con(i) + snow_con(i) + ENDDO + CALL histwrite_phy(nid_files(iff),o_pluc%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_snow%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_snow%name,itau_w,snow_fall) + ENDIF + + IF (o_evap%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_evap%name,itau_w,evap) + ENDIF + + IF (o_tops%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_tops%name,itau_w,topsw) + ENDIF + + IF (o_tops0%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_tops0%name,itau_w,topsw0) + ENDIF + + IF (o_topl%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_topl%name,itau_w,toplw) + ENDIF + + IF (o_topl0%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_topl0%name,itau_w,toplw0) + ENDIF + + IF (o_SWupTOA%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, klevp1 ) + CALL histwrite_phy(nid_files(iff),o_SWupTOA%name, + s itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_SWupTOAclr%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, klevp1 ) + CALL histwrite_phy(nid_files(iff), + $ o_SWupTOAclr%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_SWdnTOA%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, klevp1 ) + CALL histwrite_phy(nid_files(iff), + s o_SWdnTOA%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_SWdnTOAclr%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, klevp1 ) + CALL histwrite_phy(nid_files(iff), + $ o_SWdnTOAclr%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_SWup200%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_SWup200%name,itau_w,SWup200) + ENDIF + + IF (o_SWup200clr%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_SWup200clr%name,itau_w,SWup200clr) + ENDIF + + IF (o_SWdn200%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_SWdn200%name,itau_w,SWdn200) + ENDIF + + IF (o_SWdn200clr%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_SWdn200clr%name,itau_w,SWdn200clr) + ENDIF + + IF (o_LWup200%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_LWup200%name,itau_w,LWup200) + ENDIF + + IF (o_LWup200clr%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_LWup200clr%name,itau_w,LWup200clr) + ENDIF + + IF (o_LWdn200%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_LWdn200%name,itau_w,LWdn200) + ENDIF + + IF (o_LWdn200clr%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_LWdn200clr%name,itau_w,LWdn200clr) + ENDIF + + IF (o_sols%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_sols%name,itau_w,solsw) + ENDIF + + IF (o_sols0%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_sols0%name,itau_w,solsw0) + ENDIF + + IF (o_soll%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_soll%name,itau_w,sollw) + ENDIF + + IF (o_radsol%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_radsol%name,itau_w,radsol) + ENDIF + + IF (o_soll0%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_soll0%name,itau_w,sollw0) + ENDIF + + IF (o_SWupSFC%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, 1 ) + CALL histwrite_phy(nid_files(iff), + s o_SWupSFC%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_SWupSFCclr%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, 1 ) + CALL histwrite_phy(nid_files(iff), + $ o_SWupSFCclr%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_SWdnSFC%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, 1 ) + CALL histwrite_phy(nid_files(iff), + $ o_SWdnSFC%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_SWdnSFCclr%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, 1 ) + CALL histwrite_phy(nid_files(iff), + $ o_SWdnSFCclr%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_LWupSFC%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1:klon)=sollwdown(1:klon)-sollw(1:klon) + CALL histwrite_phy(nid_files(iff), + $ o_LWupSFC%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_LWdnSFC%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $ o_LWdnSFC%name,itau_w,sollwdown) + ENDIF + + sollwdownclr(1:klon) = -1.*lwdn0(1:klon,1) + IF (o_LWupSFCclr%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1:klon)=sollwdownclr(1:klon)-sollw0(1:klon) + CALL histwrite_phy(nid_files(iff), + $ o_LWupSFCclr%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_LWdnSFCclr%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $ o_LWdnSFCclr%name,itau_w,sollwdownclr) + ENDIF + + IF (o_bils%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_bils%name,itau_w,bils) + ENDIF + + IF (o_sens%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1:klon)=-1*sens(1:klon) + CALL histwrite_phy(nid_files(iff),o_sens%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_fder%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_fder%name,itau_w,fder) + ENDIF + + IF (o_ffonte%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_ffonte%name,itau_w,zxffonte) + ENDIF + + IF (o_fqcalving%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $ o_fqcalving%name,itau_w,zxfqcalving) + ENDIF + + IF (o_fqfonte%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $ o_fqfonte%name,itau_w,zxfqfonte) + ENDIF + + DO nsrf = 1, nbsrf +! IF(nsrf.GE.2) THEN + IF (o_pourc_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)*100. + CALL histwrite_phy(nid_files(iff), + $ o_pourc_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_fract_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff), + $ o_fract_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF +! ENDIF !nsrf.GT.2 + + IF (o_taux_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf) + CALL histwrite_phy(nid_files(iff), + $ o_taux_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_tauy_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf) + CALL histwrite_phy(nid_files(iff), + $ o_tauy_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_tsol_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff), + $ o_tsol_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_u10m_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = u10m(1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff),o_u10m_srf(nsrf)%name, + $ itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_v10m_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = v10m(1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff),o_v10m_srf(nsrf)%name, + $ itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_t2m_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = t2m(1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff),o_t2m_srf(nsrf)%name, + $ itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_sens_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf) + CALL histwrite_phy(nid_files(iff), + $ o_sens_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_lat_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff), + $ o_lat_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_flw_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = fsollw( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff), + $ o_flw_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_fsw_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff), + $ o_fsw_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_wbils_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = wfbils( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff), + $ o_wbils_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_wbilo_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = wfbilo( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff), + $ o_wbilo_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + if (iflag_pbl>1 .and. lev_histday.gt.10 ) then + IF (o_tke_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $ o_tke_srf(nsrf)%name,itau_w, + $ pbl_tke(:,1:klev,nsrf)) + ENDIF + + IF (o_tke_max_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $ o_tke_max_srf(nsrf)%name,itau_w, + $ pbl_tke(:,1:klev,nsrf)) + ENDIF + endif + ENDDO + + IF (o_cdrm%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_cdrm%name,itau_w,cdragm) + ENDIF + + IF (o_cdrh%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_cdrh%name,itau_w,cdragh) + ENDIF + + IF (o_cldl%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_cldl%name,itau_w,cldl) + ENDIF + + IF (o_cldm%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_cldm%name,itau_w,cldm) + ENDIF + + IF (o_cldh%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_cldh%name,itau_w,cldh) + ENDIF + + IF (o_cldt%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_cldt%name, + & itau_w,cldt*100) + ENDIF + + IF (o_cldq%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_cldq%name,itau_w,cldq) + ENDIF + + IF (o_lwp%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1:klon) = flwp(1:klon) + CALL histwrite_phy(nid_files(iff), + s o_lwp%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_iwp%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1:klon) = fiwp(1:klon) + CALL histwrite_phy(nid_files(iff), + s o_iwp%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_ue%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_ue%name,itau_w,ue) + ENDIF + + IF (o_ve%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_ve%name,itau_w,ve) + ENDIF + + IF (o_uq%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_uq%name,itau_w,uq) + ENDIF + + IF (o_vq%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_vq%name,itau_w,vq) + ENDIF + + IF(iflag_con.GE.3) THEN ! sb + IF (o_cape%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_cape%name,itau_w,cape) + ENDIF + + IF (o_pbase%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_pbase%name,itau_w,pbase) + ENDIF + + IF (o_ptop%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_ptop%name,itau_w,ema_pct) + ENDIF + + IF (o_fbase%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_fbase%name,itau_w,ema_cbmf) + ENDIF + + IF (o_prw%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_prw%name,itau_w,prw) + ENDIF + + IF (o_cape_max%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_cape_max%name,itau_w,cape) + ENDIF + + IF (o_upwd%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_upwd%name,itau_w,upwd) + ENDIF + + IF (o_Ma%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_Ma%name,itau_w,Ma) + ENDIF + + IF (o_dnwd%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_dnwd%name,itau_w,dnwd) + ENDIF + + IF (o_dnwd0%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_dnwd0%name,itau_w,dnwd0) + ENDIF + + ENDIF !iflag_con .GE. 3 + + IF (o_s_pblh%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_s_pblh%name,itau_w,s_pblh) + ENDIF + + IF (o_s_pblt%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_s_pblt%name,itau_w,s_pblt) + ENDIF + + IF (o_s_lcl%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_s_lcl%name,itau_w,s_lcl) + ENDIF + + IF (o_s_capCL%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_s_capCL%name,itau_w,s_capCL) + ENDIF + + IF (o_s_oliqCL%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_s_oliqCL%name,itau_w,s_oliqCL) + ENDIF + + IF (o_s_cteiCL%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_s_cteiCL%name,itau_w,s_cteiCL) + ENDIF + + IF (o_s_therm%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_s_therm%name,itau_w,s_therm) + ENDIF + + IF (o_s_trmb1%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_s_trmb1%name,itau_w,s_trmb1) + ENDIF + + IF (o_s_trmb2%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_s_trmb2%name,itau_w,s_trmb2) + ENDIF + + IF (o_s_trmb3%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_s_trmb3%name,itau_w,s_trmb3) + ENDIF + +! Champs interpolles sur des niveaux de pression + + ll=0 + DO k=1, nlevSTD +! IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k) +! IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k) + bb2=clevSTD(k) + IF(bb2.EQ."850".OR.bb2.EQ."700".OR. + $ bb2.EQ."500".OR.bb2.EQ."200".OR. + $ bb2.EQ."50".OR.bb2.EQ."10") THEN + +! a refaire correctement !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ll=ll+1 + IF (o_uSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_uSTDlevs(ll)%name, + & itau_w,uwriteSTD(:,k,iff)) + ENDIF + + IF (o_vSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_vSTDlevs(ll)%name, + & itau_w,vwriteSTD(:,k,iff)) + ENDIF + + IF (o_wSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_wSTDlevs(ll)%name, + & itau_w,wwriteSTD(:,k,iff)) + ENDIF + + IF (o_phiSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_phiSTDlevs(ll)%name, + & itau_w,phiwriteSTD(:,k,iff)) + ENDIF + + IF (o_qSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_qSTDlevs(ll)%name, + & itau_w, qwriteSTD(:,k,iff)) + ENDIF + + IF (o_tSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_tSTDlevs(ll)%name, + & itau_w, twriteSTD(:,k,iff)) + ENDIF + + ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR. + ENDDO + + IF (o_t_oce_sic%flag(iff)<=lev_files(iff)) THEN + DO i=1, klon + IF (pctsrf(i,is_oce).GT.epsfra.OR. + $ pctsrf(i,is_sic).GT.epsfra) THEN + zx_tmp_fi2d(i) = (ftsol(i, is_oce) * pctsrf(i,is_oce)+ + $ ftsol(i, is_sic) * pctsrf(i,is_sic))/ + $ (pctsrf(i,is_oce)+pctsrf(i,is_sic)) + ELSE + zx_tmp_fi2d(i) = 273.15 + ENDIF + ENDDO + CALL histwrite_phy(nid_files(iff), + s o_t_oce_sic%name,itau_w,zx_tmp_fi2d) + ENDIF + +! Couplage convection-couche limite + IF (iflag_con.GE.3) THEN + IF (iflag_coupl.EQ.1) THEN + IF (o_ale_bl%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_ale_bl%name,itau_w,ale_bl) + ENDIF + IF (o_alp_bl%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_alp_bl%name,itau_w,alp_bl) + ENDIF + ENDIF !iflag_coupl.EQ.1 + ENDIF !(iflag_con.GE.3) + +! Wakes + IF (iflag_con.EQ.3) THEN + IF (iflag_wake.EQ.1) THEN + IF (o_ale_wk%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_ale_wk%name,itau_w,ale_wake) + ENDIF + IF (o_alp_wk%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_alp_wk%name,itau_w,alp_wake) + ENDIF + + IF (o_ale%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_ale%name,itau_w,ale) + ENDIF + IF (o_alp%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_alp%name,itau_w,alp) + ENDIF + IF (o_cin%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_cin%name,itau_w,cin) + ENDIF + IF (o_wape%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_WAPE%name,itau_w,wake_pe) + ENDIF + IF (o_wake_h%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_wake_h%name,itau_w,wake_h) + ENDIF + + IF (o_wake_s%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_wake_s%name,itau_w,wake_s) + ENDIF + + IF (o_wake_deltat%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_wake_deltat%name, + $ itau_w,wake_deltat) + ENDIF + + IF (o_wake_deltaq%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_wake_deltaq%name, + $ itau_w,wake_deltaq) + ENDIF + + IF (o_wake_omg%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_wake_omg%name,itau_w,wake_omg) + ENDIF + + IF (o_dtwak%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_wake(1:klon,1:klev) + & /pdtphys + CALL histwrite_phy(nid_files(iff), + & o_dtwak%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dqwak%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_wake(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff), + & o_dqwak%name,itau_w,zx_tmp_fi3d) + ENDIF + ENDIF ! iflag_wake.EQ.1 + + IF (o_Vprecip%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_Vprecip%name,itau_w,Vprecip) + ENDIF + + IF (o_ftd%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_ftd%name,itau_w,ftd) + ENDIF + + IF (o_fqd%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_fqd%name,itau_w,fqd) + ENDIF + ENDIF !(iflag_con.EQ.3) + + IF (type_ocean=='slab ') THEN + IF ( o_slab_bils%flag(iff)<=lev_files(iff)) + $ CALL histwrite_phy( + $ nid_files(iff),o_slab_bils%name,itau_w,slab_wfbils) + + ENDIF !type_ocean == force/slab + + IF (o_weakinv%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_weakinv%name,itau_w,weak_inversion) + ENDIF + + IF (o_dthmin%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_dthmin%name,itau_w,dthmin) + ENDIF + + IF (o_cldtau%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_cldtau%name,itau_w,cldtau) + ENDIF + + IF (o_cldemi%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_cldemi%name,itau_w,cldemi) + ENDIF + + IF (o_pr_con_l%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_pr_con_l%name,itau_w,pmflxr(:,1:klev)) + ENDIF + + IF (o_pr_con_i%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_pr_con_i%name,itau_w,pmflxs(:,1:klev)) + ENDIF + + IF (o_pr_lsc_l%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_pr_lsc_l%name,itau_w,prfl(:,1:klev)) + ENDIF + + IF (o_pr_lsc_i%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_pr_lsc_i%name,itau_w,psfl(:,1:klev)) + ENDIF + + + IF (o_rh2m%flag(iff)<=lev_files(iff)) THEN + DO i=1, klon + zx_tmp_fi2d(i)=MIN(100.,rh2m(i)*100.) + ENDDO + CALL histwrite_phy(nid_files(iff),o_rh2m%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_qsat2m%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_qsat2m%name,itau_w,qsat2m) + ENDIF + + IF (o_tpot%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_tpot%name,itau_w,tpot) + ENDIF + + IF (o_tpote%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_tpote%name,itau_w,tpote) + ENDIF + + IF (o_SWnetOR%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, is_ter) + CALL histwrite_phy(nid_files(iff), + s o_SWnetOR%name,itau_w, zx_tmp_fi2d) + ENDIF + + IF (o_SWdownOR%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1:klon) = solsw(1:klon)/(1.-albsol1(1:klon)) + CALL histwrite_phy(nid_files(iff), + s o_SWdownOR%name,itau_w, zx_tmp_fi2d) + ENDIF + + IF (o_LWdownOR%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_LWdownOR%name,itau_w,sollwdown) + ENDIF + + IF (o_snowl%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_snowl%name,itau_w,snow_lsc) + ENDIF + + IF (o_solldown%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_solldown%name,itau_w,sollwdown) + ENDIF + + IF (o_dtsvdfo%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_dtsvdfo%name,itau_w,d_ts(:,is_oce)) + ENDIF + + IF (o_dtsvdft%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_dtsvdft%name,itau_w,d_ts(:,is_ter)) + ENDIF + + IF (o_dtsvdfg%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $ o_dtsvdfg%name,itau_w, d_ts(:,is_lic)) + ENDIF + + IF (o_dtsvdfi%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_dtsvdfi%name,itau_w,d_ts(:,is_sic)) + ENDIF + + IF (o_rugs%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_rugs%name,itau_w,zxrugs) + ENDIF + +! OD550 per species + IF (new_aod .and. (.not. aerosol_couple)) THEN + DO naero = 1, naero_spc + IF (o_tausumaero(naero)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $ o_tausumaero(naero)%name,itau_w, + $ tausum_aero(:,2,naero) ) + ENDIF + END DO + ENDIF + + IF (ok_ade) THEN + IF (o_topswad%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_topswad%name,itau_w, + $ topswad_aero) + ENDIF + IF (o_solswad%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_solswad%name,itau_w, + $ solswad_aero) + ENDIF + +!====MS forcing diagnostics + if (new_aod) then + IF (o_swtoaas_nat%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_swtoaas_nat%name,itau_w, + $ topsw_aero(:,1)) + ENDIF + + IF (o_swsrfas_nat%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_swsrfas_nat%name,itau_w, + $ solsw_aero(:,1)) + ENDIF + + IF (o_swtoacs_nat%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_swtoacs_nat%name,itau_w, + $ topsw0_aero(:,1)) + ENDIF + + IF (o_swsrfcs_nat%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_swsrfcs_nat%name,itau_w, + $ solsw0_aero(:,1)) + ENDIF + +!ant + IF (o_swtoaas_ant%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_swtoaas_ant%name,itau_w, + $ topsw_aero(:,2)) + ENDIF + + IF (o_swsrfas_ant%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_swsrfas_ant%name,itau_w, + $ solsw_aero(:,2)) + ENDIF + + IF (o_swtoacs_ant%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_swtoacs_ant%name,itau_w, + $ topsw0_aero(:,2)) + ENDIF + + IF (o_swsrfcs_ant%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_swsrfcs_ant%name,itau_w, + $ solsw0_aero(:,2)) + ENDIF + +!cf + + if (.not. aerosol_couple) then + IF (o_swtoacf_nat%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_swtoacf_nat%name,itau_w, + $ topswcf_aero(:,1)) + ENDIF + + IF (o_swsrfcf_nat%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_swsrfcf_nat%name,itau_w, + $ solswcf_aero(:,1)) + ENDIF + + IF (o_swtoacf_ant%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_swtoacf_ant%name,itau_w, + $ topswcf_aero(:,2)) + ENDIF + + IF (o_swsrfcf_ant%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_swsrfcf_ant%name,itau_w, + $ solswcf_aero(:,2)) + ENDIF + + IF (o_swtoacf_zero%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_swtoacf_zero%name,itau_w, + $ topswcf_aero(:,3)) + ENDIF + + IF (o_swsrfcf_zero%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_swsrfcf_zero%name,itau_w, + $ solswcf_aero(:,3)) + ENDIF + endif + + endif ! new_aod +!====MS forcing diagnostics + + ENDIF + + IF (ok_aie) THEN + IF (o_topswai%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_topswai%name,itau_w, + $ topswai_aero) + ENDIF + IF (o_solswai%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_solswai%name,itau_w, + $ solswai_aero) + ENDIF + ENDIF + +! Champs 3D: + IF (o_lwcon%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_lwcon%name,itau_w,flwc) + ENDIF + + IF (o_iwcon%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_iwcon%name,itau_w,fiwc) + ENDIF + + IF (o_temp%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_temp%name,itau_w,t_seri) + ENDIF + + IF (o_theta%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_theta%name,itau_w,theta) + ENDIF + + IF (o_ovap%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_ovap%name,itau_w,qx(:,:,ivap)) + ENDIF + + IF (o_ovapinit%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $ o_ovapinit%name,itau_w,q_seri) + ENDIF + + IF (o_geop%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_geop%name,itau_w,zphi) + ENDIF + + IF (o_vitu%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_vitu%name,itau_w,u_seri) + ENDIF + + IF (o_vitv%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_vitv%name,itau_w,v_seri) + ENDIF + + IF (o_vitw%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_vitw%name,itau_w,omega) + ENDIF + + IF (o_pres%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_pres%name,itau_w,pplay) + ENDIF + + IF (o_rneb%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_rneb%name,itau_w,cldfra) + ENDIF + + IF (o_rnebcon%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_rnebcon%name,itau_w,rnebcon) + ENDIF + + IF (o_rhum%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_rhum%name,itau_w,zx_rh) + ENDIF + + IF (o_ozone%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), o_ozone%name, itau_w, + $ wo(:, :, 1) * dobson_u * 1e3 / zmasse / rmo3 * rmd) + ENDIF + + IF (o_ozone_light%flag(iff)<=lev_files(iff) .and. + $ read_climoz == 2) THEN + CALL histwrite_phy(nid_files(iff), o_ozone_light%name, itau_w, + $ wo(:, :, 2) * dobson_u * 1e3 / zmasse / rmo3 * rmd) + ENDIF + + IF (o_dtphy%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_dtphy%name,itau_w,d_t) + ENDIF + + IF (o_dqphy%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_dqphy%name,itau_w, d_qx(:,:,ivap)) + ENDIF + + DO nsrf=1, nbsrf + IF (o_albe_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = falb1( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff), + s o_albe_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_rugs_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff), + s o_rugs_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_ages_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = agesno( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff), + s o_ages_srf(nsrf)%name,itau_w + $ ,zx_tmp_fi2d) + ENDIF + ENDDO !nsrf=1, nbsrf + + IF (o_albs%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_albs%name,itau_w,albsol1) + ENDIF + + IF (o_albslw%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_albslw%name,itau_w,albsol2) + ENDIF + +!FH Sorties pour la couche limite + if (iflag_pbl>1) then + zx_tmp_fi3d=0. + do nsrf=1,nbsrf + do k=1,klev + zx_tmp_fi3d(:,k)=zx_tmp_fi3d(:,k) + $ +pctsrf(:,nsrf)*pbl_tke(:,k,nsrf) + enddo + enddo + IF (o_tke%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_tke%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_tke_max%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_tke_max%name,itau_w,zx_tmp_fi3d) + ENDIF + endif + + IF (o_kz%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_kz%name,itau_w,coefh) + ENDIF + + IF (o_kz_max%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_kz_max%name,itau_w,coefh) + ENDIF + + IF (o_clwcon%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_clwcon%name,itau_w,clwcon0) + ENDIF + + IF (o_dtdyn%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_dtdyn%name,itau_w,d_t_dyn) + ENDIF + + IF (o_dqdyn%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_dqdyn%name,itau_w,d_q_dyn) + ENDIF + + IF (o_dudyn%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_dudyn%name,itau_w,d_u_dyn) + ENDIF + + IF (o_dvdyn%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_dvdyn%name,itau_w,d_v_dyn) + ENDIF + + IF (o_dtcon%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_dtcon%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_ducon%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_u_con(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_ducon%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dqcon%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_dqcon%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtlsc%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_lsc(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_dtlsc%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtlschr%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon, 1:klev)=(d_t_lsc(1:klon,1:klev)+ + $ d_t_eva(1:klon,1:klev))/pdtphys + CALL histwrite_phy(nid_files(iff), + s o_dtlschr%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dqlsc%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_lsc(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_dqlsc%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtvdf%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_vdf(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_dtvdf%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dqvdf%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_vdf(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_dqvdf%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dteva%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_eva(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_dteva%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dqeva%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_eva(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_dqeva%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_ptconv%flag(iff)<=lev_files(iff)) THEN + zpt_conv = 0. + where (ptconv) zpt_conv = 1. + CALL histwrite_phy(nid_files(iff),o_ptconv%name,itau_w,zpt_conv) + ENDIF + + IF (o_ratqs%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_ratqs%name,itau_w,ratqs) + ENDIF + + IF (o_dtthe%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_ajs(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_dtthe%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (iflag_thermals.gt.1) THEN + IF (o_f_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_f_th%name,itau_w,fm_therm) + ENDIF + + IF (o_e_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_e_th%name,itau_w,entr_therm) + ENDIF + + IF (o_w_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_w_th%name,itau_w,zw2) + ENDIF + + IF (o_q_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_q_th%name,itau_w,zqasc) + ENDIF + + IF (o_lambda_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_lambda_th%name,itau_w,lambda_th) + ENDIF + + IF (o_a_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_a_th%name,itau_w,fraca) + ENDIF + + IF (o_d_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_d_th%name,itau_w,detr_therm) + ENDIF + + ENDIF !iflag_thermals + + IF (o_f0_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_f0_th%name,itau_w,f0) + ENDIF + + IF (o_f0_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),o_zmax_th%name,itau_w,zmax0) + ENDIF + + IF (o_dqthe%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_ajs(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_dqthe%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtajs%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_ajsb(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_dtajs%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dqajs%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_ajsb(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_dqajs%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtswr%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=heat(1:klon,1:klev)/RDAY + CALL histwrite_phy(nid_files(iff),o_dtswr%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtsw0%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=heat0(1:klon,1:klev)/RDAY + CALL histwrite_phy(nid_files(iff),o_dtsw0%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtlwr%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=-1.*cool(1:klon,1:klev)/RDAY + CALL histwrite_phy(nid_files(iff),o_dtlwr%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtlw0%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=-1.*cool0(1:klon,1:klev)/RDAY + CALL histwrite_phy(nid_files(iff),o_dtlw0%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtec%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_ec(1:klon,1:klev) + CALL histwrite_phy(nid_files(iff),o_dtec%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_duvdf%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_u_vdf(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_duvdf%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dvvdf%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_v_vdf(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_dvvdf%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (ok_orodr) THEN + IF (o_duoro%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_u_oro(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_duoro%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dvoro%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_v_oro(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_dvoro%name,itau_w,zx_tmp_fi3d) + ENDIF + ENDIF + + IF (ok_orolf) THEN + IF (o_dulif%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_u_lif(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_dulif%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dvlif%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_v_lif(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),o_dvlif%name,itau_w,zx_tmp_fi3d) + ENDIF + ENDIF + +! IF (o_trac%flag(iff)<=lev_files(iff)) THEN + if (nqtot.GE.3) THEN +! DO iq=3,nqtot + DO iq=3,4 + IF (o_trac(iq-2)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + s o_trac(iq-2)%name,itau_w,qx(:,:,iq)) + ENDIF + ENDDO + endif + + if (ok_sync) then +c$OMP MASTER + call histsync(nid_files(iff)) +c$OMP END MASTER + endif + + ENDIF ! clef_files + + ENDDO ! iff=1,nfiles Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phys_state_var_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phys_state_var_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phys_state_var_mod.F90 (revision 1280) @@ -0,0 +1,497 @@ + MODULE phys_state_var_mod +! Variables sauvegardees pour le startphy.nc +!====================================================================== +! +! +!====================================================================== +! Declaration des variables + USE dimphy + INTEGER, PARAMETER :: nlevSTD=17 + INTEGER, PARAMETER :: nout=3 + INTEGER, PARAMETER :: napisccp=1 + INTEGER, SAVE :: radpas + REAL, SAVE :: dtime, solaire_etat0 +!$OMP THREADPRIVATE(radpas) +!$OMP THREADPRIVATE(dtime, solaire_etat0) + + REAL, ALLOCATABLE, SAVE :: rlat(:), rlon(:), pctsrf(:,:) +!$OMP THREADPRIVATE(rlat, rlon, pctsrf) + REAL, ALLOCATABLE, SAVE :: ftsol(:,:) +!$OMP THREADPRIVATE(ftsol) +! character(len=6), SAVE :: ocean +!!!!!!$OMP THREADPRIVATE(ocean) +! logical, SAVE :: ok_veget +!!!!!!$OMP THREADPRIVATE(ok_veget) + REAL, ALLOCATABLE, SAVE :: falb1(:,:), falb2(:,:) +!$OMP THREADPRIVATE(falb1, falb2) + REAL, ALLOCATABLE, SAVE :: rain_fall(:), snow_fall(:) +!$OMP THREADPRIVATE( rain_fall, snow_fall) + REAL, ALLOCATABLE, SAVE :: solsw(:), sollw(:) +!$OMP THREADPRIVATE(solsw, sollw) + REAL, ALLOCATABLE, SAVE :: radsol(:) +!$OMP THREADPRIVATE(radsol) + +!clesphy0 param physiq +! +! Parametres de l'Orographie a l'Echelle Sous-Maille (OESM): +! + REAL, ALLOCATABLE, SAVE :: zmea(:), zstd(:), zsig(:), zgam(:) +!$OMP THREADPRIVATE(zmea, zstd, zsig, zgam) + REAL, ALLOCATABLE, SAVE :: zthe(:), zpic(:), zval(:) +!$OMP THREADPRIVATE(zthe, zpic, zval) +! REAL tabcntr0(100) + REAL, ALLOCATABLE, SAVE :: rugoro(:) +!$OMP THREADPRIVATE(rugoro) + REAL, ALLOCATABLE, SAVE :: t_ancien(:,:), q_ancien(:,:) +!$OMP THREADPRIVATE(t_ancien, q_ancien) + REAL, ALLOCATABLE, SAVE :: u_ancien(:,:), v_ancien(:,:) +!$OMP THREADPRIVATE(u_ancien, v_ancien) + LOGICAL, SAVE :: ancien_ok +!$OMP THREADPRIVATE(ancien_ok) + REAL, ALLOCATABLE, SAVE :: clwcon(:,:),rnebcon(:,:) +!$OMP THREADPRIVATE(clwcon,rnebcon) + REAL, ALLOCATABLE, SAVE :: ratqs(:,:) +!$OMP THREADPRIVATE(ratqs) + REAL, ALLOCATABLE, SAVE :: pbl_tke(:,:,:) ! turb kinetic energy +!$OMP THREADPRIVATE(pbl_tke) + REAL, ALLOCATABLE, SAVE :: zmax0(:), f0(:) ! +!$OMP THREADPRIVATE(zmax0,f0) + REAL, ALLOCATABLE, SAVE :: ema_work1(:,:), ema_work2(:,:) +!$OMP THREADPRIVATE(ema_work1,ema_work2) + REAL, ALLOCATABLE, SAVE :: entr_therm(:,:), fm_therm(:,:) +!$OMP THREADPRIVATE(entr_therm,fm_therm) + REAL, ALLOCATABLE, SAVE :: detr_therm(:,:) +!$OMP THREADPRIVATE(detr_therm) +!IM 150408 +! pour phsystoke avec thermiques + REAL,ALLOCATABLE,SAVE :: clwcon0th(:,:),rnebcon0th(:,:) +!$OMP THREADPRIVATE(clwcon0th,rnebcon0th) +! radiation outputs + REAL,ALLOCATABLE,SAVE :: swdn0(:,:), swdn(:,:) +!$OMP THREADPRIVATE(swdn0,swdn) + REAL,ALLOCATABLE,SAVE :: swup0(:,:), swup(:,:) +!$OMP THREADPRIVATE(swup0,swup) + REAL,ALLOCATABLE,SAVE :: SWdn200clr(:), SWdn200(:) +!$OMP THREADPRIVATE(SWdn200clr,SWdn200) + REAL,ALLOCATABLE,SAVE :: SWup200clr(:), SWup200(:) +!$OMP THREADPRIVATE(SWup200clr,SWup200) + REAL,ALLOCATABLE,SAVE :: lwdn0(:,:), lwdn(:,:) +!$OMP THREADPRIVATE(lwdn0,lwdn) + REAL,ALLOCATABLE,SAVE :: lwup0(:,:), lwup(:,:) +!$OMP THREADPRIVATE(lwup0,lwup) + REAL,ALLOCATABLE,SAVE :: LWdn200clr(:), LWdn200(:) +!$OMP THREADPRIVATE(LWdn200clr,LWdn200) + REAL,ALLOCATABLE,SAVE :: LWup200clr(:), LWup200(:) +!$OMP THREADPRIVATE(LWup200clr,LWup200) + REAL,ALLOCATABLE,SAVE :: LWdnTOA(:), LWdnTOAclr(:) +!$OMP THREADPRIVATE(LWdnTOA,LWdnTOAclr) +! pressure level + REAL,ALLOCATABLE,SAVE :: tsumSTD(:,:,:) +!$OMP THREADPRIVATE(tsumSTD) + REAL,ALLOCATABLE,SAVE :: usumSTD(:,:,:), vsumSTD(:,:,:) +!$OMP THREADPRIVATE(usumSTD,vsumSTD) + REAL,ALLOCATABLE,SAVE :: wsumSTD(:,:,:), phisumSTD(:,:,:) +!$OMP THREADPRIVATE(wsumSTD,phisumSTD) + REAL,ALLOCATABLE,SAVE :: qsumSTD(:,:,:), rhsumSTD(:,:,:) +!$OMP THREADPRIVATE(qsumSTD,rhsumSTD) + REAL,ALLOCATABLE,SAVE :: tnondef(:,:,:) +!$OMP THREADPRIVATE(tnondef) + REAL,ALLOCATABLE,SAVE :: uvsumSTD(:,:,:) +!$OMP THREADPRIVATE(uvsumSTD) + REAL,ALLOCATABLE,SAVE :: vqsumSTD(:,:,:) +!$OMP THREADPRIVATE(vqsumSTD) + REAL,ALLOCATABLE,SAVE :: vTsumSTD(:,:,:) +!$OMP THREADPRIVATE(vTsumSTD) + REAL,ALLOCATABLE,SAVE :: wqsumSTD(:,:,:) +!$OMP THREADPRIVATE(wqsumSTD) + REAL,ALLOCATABLE,SAVE :: vphisumSTD(:,:,:) +!$OMP THREADPRIVATE(vphisumSTD) + REAL,ALLOCATABLE,SAVE :: wTsumSTD(:,:,:) +!$OMP THREADPRIVATE(wTsumSTD) + REAL,ALLOCATABLE,SAVE :: u2sumSTD(:,:,:) +!$OMP THREADPRIVATE(u2sumSTD) + REAL,ALLOCATABLE,SAVE :: v2sumSTD(:,:,:) +!$OMP THREADPRIVATE(v2sumSTD) + REAL,ALLOCATABLE,SAVE :: T2sumSTD(:,:,:) +!$OMP THREADPRIVATE(T2sumSTD) + INTEGER,ALLOCATABLE,SAVE :: seed_old(:,:) +!$OMP THREADPRIVATE(seed_old) + REAL,ALLOCATABLE,SAVE :: zuthe(:),zvthe(:) +!$OMP THREADPRIVATE(zuthe,zvthe) + REAL,ALLOCATABLE,SAVE :: alb_neig(:) +!$OMP THREADPRIVATE(alb_neig) +!cloud base mass flux + REAL,ALLOCATABLE,SAVE :: ema_workcbmf(:), ema_cbmf(:) +!$OMP THREADPRIVATE(ema_workcbmf,ema_cbmf) +!cloud base pressure & cloud top pressure + REAL,ALLOCATABLE,SAVE :: ema_pcb(:), ema_pct(:) +!$OMP THREADPRIVATE(ema_pcb,ema_pct) + REAL,ALLOCATABLE,SAVE :: Ma(:,:) ! undilute upward mass flux +!$OMP THREADPRIVATE(Ma) + REAL,ALLOCATABLE,SAVE :: qcondc(:,:) ! in-cld water content from convect +!$OMP THREADPRIVATE(qcondc) + REAL,ALLOCATABLE,SAVE :: wd(:) ! sb +!$OMP THREADPRIVATE(wd) + REAL,ALLOCATABLE,SAVE :: sigd(:) +!$OMP THREADPRIVATE(sigd) +! + REAL,ALLOCATABLE,SAVE :: cin(:) +!$OMP THREADPRIVATE(cin) +! ftd : differential heating between wake and environment + REAL,ALLOCATABLE,SAVE :: ftd(:,:) +!$OMP THREADPRIVATE(ftd) +! fqd : differential moistening between wake and environment + REAL,ALLOCATABLE,SAVE :: fqd(:,:) +!$OMP THREADPRIVATE(fqd) +!34EK +! -- Variables de controle de ALE et ALP +!ALE : Energie disponible pour soulevement : utilisee par la +! convection d'Emanuel pour le declenchement et la regulation + REAL,ALLOCATABLE,SAVE :: ALE(:) +!$OMP THREADPRIVATE(ALE) +!ALP : Puissance disponible pour soulevement + REAL,ALLOCATABLE,SAVE :: ALP(:) +!$OMP THREADPRIVATE(ALP) +! +! nouvelles variables pour le couplage convection-couche limite + REAL,ALLOCATABLE,SAVE :: Ale_bl(:) +!$OMP THREADPRIVATE(Ale_bl) + REAL,ALLOCATABLE,SAVE :: Alp_bl(:) +!$OMP THREADPRIVATE(Alp_bl) + INTEGER,ALLOCATABLE,SAVE :: lalim_conv(:) +!$OMP THREADPRIVATE(lalim_conv) + REAL,ALLOCATABLE,SAVE :: wght_th(:,:) +!$OMP THREADPRIVATE(wght_th) +! +! variables de la wake +! wake_deltat : ecart de temperature avec la zone non perturbee +! wake_deltaq : ecart d'humidite avec la zone non perturbee +! wake_Cstar : vitesse d'etalement de la poche +! wake_s : fraction surfacique occupee par la poche froide +! wake_fip : Gust Front Impinging power - ALP +! dt_wake, dq_wake: LS tendencies due to wake + REAL,ALLOCATABLE,SAVE :: wake_deltat(:,:) +!$OMP THREADPRIVATE(wake_deltat) + REAL,ALLOCATABLE,SAVE :: wake_deltaq(:,:) +!$OMP THREADPRIVATE(wake_deltaq) + REAL,ALLOCATABLE,SAVE :: wake_Cstar(:) +!$OMP THREADPRIVATE(wake_Cstar) + REAL,ALLOCATABLE,SAVE :: wake_s(:) +!$OMP THREADPRIVATE(wake_s) + REAL,ALLOCATABLE,SAVE :: wake_fip(:) +!$OMP THREADPRIVATE(wake_fip) + REAL,ALLOCATABLE,SAVE :: dt_wake(:,:) +!$OMP THREADPRIVATE(dt_wake) + REAL,ALLOCATABLE,SAVE :: dq_wake(:,:) +!$OMP THREADPRIVATE(dq_wake) +! +! pfrac_impa : Produits des coefs lessivage impaction +! pfrac_nucl : Produits des coefs lessivage nucleation +! pfrac_1nucl: Produits des coefs lessi nucl (alpha = 1) + REAL,ALLOCATABLE,SAVE :: pfrac_impa(:,:), pfrac_nucl(:,:) +!$OMP THREADPRIVATE(pfrac_impa,pfrac_nucl) + REAL,ALLOCATABLE,SAVE :: pfrac_1nucl(:,:) +!$OMP THREADPRIVATE(pfrac_1nucl) +! + REAL,ALLOCATABLE,SAVE :: total_rain(:), nday_rain(:) +!$OMP THREADPRIVATE(total_rain,nday_rain) + REAL,ALLOCATABLE,SAVE :: paire_ter(:) +!$OMP THREADPRIVATE(paire_ter) +! albsol1: albedo du sol total pour SW visible +! albsol2: albedo du sol total pour SW proche IR + REAL,ALLOCATABLE,SAVE :: albsol1(:), albsol2(:) +!$OMP THREADPRIVATE(albsol1,albsol2) + + REAL, ALLOCATABLE, SAVE:: wo(:, :, :) + ! column-density of ozone in a layer, in kilo-Dobsons + ! Third dimension has size 1 or 2. + ! "wo(:, :, 1)" is for the average day-night field, + ! "wo(:, :, 2)" is for daylight time. + !$OMP THREADPRIVATE(wo) + +! heat : chauffage solaire +! heat0: chauffage solaire ciel clair +! cool : refroidissement infrarouge +! cool0 : refroidissement infrarouge ciel clair +! sollwdown : downward LW flux at surface +! sollwdownclr : downward CS LW flux at surface +! toplwdown : downward CS LW flux at TOA +! toplwdownclr : downward CS LW flux at TOA + REAL,ALLOCATABLE,SAVE :: clwcon0(:,:),rnebcon0(:,:) +!$OMP THREADPRIVATE(clwcon0,rnebcon0) + REAL,ALLOCATABLE,SAVE :: heat(:,:) +!$OMP THREADPRIVATE(heat) + REAL,ALLOCATABLE,SAVE :: heat0(:,:) +!$OMP THREADPRIVATE(heat0) + REAL,ALLOCATABLE,SAVE :: cool(:,:) +!$OMP THREADPRIVATE(cool) + REAL,ALLOCATABLE,SAVE :: cool0(:,:) +!$OMP THREADPRIVATE(cool0) + REAL,ALLOCATABLE,SAVE :: topsw(:), toplw(:) +!$OMP THREADPRIVATE(topsw,toplw) + REAL,ALLOCATABLE,SAVE :: sollwdown(:) +!$OMP THREADPRIVATE(sollwdown) + REAL,ALLOCATABLE,SAVE :: sollwdownclr(:) +!$OMP THREADPRIVATE(sollwdownclr) + REAL,ALLOCATABLE,SAVE :: toplwdown(:) +!$OMP THREADPRIVATE(toplwdown) + REAL,ALLOCATABLE,SAVE :: toplwdownclr(:) +!$OMP THREADPRIVATE(toplwdownclr) + REAL,ALLOCATABLE,SAVE :: topsw0(:),toplw0(:),solsw0(:),sollw0(:) +!$OMP THREADPRIVATE(topsw0,toplw0,solsw0,sollw0) + REAL,ALLOCATABLE,SAVE :: albpla(:) +!$OMP THREADPRIVATE(albpla) +! pbase : cloud base pressure +! bbase : cloud base buoyancy + REAL,ALLOCATABLE,SAVE :: cape(:) +!$OMP THREADPRIVATE(cape) + REAL,ALLOCATABLE,SAVE :: pbase(:) +!$OMP THREADPRIVATE(pbase) + REAL,ALLOCATABLE,SAVE :: bbase(:) +!$OMP THREADPRIVATE(bbase) +! + REAL,SAVE,ALLOCATABLE :: zqasc(:,:) +!$OMP THREADPRIVATE( zqasc) + INTEGER,ALLOCATABLE,SAVE :: ibas_con(:), itop_con(:) +!$OMP THREADPRIVATE(ibas_con,itop_con) + REAL,SAVE,ALLOCATABLE :: rain_con(:) +!$OMP THREADPRIVATE(rain_con) + REAL,SAVE,ALLOCATABLE :: snow_con(:) +!$OMP THREADPRIVATE(snow_con) +! + REAL,SAVE,ALLOCATABLE :: rlonPOS(:) +!$OMP THREADPRIVATE(rlonPOS) + REAL,SAVE,ALLOCATABLE :: newsst(:) +!$OMP THREADPRIVATE(newsst) + REAL,SAVE,ALLOCATABLE :: u10m(:,:), v10m(:,:) +!$OMP THREADPRIVATE(u10m,v10m) +! +! ok_ade=T -ADE=topswad-topsw +! ok_aie=T -> +! ok_ade=T -AIE=topswai-topswad +! ok_ade=F -AIE=topswai-topsw +! +!topswad, solswad : Aerosol direct effect + REAL,SAVE,ALLOCATABLE :: topswad(:), solswad(:) +!$OMP THREADPRIVATE(topswad,solswad) +!topswai, solswai : Aerosol indirect effect + REAL,SAVE,ALLOCATABLE :: topswai(:), solswai(:) +!$OMP THREADPRIVATE(topswai,solswai) + + REAL,SAVE,ALLOCATABLE :: tau_aero(:,:,:,:), piz_aero(:,:,:,:), cg_aero(:,:,:,:) +!$OMP THREADPRIVATE(tau_aero, piz_aero, cg_aero) + REAL,SAVE,ALLOCATABLE :: ccm(:,:,:) +!$OMP THREADPRIVATE(ccm) + +CONTAINS + +!====================================================================== +SUBROUTINE phys_state_var_init(read_climoz) +use dimphy +use aero_mod +IMPLICIT NONE + +integer, intent(in):: read_climoz +! read ozone climatology +! Allowed values are 0, 1 and 2 +! 0: do not read an ozone climatology +! 1: read a single ozone climatology that will be used day and night +! 2: read two ozone climatologies, the average day and night +! climatology and the daylight climatology + +#include "indicesol.h" +#include "control.h" + ALLOCATE(rlat(klon), rlon(klon)) + ALLOCATE(pctsrf(klon,nbsrf)) + ALLOCATE(ftsol(klon,nbsrf)) + ALLOCATE(falb1(klon,nbsrf)) + ALLOCATE(falb2(klon,nbsrf)) + ALLOCATE(rain_fall(klon)) + ALLOCATE(snow_fall(klon)) + ALLOCATE(solsw(klon), sollw(klon)) + ALLOCATE(radsol(klon)) + ALLOCATE(zmea(klon), zstd(klon), zsig(klon), zgam(klon)) + ALLOCATE(zthe(klon), zpic(klon), zval(klon)) + + ALLOCATE(rugoro(klon)) + ALLOCATE(t_ancien(klon,klev), q_ancien(klon,klev)) + ALLOCATE(u_ancien(klon,klev), v_ancien(klon,klev)) + ALLOCATE(clwcon(klon,klev),rnebcon(klon,klev)) + ALLOCATE(ratqs(klon,klev)) + ALLOCATE(pbl_tke(klon,klev+1,nbsrf)) + ALLOCATE(zmax0(klon), f0(klon)) + ALLOCATE(ema_work1(klon,klev), ema_work2(klon,klev)) + ALLOCATE(entr_therm(klon,klev), fm_therm(klon,klev+1)) + ALLOCATE(detr_therm(klon,klev)) +! pour phsystoke avec thermiques + ALLOCATE(clwcon0th(klon,klev),rnebcon0th(klon,klev)) +! radiation outputs + ALLOCATE(swdn0(klon,klevp1), swdn(klon,klevp1)) + ALLOCATE(swup0(klon,klevp1), swup(klon,klevp1)) + ALLOCATE(lwdn0(klon,klevp1), lwdn(klon,klevp1)) + ALLOCATE(lwup0(klon,klevp1), lwup(klon,klevp1)) + ALLOCATE(SWdn200clr(klon), SWdn200(klon)) + ALLOCATE(SWup200clr(klon), SWup200(klon)) + ALLOCATE(LWdn200clr(klon), LWdn200(klon)) + ALLOCATE(LWup200clr(klon), LWup200(klon)) + ALLOCATE(LWdnTOA(klon), LWdnTOAclr(klon)) +! pressure level + ALLOCATE(tsumSTD(klon,nlevSTD,nout)) + ALLOCATE(usumSTD(klon,nlevSTD,nout), vsumSTD(klon,nlevSTD,nout)) + ALLOCATE(wsumSTD(klon,nlevSTD,nout), phisumSTD(klon,nlevSTD,nout)) + ALLOCATE(qsumSTD(klon,nlevSTD,nout), rhsumSTD(klon,nlevSTD,nout)) + ALLOCATE(tnondef(klon,nlevSTD,nout)) + ALLOCATE(uvsumSTD(klon,nlevSTD,nout)) + ALLOCATE(vqsumSTD(klon,nlevSTD,nout)) + ALLOCATE(vTsumSTD(klon,nlevSTD,nout)) + ALLOCATE(wqsumSTD(klon,nlevSTD,nout)) + ALLOCATE(vphisumSTD(klon,nlevSTD,nout)) + ALLOCATE(wTsumSTD(klon,nlevSTD,nout)) + ALLOCATE(u2sumSTD(klon,nlevSTD,nout)) + ALLOCATE(v2sumSTD(klon,nlevSTD,nout)) + ALLOCATE(T2sumSTD(klon,nlevSTD,nout)) + ALLOCATE(seed_old(klon,napisccp)) + ALLOCATE(zuthe(klon),zvthe(klon)) + ALLOCATE(alb_neig(klon)) +!cloud base mass flux + ALLOCATE(ema_workcbmf(klon), ema_cbmf(klon)) +!cloud base pressure & cloud top pressure + ALLOCATE(ema_pcb(klon), ema_pct(klon)) +! + ALLOCATE(Ma(klon,klev)) + ALLOCATE(qcondc(klon,klev)) + ALLOCATE(wd(klon)) + ALLOCATE(sigd(klon)) + ALLOCATE(cin(klon), ALE(klon), ALP(klon)) + ALLOCATE(ftd(klon,klev), fqd(klon,klev)) + ALLOCATE(Ale_bl(klon)) + ALLOCATE(Alp_bl(klon)) + ALLOCATE(lalim_conv(klon)) + ALLOCATE(wght_th(klon,klev)) + ALLOCATE(wake_deltat(klon,klev), wake_deltaq(klon,klev)) + ALLOCATE(wake_Cstar(klon), wake_s(klon), wake_fip(klon)) + ALLOCATE(dt_wake(klon,klev), dq_wake(klon,klev)) + ALLOCATE(pfrac_impa(klon,klev), pfrac_nucl(klon,klev)) + ALLOCATE(pfrac_1nucl(klon,klev)) + ALLOCATE(total_rain(klon), nday_rain(klon)) + ALLOCATE(paire_ter(klon)) + ALLOCATE(albsol1(klon), albsol2(klon)) + + if (read_climoz <= 1) then + ALLOCATE(wo(klon,klev, 1)) + else + ! read_climoz == 2 + ALLOCATE(wo(klon,klev, 2)) + end if + + ALLOCATE(clwcon0(klon,klev),rnebcon0(klon,klev)) + ALLOCATE(heat(klon,klev), heat0(klon,klev)) + ALLOCATE(cool(klon,klev), cool0(klon,klev)) + ALLOCATE(topsw(klon), toplw(klon)) + ALLOCATE(sollwdown(klon), sollwdownclr(klon)) + ALLOCATE(toplwdown(klon), toplwdownclr(klon)) + ALLOCATE(topsw0(klon),toplw0(klon),solsw0(klon),sollw0(klon)) + ALLOCATE(albpla(klon)) + ALLOCATE(cape(klon)) + ALLOCATE(pbase(klon),bbase(klon)) + ALLOCATE(zqasc(klon,klev)) + ALLOCATE(ibas_con(klon), itop_con(klon)) + ALLOCATE(rain_con(klon), snow_con(klon)) + ALLOCATE(rlonPOS(klon)) + ALLOCATE(newsst(klon)) + ALLOCATE(u10m(klon,nbsrf), v10m(klon,nbsrf)) + ALLOCATE(topswad(klon), solswad(klon)) + ALLOCATE(topswai(klon), solswai(klon)) + ALLOCATE(tau_aero(klon,klev,naero_grp,nbands),piz_aero(klon,klev,naero_grp,nbands),cg_aero(klon,klev,naero_grp,nbands)) + ALLOCATE(ccm(klon,klev,nbands)) + +END SUBROUTINE phys_state_var_init + +!====================================================================== +SUBROUTINE phys_state_var_end +use dimphy +IMPLICIT NONE +#include "indicesol.h" +#include "control.h" + + deallocate(rlat, rlon, pctsrf, ftsol, falb1, falb2) + deallocate(rain_fall, snow_fall, solsw, sollw, radsol) + deallocate(zmea, zstd, zsig, zgam) + deallocate(zthe, zpic, zval) + deallocate(rugoro, t_ancien, q_ancien, clwcon, rnebcon) + deallocate( u_ancien, v_ancien ) + deallocate(ratqs, pbl_tke) + deallocate(zmax0, f0) + deallocate(ema_work1, ema_work2) + deallocate(entr_therm, fm_therm) + deallocate(detr_therm) + deallocate(clwcon0th, rnebcon0th) +! radiation outputs + deallocate(swdn0, swdn) + deallocate(swup0, swup) + deallocate(lwdn0, lwdn) + deallocate(lwup0, lwup) + deallocate(SWdn200clr, SWdn200) + deallocate(SWup200clr, SWup200) + deallocate(LWdn200clr, LWdn200) + deallocate(LWup200clr, LWup200) + deallocate(LWdnTOA, LWdnTOAclr) +! pressure level + deallocate(tsumSTD) + deallocate(usumSTD, vsumSTD) + deallocate(wsumSTD, phisumSTD) + deallocate(tnondef) + deallocate(qsumSTD, rhsumSTD) + deallocate(uvsumSTD) + deallocate(vqsumSTD) + deallocate(vTsumSTD) + deallocate(wqsumSTD) + deallocate(vphisumSTD) + deallocate(wTsumSTD) + deallocate(u2sumSTD) + deallocate(v2sumSTD) + deallocate(T2sumSTD) + deallocate(seed_old) + deallocate(zuthe, zvthe) + deallocate(alb_neig) + deallocate(ema_workcbmf, ema_cbmf) + deallocate(ema_pcb, ema_pct) + deallocate(Ma, qcondc) + deallocate(wd, sigd) + deallocate(cin, ALE, ALP) + deallocate(ftd, fqd) + deallocate(Ale_bl, Alp_bl) + deallocate(lalim_conv, wght_th) + deallocate(wake_deltat, wake_deltaq) + deallocate(wake_Cstar, wake_s, wake_fip) + deallocate(dt_wake, dq_wake) + deallocate(pfrac_impa, pfrac_nucl) + deallocate(pfrac_1nucl) + deallocate(total_rain, nday_rain) + deallocate(paire_ter) + deallocate(albsol1, albsol2) + deallocate(wo) + deallocate(clwcon0,rnebcon0) + deallocate(heat, heat0) + deallocate(cool, cool0) + deallocate(topsw, toplw) + deallocate(sollwdown, sollwdownclr) + deallocate(toplwdown, toplwdownclr) + deallocate(topsw0,toplw0,solsw0,sollw0) + deallocate(albpla) + deallocate(cape) + deallocate(pbase,bbase) + deallocate(zqasc) + deallocate(ibas_con, itop_con) + deallocate(rain_con, snow_con) + deallocate(rlonPOS) + deallocate(newsst) + deallocate(u10m, v10m) + deallocate(topswad, solswad) + deallocate(topswai, solswai) + deallocate(tau_aero,piz_aero,cg_aero) + deallocate(ccm) + +END SUBROUTINE phys_state_var_end + + END MODULE phys_state_var_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/physiq.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/physiq.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/physiq.F (revision 1280) @@ -0,0 +1,3605 @@ +! $Id$ +! +c#define IO_DEBUG + + SUBROUTINE physiq (nlon,nlev, + . debut,lafin,jD_cur, jH_cur,pdtphys, + . paprs,pplay,pphi,pphis,presnivs,clesphy0, + . u,v,t,qx, + . flxmass_w, + . d_u, d_v, d_t, d_qx, d_ps + . , dudyn + . , PVteta) + + USE ioipsl, only: histbeg, histvert, histdef, histend, histsync, + $ histwrite, ju2ymds, ymds2ju, ioget_year_len + USE comgeomphy + USE phys_cal_mod + USE write_field_phy + USE dimphy + USE infotrac + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE iophy + USE misc_mod, mydebug=>debug + USE vampir + USE pbl_surface_mod, ONLY : pbl_surface + USE change_srf_frac_mod + USE surface_data, ONLY : type_ocean, ok_veget + USE phys_local_var_mod ! Variables internes non sauvegardees de la physique + USE phys_state_var_mod ! Variables sauvegardees de la physique + USE fonte_neige_mod, ONLY : fonte_neige_get_vars + USE phys_output_mod + use open_climoz_m, only: open_climoz ! ozone climatology from a file + use regr_pr_av_m, only: regr_pr_av + use netcdf95, only: nf95_close + use mod_phys_lmdz_mpi_data, only: is_mpi_root + USE aero_mod + use ozonecm_m, only: ozonecm ! ozone of J.-F. Royer + use conf_phys_m, only: conf_phys + use radlwsw_m, only: radlwsw + + IMPLICIT none +c====================================================================== +c +c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +c +c Objet: Moniteur general de la physique du modele +cAA Modifications quant aux traceurs : +cAA - uniformisation des parametrisations ds phytrac +cAA - stockage des moyennes des champs necessaires +cAA en mode traceur off-line +c====================================================================== +c CLEFS CPP POUR LES IO +c ===================== +c#define histmthNMC +c#define histISCCP +c====================================================================== +c modif ( P. Le Van , 12/10/98 ) +c +c Arguments: +c +c nlon----input-I-nombre de points horizontaux +c nlev----input-I-nombre de couches verticales, doit etre egale a klev +c debut---input-L-variable logique indiquant le premier passage +c lafin---input-L-variable logique indiquant le dernier passage +c jD_cur -R-jour courant a l'appel de la physique (jour julien) +c jH_cur -R-heure courante a l'appel de la physique (jour julien) +c pdtphys-input-R-pas d'integration pour la physique (seconde) +c paprs---input-R-pression pour chaque inter-couche (en Pa) +c pplay---input-R-pression pour le mileu de chaque couche (en Pa) +c pphi----input-R-geopotentiel de chaque couche (g z) (reference sol) +c pphis---input-R-geopotentiel du sol +c presnivs-input_R_pressions approximat. des milieux couches ( en PA) +c u-------input-R-vitesse dans la direction X (de O a E) en m/s +c v-------input-R-vitesse Y (de S a N) en m/s +c t-------input-R-temperature (K) +c qx------input-R-humidite specifique (kg/kg) et d'autres traceurs +c d_t_dyn-input-R-tendance dynamique pour "t" (K/s) +c d_q_dyn-input-R-tendance dynamique pour "q" (kg/kg/s) +c flxmass_w -input-R- flux de masse verticale +c d_u-----output-R-tendance physique de "u" (m/s/s) +c d_v-----output-R-tendance physique de "v" (m/s/s) +c d_t-----output-R-tendance physique de "t" (K/s) +c d_qx----output-R-tendance physique de "qx" (kg/kg/s) +c d_ps----output-R-tendance physique de la pression au sol +cIM +c PVteta--output-R-vorticite potentielle a des thetas constantes +c====================================================================== +#include "dimensions.h" + integer jjmp1 + parameter (jjmp1=jjm+1-1/jjm) + integer iip1 + parameter (iip1=iim+1) + +#include "regdim.h" +#include "indicesol.h" +#include "dimsoil.h" +#include "clesphys.h" +#include "control.h" +#include "temps.h" +#include "iniprint.h" +#include "thermcell.h" +c====================================================================== + LOGICAL ok_cvl ! pour activer le nouveau driver pour convection KE + PARAMETER (ok_cvl=.TRUE.) + LOGICAL ok_gust ! pour activer l'effet des gust sur flux surface + PARAMETER (ok_gust=.FALSE.) + integer iflag_radia ! active ou non le rayonnement (MPL) + save iflag_radia +c$OMP THREADPRIVATE(iflag_radia) +c====================================================================== + LOGICAL check ! Verifier la conservation du modele en eau + PARAMETER (check=.FALSE.) + LOGICAL ok_stratus ! Ajouter artificiellement les stratus + PARAMETER (ok_stratus=.FALSE.) +c====================================================================== + REAL amn, amx + INTEGER igout +c====================================================================== +c Clef controlant l'activation du cycle diurne: +ccc LOGICAL cycle_diurne +ccc PARAMETER (cycle_diurne=.FALSE.) +c====================================================================== +c Modele thermique du sol, a activer pour le cycle diurne: +ccc LOGICAL soil_model +ccc PARAMETER (soil_model=.FALSE.) +c====================================================================== +c Dans les versions precedentes, l'eau liquide nuageuse utilisee dans +c le calcul du rayonnement est celle apres la precipitation des nuages. +c Si cette cle new_oliq est activee, ce sera une valeur moyenne entre +c la condensation et la precipitation. Cette cle augmente les impacts +c radiatifs des nuages. +ccc LOGICAL new_oliq +ccc PARAMETER (new_oliq=.FALSE.) +c====================================================================== +c Clefs controlant deux parametrisations de l'orographie: +cc LOGICAL ok_orodr +ccc PARAMETER (ok_orodr=.FALSE.) +ccc LOGICAL ok_orolf +ccc PARAMETER (ok_orolf=.FALSE.) +c====================================================================== + LOGICAL ok_journe ! sortir le fichier journalier + save ok_journe +c$OMP THREADPRIVATE(ok_journe) +c + LOGICAL ok_mensuel ! sortir le fichier mensuel + save ok_mensuel +c$OMP THREADPRIVATE(ok_mensuel) +c + LOGICAL ok_instan ! sortir le fichier instantane + save ok_instan +c$OMP THREADPRIVATE(ok_instan) +c + LOGICAL ok_LES ! sortir le fichier LES + save ok_LES +c$OMP THREADPRIVATE(ok_LES) +c + LOGICAL ok_region ! sortir le fichier regional + PARAMETER (ok_region=.FALSE.) +c====================================================================== + real weak_inversion(klon),dthmin(klon) + real seuil_inversion + save seuil_inversion +c$OMP THREADPRIVATE(seuil_inversion) + integer iflag_ratqs + save iflag_ratqs +c$OMP THREADPRIVATE(iflag_ratqs) + REAL lambda_th(klon,klev),zz,znum,zden + REAL wmax_th(klon) + REAL zmax_th(klon) + REAL tau_overturning_th(klon) + + integer lmax_th(klon) + integer limbas(klon) + real ratqscth(klon,klev) + real ratqsdiff(klon,klev) + real zqsatth(klon,klev) + +c====================================================================== +c + INTEGER ivap ! indice de traceurs pour vapeur d'eau + PARAMETER (ivap=1) + INTEGER iliq ! indice de traceurs pour eau liquide + PARAMETER (iliq=2) + +c +c +c Variables argument: +c + INTEGER nlon + INTEGER nlev + REAL, intent(in):: jD_cur, jH_cur + + REAL pdtphys + LOGICAL debut, lafin + REAL paprs(klon,klev+1) + REAL pplay(klon,klev) + REAL pphi(klon,klev) + REAL pphis(klon) + REAL presnivs(klev) + REAL znivsig(klev) + real pir + + REAL u(klon,klev) + REAL v(klon,klev) + REAL t(klon,klev),theta(klon,klev) + REAL qx(klon,klev,nqtot) + REAL flxmass_w(klon,klev) + REAL omega(klon,klev) ! vitesse verticale en Pa/s + REAL d_u(klon,klev) + REAL d_v(klon,klev) + REAL d_t(klon,klev) + REAL d_qx(klon,klev,nqtot) + REAL d_ps(klon) + real da(klon,klev),phi(klon,klev,klev),mp(klon,klev) +c +cIM Amip2 PV a theta constante +c + INTEGER nbteta + PARAMETER(nbteta=3) + CHARACTER*3 ctetaSTD(nbteta) + DATA ctetaSTD/'350','380','405'/ + SAVE ctetaSTD +c$OMP THREADPRIVATE(ctetaSTD) + REAL rtetaSTD(nbteta) + DATA rtetaSTD/350., 380., 405./ + SAVE rtetaSTD +c$OMP THREADPRIVATE(rtetaSTD) +c + REAL PVteta(klon,nbteta) + REAL zx_tmp_3dte(iim,jjmp1,nbteta) +c +cMI Amip2 PV a theta constante + +cym INTEGER klevp1, klevm1 +cym PARAMETER(klevp1=klev+1,klevm1=klev-1) +cym#include "raddim.h" +c +c +cIM Amip2 +c variables a une pression donnee +c + real rlevSTD(nlevSTD) + DATA rlevSTD/100000., 92500., 85000., 70000., + .60000., 50000., 40000., 30000., 25000., 20000., + .15000., 10000., 7000., 5000., 3000., 2000., 1000./ + SAVE rlevstd +c$OMP THREADPRIVATE(rlevstd) + CHARACTER*4 clevSTD(nlevSTD) + DATA clevSTD/'1000','925 ','850 ','700 ','600 ', + .'500 ','400 ','300 ','250 ','200 ','150 ','100 ', + .'70 ','50 ','30 ','20 ','10 '/ + SAVE clevSTD +c$OMP THREADPRIVATE(clevSTD) +c + CHARACTER*4 bb2 + CHARACTER*2 bb3 +c + real tlevSTD(klon,nlevSTD), qlevSTD(klon,nlevSTD) + real rhlevSTD(klon,nlevSTD), philevSTD(klon,nlevSTD) + real ulevSTD(klon,nlevSTD), vlevSTD(klon,nlevSTD) + real wlevSTD(klon,nlevSTD) + + real twriteSTD(klon,nlevSTD,nfiles) + real qwriteSTD(klon,nlevSTD,nfiles) + real rhwriteSTD(klon,nlevSTD,nfiles) + real phiwriteSTD(klon,nlevSTD,nfiles) + real uwriteSTD(klon,nlevSTD,nfiles) + real vwriteSTD(klon,nlevSTD,nfiles) + real wwriteSTD(klon,nlevSTD,nfiles) +c +c nout : niveau de output des variables a une pression donnee + logical oknondef(klon,nlevSTD,nout) +c +c les produits uvSTD, vqSTD, .., T2STD sont calcules +c a partir des valeurs instantannees toutes les 6 h +c qui sont moyennees sur le mois +c + real uvSTD(klon,nlevSTD) + real vqSTD(klon,nlevSTD) + real vTSTD(klon,nlevSTD) + real wqSTD(klon,nlevSTD) +c + real vphiSTD(klon,nlevSTD) + real wTSTD(klon,nlevSTD) + real u2STD(klon,nlevSTD) + real v2STD(klon,nlevSTD) + real T2STD(klon,nlevSTD) +c +#include "radopt.h" +c +c +c prw: precipitable water + real prw(klon) + + REAL convliq(klon,klev) ! eau liquide nuageuse convective + REAL convfra(klon,klev) ! fraction nuageuse convective + + REAL cldl_c(klon),cldm_c(klon),cldh_c(klon) !nuages bas, moyen et haut + REAL cldt_c(klon),cldq_c(klon) !nuage total, eau liquide integree + REAL cldl_s(klon),cldm_s(klon),cldh_s(klon) !nuages bas, moyen et haut + REAL cldt_s(klon),cldq_s(klon) !nuage total, eau liquide integree + + INTEGER linv, kp1 +c flwp, fiwp = Liquid Water Path & Ice Water Path (kg/m2) +c flwc, fiwc = Liquid Water Content & Ice Water Content (kg/kg) + REAL flwp(klon), fiwp(klon) + REAL flwc(klon,klev), fiwc(klon,klev) + REAL flwp_c(klon), fiwp_c(klon) + REAL flwc_c(klon,klev), fiwc_c(klon,klev) + REAL flwp_s(klon), fiwp_s(klon) + REAL flwc_s(klon,klev), fiwc_s(klon,klev) + +cIM ISCCP simulator v3.4 +c dans clesphys.h top_height, overlap +cv3.4 + INTEGER debug, debugcol +cym INTEGER npoints +cym PARAMETER(npoints=klon) +c + INTEGER sunlit(klon) !sunlit=1 if day; sunlit=0 if night + INTEGER nregISCtot + PARAMETER(nregISCtot=1) +c +c imin_debut, nbpti, jmin_debut, nbptj : parametres pour sorties sur 1 region rectangulaire +c y compris pour 1 point +c imin_debut : indice minimum de i; nbpti : nombre de points en direction i (longitude) +c jmin_debut : indice minimum de j; nbptj : nombre de points en direction j (latitude) + INTEGER imin_debut, nbpti + INTEGER jmin_debut, nbptj +cIM parametres ISCCP BEG + INTEGER nbapp_isccp +! INTEGER nbapp_isccp,isccppas +! PARAMETER(isccppas=6) !appel du simulateurs tous les 6pas de temps de la physique +! !i.e. toutes les 3 heures + INTEGER n + INTEGER ifreq_isccp(napisccp), freqin_pdt(napisccp) + DATA ifreq_isccp/3/ + SAVE ifreq_isccp +c$OMP THREADPRIVATE(ifreq_isccp) + CHARACTER*5 typinout(napisccp) + DATA typinout/'i3od'/ + SAVE typinout +c$OMP THREADPRIVATE(typinout) +cIM verif boxptop BEG + CHARACTER*1 verticaxe(napisccp) + DATA verticaxe/'1'/ + SAVE verticaxe +c$OMP THREADPRIVATE(verticaxe) +cIM verif boxptop END + INTEGER nvlev(napisccp) +c INTEGER nvlev + REAL t1, aa + REAL seed_re(klon,napisccp) +cym !!!! A voir plus tard +cym INTEGER iphy(iim,jjmp1) +cIM parametres ISCCP END +c +c ncol = nb. de sous-colonnes pour chaque maille du GCM +c ncolmx = No. max. de sous-colonnes pour chaque maille du GCM +c INTEGER ncol(napisccp), ncolmx, seed(klon,napisccp) + INTEGER,SAVE :: ncol(napisccp) +c$OMP THREADPRIVATE(ncol) + INTEGER ncolmx, seed(klon,napisccp) + REAL nbsunlit(nregISCtot,klon,napisccp) !nbsunlit : moyenne de sunlit +c PARAMETER(ncolmx=1500) + PARAMETER(ncolmx=300) +c +cIM verif boxptop BEG + REAL vertlev(ncolmx,napisccp) +cIM verif boxptop END +c + REAL,SAVE :: tautab_omp(0:255),tautab(0:255) + INTEGER,SAVE :: invtau_omp(-20:45000),invtau(-20:45000) +c$OMP THREADPRIVATE(tautab,invtau) + REAL emsfc_lw + PARAMETER(emsfc_lw=0.99) +c REAL ran0 ! type for random number fuction +c + REAL cldtot(klon,klev) +c variables de haut en bas pour le simulateur ISCCP + REAL dtau_s(klon,klev) !tau nuages startiformes + REAL dtau_c(klon,klev) !tau nuages convectifs + REAL dem_s(klon,klev) !emissivite nuages startiformes + REAL dem_c(klon,klev) !emissivite nuages convectifs +c +c variables de haut en bas pour le simulateur ISCCP + REAL pfull(klon,klev) + REAL phalf(klon,klev+1) + REAL qv(klon,klev) + REAL cc(klon,klev) + REAL conv(klon,klev) + REAL dtau_sH2B(klon,klev) + REAL dtau_cH2B(klon,klev) + REAL at(klon,klev) + REAL dem_sH2B(klon,klev) + REAL dem_cH2B(klon,klev) +c + INTEGER kmax, lmax, lmax3 + PARAMETER(kmax=8, lmax=8, lmax3=3) + INTEGER kmaxm1, lmaxm1 + PARAMETER(kmaxm1=kmax-1, lmaxm1=lmax-1) + INTEGER iimx7, jjmx7, jjmp1x7 + PARAMETER(iimx7=iim*kmaxm1, jjmx7=jjm*lmaxm1, + .jjmp1x7=jjmp1*lmaxm1) +c +c output from ISCCP simulator + REAL fq_isccp(klon,kmaxm1,lmaxm1,napisccp) + REAL fq_is_true(klon,kmaxm1,lmaxm1,napisccp) + REAL totalcldarea(klon,napisccp) + REAL meanptop(klon,napisccp) + REAL meantaucld(klon,napisccp) + REAL boxtau(klon,ncolmx,napisccp) + REAL boxptop(klon,ncolmx,napisccp) + REAL zx_tmp_fi3d_bx(klon,ncolmx) + REAL zx_tmp_3d_bx(iim,jjmp1,ncolmx) +c + REAL cld_fi3d(klon,lmax3) + REAL cld_3d(iim,jjmp1,lmax3) +c + INTEGER iw, iwmax + REAL wmin, pas_w +c PARAMETER(wmin=-100.,pas_w=10.,iwmax=30) +cIM 051005 PARAMETER(wmin=-200.,pas_w=10.,iwmax=40) + PARAMETER(wmin=-100.,pas_w=10.,iwmax=20) + REAL o500(klon) +c + +c sorties ISCCP + + integer nid_isccp + save nid_isccp +c$OMP THREADPRIVATE(nid_isccp) + + REAL zx_tau(kmaxm1), zx_pc(lmaxm1), zx_o500(iwmax) + DATA zx_tau/0.0, 0.3, 1.3, 3.6, 9.4, 23., 60./ + SAVE zx_tau + DATA zx_pc/180., 310., 440., 560., 680., 800., 1000./ + SAVE zx_pc +c$OMP THREADPRIVATE(zx_tau,zx_pc) +c cldtopres pression au sommet des nuages + REAL cldtopres(lmaxm1), cldtopres3(lmax3) + DATA cldtopres/180., 310., 440., 560., 680., 800., 1000./ + DATA cldtopres3/440., 680., 1000./ + SAVE cldtopres,cldtopres3 +c$OMP THREADPRIVATE(cldtopres,cldtopres3) +cIM 051005 BEG + INTEGER komega, nhoriRD + +c taulev: numero du niveau de tau dans les sorties ISCCP + CHARACTER *4 taulev(kmaxm1) +c DATA taulev/'tau1','tau2','tau3','tau4','tau5','tau6','tau7'/ + DATA taulev/'tau0','tau1','tau2','tau3','tau4','tau5','tau6'/ + CHARACTER *3 pclev(lmaxm1) + DATA pclev/'pc1','pc2','pc3','pc4','pc5','pc6','pc7'/ + SAVE taulev,pclev +c$OMP THREADPRIVATE(taulev,pclev) +c +c cnameisccp + CHARACTER *27 cnameisccp(lmaxm1,kmaxm1) +cIM bad 151205 DATA cnameisccp/'pc< 50hPa, tau< 0.3', + DATA cnameisccp/'pc= 50-180hPa, tau< 0.3', + . 'pc= 180-310hPa, tau< 0.3', + . 'pc= 310-440hPa, tau< 0.3', + . 'pc= 440-560hPa, tau< 0.3', + . 'pc= 560-680hPa, tau< 0.3', + . 'pc= 680-800hPa, tau< 0.3', + . 'pc= 800-1000hPa, tau< 0.3', + . 'pc= 50-180hPa, tau= 0.3-1.3', + . 'pc= 180-310hPa, tau= 0.3-1.3', + . 'pc= 310-440hPa, tau= 0.3-1.3', + . 'pc= 440-560hPa, tau= 0.3-1.3', + . 'pc= 560-680hPa, tau= 0.3-1.3', + . 'pc= 680-800hPa, tau= 0.3-1.3', + . 'pc= 800-1000hPa, tau= 0.3-1.3', + . 'pc= 50-180hPa, tau= 1.3-3.6', + . 'pc= 180-310hPa, tau= 1.3-3.6', + . 'pc= 310-440hPa, tau= 1.3-3.6', + . 'pc= 440-560hPa, tau= 1.3-3.6', + . 'pc= 560-680hPa, tau= 1.3-3.6', + . 'pc= 680-800hPa, tau= 1.3-3.6', + . 'pc= 800-1000hPa, tau= 1.3-3.6', + . 'pc= 50-180hPa, tau= 3.6-9.4', + . 'pc= 180-310hPa, tau= 3.6-9.4', + . 'pc= 310-440hPa, tau= 3.6-9.4', + . 'pc= 440-560hPa, tau= 3.6-9.4', + . 'pc= 560-680hPa, tau= 3.6-9.4', + . 'pc= 680-800hPa, tau= 3.6-9.4', + . 'pc= 800-1000hPa, tau= 3.6-9.4', + . 'pc= 50-180hPa, tau= 9.4-23', + . 'pc= 180-310hPa, tau= 9.4-23', + . 'pc= 310-440hPa, tau= 9.4-23', + . 'pc= 440-560hPa, tau= 9.4-23', + . 'pc= 560-680hPa, tau= 9.4-23', + . 'pc= 680-800hPa, tau= 9.4-23', + . 'pc= 800-1000hPa, tau= 9.4-23', + . 'pc= 50-180hPa, tau= 23-60', + . 'pc= 180-310hPa, tau= 23-60', + . 'pc= 310-440hPa, tau= 23-60', + . 'pc= 440-560hPa, tau= 23-60', + . 'pc= 560-680hPa, tau= 23-60', + . 'pc= 680-800hPa, tau= 23-60', + . 'pc= 800-1000hPa, tau= 23-60', + . 'pc= 50-180hPa, tau> 60.', + . 'pc= 180-310hPa, tau> 60.', + . 'pc= 310-440hPa, tau> 60.', + . 'pc= 440-560hPa, tau> 60.', + . 'pc= 560-680hPa, tau> 60.', + . 'pc= 680-800hPa, tau> 60.', + . 'pc= 800-1000hPa, tau> 60.'/ + SAVE cnameisccp +c$OMP THREADPRIVATE(cnameisccp) +c +c REAL zx_lonx7(iimx7), zx_latx7(jjmp1x7) +c INTEGER nhorix7 +cIM: region='3d' <==> sorties en global + CHARACTER*3 region + PARAMETER(region='3d') +c +cIM ISCCP simulator v3.4 +c + logical ok_hf +c + integer nid_hf, nid_hf3d + save ok_hf, nid_hf, nid_hf3d +c$OMP THREADPRIVATE(ok_hf, nid_hf, nid_hf3d) +c QUESTION : noms de variables ? + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) +c +c Variables propres a la physique + INTEGER itap + SAVE itap ! compteur pour la physique +c$OMP THREADPRIVATE(itap) +c + real slp(klon) ! sea level pressure +c + REAL fevap(klon,nbsrf) + REAL fluxlat(klon,nbsrf) +c + REAL qsol(klon) + REAL,save :: solarlong0 +c$OMP THREADPRIVATE(solarlong0) + +c +c Parametres de l'Orographie a l'Echelle Sous-Maille (OESM): +c +cIM 141004 REAL zulow(klon),zvlow(klon),zustr(klon), zvstr(klon) + REAL zulow(klon),zvlow(klon) +c + INTEGER igwd,idx(klon),itest(klon) +c + REAL agesno(klon,nbsrf) +c +c REAL,allocatable,save :: run_off_lic_0(:) +cc$OMP THREADPRIVATE(run_off_lic_0) +cym SAVE run_off_lic_0 +cKE43 +c Variables liees a la convection de K. Emanuel (sb): +c + REAL bas, top ! cloud base and top levels + SAVE bas + SAVE top +c$OMP THREADPRIVATE(bas, top) + + REAL wdn(klon), tdn(klon), qdn(klon) +c +c================================================================================================= +cCR04.12.07: on ajoute les nouvelles variables du nouveau schema de convection avec poches froides +c Variables liées à la poche froide (jyg) + + REAL mip(klon,klev) ! mass flux shed by the adiab ascent at each level + REAL Vprecip(klon,klev) ! precipitation vertical profile +c + REAL wape_prescr, fip_prescr + INTEGER it_wape_prescr + SAVE wape_prescr, fip_prescr, it_wape_prescr +c$OMP THREADPRIVATE(wape_prescr, fip_prescr, it_wape_prescr) +c +c variables supplementaires de concvl + REAL Tconv(klon,klev) + REAL ment(klon,klev,klev),sij(klon,klev,klev) + REAL dd_t(klon,klev),dd_q(klon,klev) + + real, save :: alp_bl_prescr=0. + real, save :: ale_bl_prescr=0. + + real, save :: ale_max=100. + real, save :: alp_max=2. + +c$OMP THREADPRIVATE(alp_bl_prescr,ale_bl_prescr) +c$OMP THREADPRIVATE(ale_max,alp_max) + + real ale_wake(klon) + real alp_wake(klon) +cRC +c Variables liées à la poche froide (jyg et rr) +c Version diagnostique pour l'instant : pas de rétroaction sur la convection + + REAL t_wake(klon,klev),q_wake(klon,klev) ! wake pour la convection + + REAL wake_dth(klon,klev) ! wake : temp pot difference + + REAL wake_d_deltat_gw(klon,klev)! wake : delta T tendency due to Gravity Wave (/s) + REAL wake_omgbdth(klon,klev) ! Wake : flux of Delta_Theta transported by LS omega + REAL wake_dp_omgb(klon,klev) ! Wake : vertical gradient of large scale omega + REAL wake_dtKE(klon,klev) ! Wake : differential heating (wake - unpertubed) CONV + REAL wake_dqKE(klon,klev) ! Wake : differential moistening (wake - unpertubed) CONV + REAL wake_dtPBL(klon,klev) ! Wake : differential heating (wake - unpertubed) PBL + REAL wake_dqPBL(klon,klev) ! Wake : differential moistening (wake - unpertubed) PBL + REAL wake_omg(klon,klev) ! Wake : velocity difference (wake - unpertubed) + REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev) + REAL wake_dp_deltomg(klon,klev) ! Wake : gradient vertical de wake_omg + REAL wake_spread(klon,klev) ! spreading term in wake_delt +c +cpourquoi y'a pas de save?? + REAL wake_h(klon) ! Wake : hauteur de la poche froide +c + INTEGER wake_k(klon) ! Wake sommet +c + REAL t_undi(klon,klev) ! temperature moyenne dans la zone non perturbee + REAL q_undi(klon,klev) ! humidite moyenne dans la zone non perturbee +c + REAL wake_pe(klon) ! Wake potential energy - WAPE + + REAL wake_gfl(klon) ! Gust Front Length + REAL wake_dens(klon) +c +c + REAL dt_dwn(klon,klev) + REAL dq_dwn(klon,klev) + REAL wdt_PBL(klon,klev) + REAL udt_PBL(klon,klev) + REAL wdq_PBL(klon,klev) + REAL udq_PBL(klon,klev) + REAL M_dwn(klon,klev) + REAL M_up(klon,klev) + REAL dt_a(klon,klev) + REAL dq_a(klon,klev) +c +cRR:fin declarations poches froides +c======================================================================================================= + + REAL zw2(klon,klev+1) + REAL fraca(klon,klev+1) + +c Variables locales pour la couche limite (al1): +c +cAl1 REAL pblh(klon) ! Hauteur de couche limite +cAl1 SAVE pblh +c34EK +c +c Variables locales: +c + REAL cdragh(klon) ! drag coefficient pour T and Q + REAL cdragm(klon) ! drag coefficient pour vent +cAA +cAA Pour phytrac +cAA + REAL coefh(klon,klev) ! coef d'echange pour phytrac, valable pour 2<=k<=klev + REAL u1(klon) ! vents dans la premiere couche U + REAL v1(klon) ! vents dans la premiere couche V + + REAL zxffonte(klon), zxfqcalving(klon),zxfqfonte(klon) + +c@$$ LOGICAL offline ! Controle du stockage ds "physique" +c@$$ PARAMETER (offline=.false.) +c@$$ INTEGER physid + REAL frac_impa(klon,klev) ! fractions d'aerosols lessivees (impaction) + REAL frac_nucl(klon,klev) ! idem (nucleation) + INTEGER :: iii + REAL :: calday + +cIM cf FH pour Tiedtke 080604 + REAL rain_tiedtke(klon),snow_tiedtke(klon) +c +cIM 050204 END + REAL evap(klon), devap(klon) ! evaporation et sa derivee + REAL sens(klon), dsens(klon) ! chaleur sensible et sa derivee + + REAL bils(klon) ! bilan de chaleur au sol + REAL wfbilo(klon,nbsrf) ! bilan d'eau, pour chaque +C ! type de sous-surface et pondere par la fraction + REAL wfbils(klon,nbsrf) ! bilan de chaleur au sol, pour chaque +C ! type de sous-surface et pondere par la fraction + REAL slab_wfbils(klon) ! bilan de chaleur au sol pour le cas de slab, sur les points d'ocean + + REAL fder(klon) + REAL ve(klon) ! integr. verticale du transport meri. de l'energie + REAL vq(klon) ! integr. verticale du transport meri. de l'eau + REAL ue(klon) ! integr. verticale du transport zonal de l'energie + REAL uq(klon) ! integr. verticale du transport zonal de l'eau +c + REAL frugs(klon,nbsrf) + REAL zxrugs(klon) ! longueur de rugosite +c +c Conditions aux limites +c +! + REAL :: day_since_equinox +! Date de l'equinoxe de printemps + INTEGER, parameter :: mth_eq=3, day_eq=21 + REAL :: jD_eq + + LOGICAL, parameter :: new_orbit = .true. + +c + INTEGER lmt_pas + SAVE lmt_pas ! frequence de mise a jour +c$OMP THREADPRIVATE(lmt_pas) + real zmasse(klon, llm) +C (column-density of mass of air in a cell, in kg m-2) + real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2 + +cIM sorties + REAL un_jour + PARAMETER(un_jour=86400.) +c====================================================================== +c +c Declaration des procedures appelees +c + EXTERNAL angle ! calculer angle zenithal du soleil + EXTERNAL alboc ! calculer l'albedo sur ocean + EXTERNAL ajsec ! ajustement sec + EXTERNAL conlmd ! convection (schema LMD) +cKE43 + EXTERNAL conema3 ! convect4.3 + EXTERNAL fisrtilp ! schema de condensation a grande echelle (pluie) +cAA + EXTERNAL fisrtilp_tr ! schema de condensation a grande echelle (pluie) +c ! stockage des coefficients necessaires au +c ! lessivage OFF-LINE et ON-LINE + EXTERNAL hgardfou ! verifier les temperatures + EXTERNAL nuage ! calculer les proprietes radiatives +CC EXTERNAL o3cm ! initialiser l'ozone + EXTERNAL orbite ! calculer l'orbite terrestre + EXTERNAL phyetat0 ! lire l'etat initial de la physique + EXTERNAL phyredem ! ecrire l'etat de redemarrage de la physique + EXTERNAL suphel ! initialiser certaines constantes + EXTERNAL transp ! transport total de l'eau et de l'energie + EXTERNAL ecribina ! ecrire le fichier binaire global + EXTERNAL ecribins ! ecrire le fichier binaire global + EXTERNAL ecrirega ! ecrire le fichier binaire regional + EXTERNAL ecriregs ! ecrire le fichier binaire regional +cIM + EXTERNAL haut2bas !variables de haut en bas + INTEGER lnblnk1 + EXTERNAL lnblnk1 !enleve les blancs a la fin d'une variable de type + !caracter + EXTERNAL ini_undefSTD !initialise a 0 une variable a 1 niveau de pression + EXTERNAL undefSTD !somme les valeurs definies d'1 var a 1 niveau de pression +c EXTERNAL moy_undefSTD !moyenne d'1 var a 1 niveau de pression +c EXTERNAL moyglo_aire !moyenne globale d'1 var ponderee par l'aire de la maille (moyglo_pondaire) +c !par la masse/airetot (moyglo_pondaima) et la vraie masse (moyglo_pondmass) +c +c Variables locales +c + REAL rhcl(klon,klev) ! humiditi relative ciel clair + REAL dialiq(klon,klev) ! eau liquide nuageuse + REAL diafra(klon,klev) ! fraction nuageuse + REAL cldliq(klon,klev) ! eau liquide nuageuse + REAL cldfra(klon,klev) ! fraction nuageuse + REAL cldtau(klon,klev) ! epaisseur optique + REAL cldemi(klon,klev) ! emissivite infrarouge +c +CXXX PB + REAL fluxq(klon,klev, nbsrf) ! flux turbulent d'humidite + REAL fluxt(klon,klev, nbsrf) ! flux turbulent de chaleur + REAL fluxu(klon,klev, nbsrf) ! flux turbulent de vitesse u + REAL fluxv(klon,klev, nbsrf) ! flux turbulent de vitesse v +c + REAL zxfluxt(klon, klev) + REAL zxfluxq(klon, klev) + REAL zxfluxu(klon, klev) + REAL zxfluxv(klon, klev) +CXXX +c + REAL fsollw(klon, nbsrf) ! bilan flux IR pour chaque sous surface + REAL fsolsw(klon, nbsrf) ! flux solaire absorb. pour chaque sous surface +c Le rayonnement n'est pas calcule tous les pas, il faut donc +c sauvegarder les sorties du rayonnement +cym SAVE heat,cool,albpla,topsw,toplw,solsw,sollw,sollwdown +cym SAVE sollwdownclr, toplwdown, toplwdownclr +cym SAVE topsw0,toplw0,solsw0,sollw0, heat0, cool0 +c + INTEGER itaprad + SAVE itaprad +c$OMP THREADPRIVATE(itaprad) +c + REAL conv_q(klon,klev) ! convergence de l'humidite (kg/kg/s) + REAL conv_t(klon,klev) ! convergence de la temperature(K/s) +c + REAL cldl(klon),cldm(klon),cldh(klon) !nuages bas, moyen et haut + REAL cldt(klon),cldq(klon) !nuage total, eau liquide integree +c + REAL zxtsol(klon), zxqsurf(klon), zxsnow(klon), zxfluxlat(klon) + REAL zxsnow_dummy(klon) +c + REAL dist, rmu0(klon), fract(klon) + REAL zdtime, zlongi +c + CHARACTER*2 str2 + CHARACTER*2 iqn +c + REAL qcheck + REAL z_avant(klon), z_apres(klon), z_factor(klon) + LOGICAL zx_ajustq +c + REAL za, zb + REAL zx_t, zx_qs, zdelta, zcor, zfra, zlvdcp, zlsdcp + real zqsat(klon,klev) + INTEGER i, k, iq, ig, j, nsrf, ll, l, iiq, iff + REAL t_coup + PARAMETER (t_coup=234.0) +c + REAL zphi(klon,klev) +cym A voir plus tard !! +cym REAL zx_relief(iim,jjmp1) +cym REAL zx_aire(iim,jjmp1) +c +c Grandeurs de sorties + REAL s_pblh(klon), s_lcl(klon), s_capCL(klon) + REAL s_oliqCL(klon), s_cteiCL(klon), s_pblt(klon) + REAL s_therm(klon), s_trmb1(klon), s_trmb2(klon) + REAL s_trmb3(klon) +cKE43 +c Variables locales pour la convection de K. Emanuel (sb): +c + REAL upwd(klon,klev) ! saturated updraft mass flux + REAL dnwd(klon,klev) ! saturated downdraft mass flux + REAL dnwd0(klon,klev) ! unsaturated downdraft mass flux + REAL tvp(klon,klev) ! virtual temp of lifted parcel + CHARACTER*40 capemaxcels !max(CAPE) + + REAL rflag(klon) ! flag fonctionnement de convect + INTEGER iflagctrl(klon) ! flag fonctionnement de convect +c -- convect43: + INTEGER ntra ! nb traceurs pour convect4.3 + REAL pori_con(klon) ! pressure at the origin level of lifted parcel + REAL plcl_con(klon),dtma_con(klon),dtlcl_con(klon) + REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev) + REAL dplcldt(klon), dplcldr(klon) +c? . condm_con(klon,klev),conda_con(klon,klev), +c? . mr_con(klon,klev),ep_con(klon,klev) +c? . ,sadiab(klon,klev),wadiab(klon,klev) +c -- +c34EK +c +c Variables du changement +c +c con: convection +c lsc: condensation a grande echelle (Large-Scale-Condensation) +c ajs: ajustement sec +c eva: evaporation de l'eau liquide nuageuse +c vdf: couche limite (Vertical DiFfusion) + REAL rneb(klon,klev) + +! tendance nulles + REAL du0(klon,klev),dv0(klon,klev),dq0(klon,klev),dql0(klon,klev) + +c +********************************************************* +* declarations + +********************************************************* +cIM 081204 END +c + REAL pmfu(klon,klev), pmfd(klon,klev) + REAL pen_u(klon,klev), pen_d(klon,klev) + REAL pde_u(klon,klev), pde_d(klon,klev) + INTEGER kcbot(klon), kctop(klon), kdtop(klon) + REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1) + REAL prfl(klon,klev+1), psfl(klon,klev+1) +c + REAL rain_lsc(klon) + REAL snow_lsc(klon) +c + REAL ratqss(klon,klev),ratqsc(klon,klev) + real ratqsbas,ratqshaut,tau_ratqs + save ratqsbas,ratqshaut,tau_ratqs +c$OMP THREADPRIVATE(ratqsbas,ratqshaut,tau_ratqs) + real zpt_conv(klon,klev) + +c Parametres lies au nouveau schema de nuages (SB, PDF) + real fact_cldcon + real facttemps + logical ok_newmicro + save ok_newmicro + real ref_liq(klon,klev), ref_ice(klon,klev) +c$OMP THREADPRIVATE(ok_newmicro) + save fact_cldcon,facttemps +c$OMP THREADPRIVATE(fact_cldcon,facttemps) + real facteur + + integer iflag_cldcon + save iflag_cldcon +c$OMP THREADPRIVATE(iflag_cldcon) + logical ptconv(klon,klev) +cIM cf. AM 081204 BEG + logical ptconvth(klon,klev) +cIM cf. AM 081204 END +c +c Variables liees a l'ecriture de la bande histoire physique +c +c====================================================================== +c +cIM cf. AM 081204 BEG +c declarations pour sortir sur une sous-region + integer imin_ins,imax_ins,jmin_ins,jmax_ins + save imin_ins,imax_ins,jmin_ins,jmax_ins +c$OMP THREADPRIVATE(imin_ins,imax_ins,jmin_ins,jmax_ins) +c real lonmin_ins,lonmax_ins,latmin_ins +c s ,latmax_ins +c data lonmin_ins,lonmax_ins,latmin_ins +c s ,latmax_ins/ +c valeurs initiales s -5.,20.,41.,55./ +c s 100.,130.,-20.,20./ +c s -180.,180.,-90.,90./ +c====================================================================== +cIM cf. AM 081204 END + +c + integer itau_w ! pas de temps ecriture = itap + itau_phy +c +c +c Variables locales pour effectuer les appels en serie +c + REAL zx_rh(klon,klev) +cIM RH a 2m (la surface) + REAL rh2m(klon), qsat2m(klon) + REAL tpot(klon), tpote(klon) + REAL Lheat + + INTEGER length + PARAMETER ( length = 100 ) + REAL tabcntr0( length ) +c + INTEGER ndex2d(iim*jjmp1),ndex3d(iim*jjmp1*klev) +cIM + INTEGER ndex2d1(iwmax) +c +cIM AMIP2 BEG + REAL moyglo, mountor +cIM 141004 BEG + REAL zustrdr(klon), zvstrdr(klon) + REAL zustrli(klon), zvstrli(klon) + REAL zustrph(klon), zvstrph(klon) + REAL zustrhi(klon), zvstrhi(klon) + REAL aam, torsfc +cIM 141004 END +cIM 190504 BEG + INTEGER ij, imp1jmp1 + PARAMETER(imp1jmp1=(iim+1)*jjmp1) +cym A voir plus tard + REAL zx_tmp(imp1jmp1), airedyn(iim+1,jjmp1) + REAL padyn(iim+1,jjmp1,klev+1) + REAL dudyn(iim+1,jjmp1,klev) + REAL rlatdyn(iim+1,jjmp1) +cIM 190504 END + LOGICAL ok_msk + REAL msk(klon) +cIM + REAL airetot, pi +cym A voir plus tard +cym REAL zm_wo(jjmp1, klev) +cIM AMIP2 END +c + REAL zx_tmp_fi2d(klon) ! variable temporaire grille physique + REAL zx_tmp_fi3d(klon,klev) ! variable temporaire pour champs 3D +c#ifdef histmthNMC +cym A voir plus tard !!!! +cym REAL zx_tmp_NC(iim,jjmp1,nlevSTD) + REAL zx_tmp_fiNC(klon,nlevSTD) +c#endif + REAL(KIND=8) zx_tmp2_fi3d(klon,klev) ! variable temporaire pour champs 3D + REAL zx_tmp_2d(iim,jjmp1), zx_tmp_3d(iim,jjmp1,klev) + REAL zx_lon(iim,jjmp1), zx_lat(iim,jjmp1) +c + INTEGER nid_day, nid_mth, nid_ins, nid_nmc, nid_day_seri + INTEGER nid_ctesGCM + SAVE nid_day, nid_mth, nid_ins, nid_nmc, nid_day_seri + SAVE nid_ctesGCM +c$OMP THREADPRIVATE(nid_day, nid_mth, nid_ins, nid_nmc) +c$OMP THREADPRIVATE(nid_day_seri,nid_ctesGCM) +c +cIM 280405 BEG + INTEGER nid_bilKPins, nid_bilKPave + SAVE nid_bilKPins, nid_bilKPave +c$OMP THREADPRIVATE(nid_bilKPins, nid_bilKPave) +c + REAL ve_lay(klon,klev) ! transport meri. de l'energie a chaque niveau vert. + REAL vq_lay(klon,klev) ! transport meri. de l'eau a chaque niveau vert. + REAL ue_lay(klon,klev) ! transport zonal de l'energie a chaque niveau vert. + REAL uq_lay(klon,klev) ! transport zonal de l'eau a chaque niveau vert. +c +cIM 280405 END +c + INTEGER nhori, nvert, nvert1, nvert3 + REAL zsto, zsto1, zsto2 + REAL zstophy, zstorad, zstohf, zstoday, zstomth, zout + REAL zcals(napisccp), zcalh(napisccp), zoutj(napisccp) + REAL zout_isccp(napisccp) + SAVE zcals, zcalh, zoutj, zout_isccp +c$OMP THREADPRIVATE(zcals, zcalh, zoutj, zout_isccp) + + real zjulian + save zjulian +c$OMP THREADPRIVATE(zjulian) + + character*20 modname + character*80 abort_message + logical ok_sync + real date0 + integer idayref + +C essai writephys + integer fid_day, fid_mth, fid_ins + parameter (fid_ins = 1, fid_day = 2, fid_mth = 3) + integer prof2d_on, prof3d_on, prof2d_av, prof3d_av + parameter (prof2d_on = 1, prof3d_on = 2, + . prof2d_av = 3, prof3d_av = 4) + character*30 nom_fichier + character*10 varname + character*40 vartitle + character*20 varunits +C Variables liees au bilan d'energie et d'enthalpi + REAL ztsol(klon) + REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + $ , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot + SAVE h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + $ , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot +c$OMP THREADPRIVATE(h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot, +c$OMP+ h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot) + REAL d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec + REAL d_h_vcol_phy + REAL fs_bound, fq_bound + SAVE d_h_vcol_phy +c$OMP THREADPRIVATE(d_h_vcol_phy) + REAL zero_v(klon) + CHARACTER*15 ztit + INTEGER ip_ebil ! PRINT level for energy conserv. diag. + SAVE ip_ebil + DATA ip_ebil/0/ +c$OMP THREADPRIVATE(ip_ebil) + INTEGER if_ebil ! level for energy conserv. dignostics + SAVE if_ebil +c$OMP THREADPRIVATE(if_ebil) +c+jld ec_conser + REAL ZRCPD +c-jld ec_conser + REAL t2m(klon,nbsrf) ! temperature a 2m + REAL q2m(klon,nbsrf) ! humidite a 2m + +cIM: t2m, q2m, u10m, v10m et t2mincels, t2maxcels + REAL zt2m(klon), zq2m(klon) !temp., hum. 2m moyenne s/ 1 maille + REAL zu10m(klon), zv10m(klon) !vents a 10m moyennes s/1 maille + CHARACTER*40 t2mincels, t2maxcels !t2m min., t2m max + CHARACTER*40 tinst, tave, typeval + REAL cldtaupi(klon,klev) ! Cloud optical thickness for pre-industrial (pi) aerosols + + REAL re(klon, klev) ! Cloud droplet effective radius + REAL fl(klon, klev) ! denominator of re + + REAL re_top(klon), fl_top(klon) ! CDR at top of liquid water clouds + + ! Aerosol optical properties + CHARACTER*4, DIMENSION(naero_grp) :: rfname + REAL, DIMENSION(klon) :: aerindex ! POLDER aerosol index + REAL, DIMENSION(klon,klev) :: mass_solu_aero ! total mass concentration for all soluble aerosols[ug/m3] + REAL, DIMENSION(klon,klev) :: mass_solu_aero_pi ! - " - (pre-industrial value) + INTEGER :: naero ! aerosol species + + ! Parameters + LOGICAL ok_ade, ok_aie ! Apply aerosol (in)direct effects or not + REAL bl95_b0, bl95_b1 ! Parameter in Boucher and Lohmann (1995) + SAVE ok_ade, ok_aie, bl95_b0, bl95_b1 +c$OMP THREADPRIVATE(ok_ade, ok_aie, bl95_b0, bl95_b1) + LOGICAL, SAVE :: aerosol_couple ! true : calcul des aerosols dans INCA + ! false : lecture des aerosol dans un fichier +c$OMP THREADPRIVATE(aerosol_couple) + INTEGER, SAVE :: flag_aerosol +c$OMP THREADPRIVATE(flag_aerosol) + LOGICAL, SAVE :: new_aod +c$OMP THREADPRIVATE(new_aod) + +c +c Declaration des constantes et des fonctions thermodynamiques +c + LOGICAL,SAVE :: first=.true. +c$OMP THREADPRIVATE(first) + + integer iunit + + integer, save:: read_climoz ! read ozone climatology +C Allowed values are 0, 1 and 2 +C 0: do not read an ozone climatology +C 1: read a single ozone climatology that will be used day and night +C 2: read two ozone climatologies, the average day and night +C climatology and the daylight climatology + + integer, save:: ncid_climoz ! NetCDF file containing ozone climatologies + + real, pointer, save:: press_climoz(:) +! edges of pressure intervals for ozone climatologies, in Pa, in strictly +! ascending order + + integer, save:: co3i = 0 +! time index in NetCDF file of current ozone fields +c$OMP THREADPRIVATE(co3i) + + integer ro3i +! required time index in NetCDF file for the ozone fields, between 1 +! and 360 + +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +cIM 100106 BEG : pouvoir sortir les ctes de la physique +#include "conema3.h" +#include "fisrtilp.h" +#include "nuage.h" +#include "compbl.h" +cIM 100106 END : pouvoir sortir les ctes de la physique +c +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c Declarations pour Simulateur COSP +c============================================================ + real :: mr_ozone(klon,klev) +c====================================================================== +! Ecriture eventuelle d'un profil verticale en entree de la physique. +! Utilise notamment en 1D mais peut etre active egalement en 3D +! en imposant la valeur de igout. +c====================================================================== + + if (prt_level.ge.1) then + igout=klon/2+1/klon + write(lunout,*) 'DEBUT DE PHYSIQ !!!!!!!!!!!!!!!!!!!!' + write(lunout,*) + s 'nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys' + write(lunout,*) + s nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys + + write(lunout,*) 'paprs, play, phi, u, v, t' + do k=1,klev + write(lunout,*) paprs(igout,k),pplay(igout,k),pphi(igout,k), + s u(igout,k),v(igout,k),t(igout,k) + enddo + write(lunout,*) 'ovap (g/kg), oliq (g/kg)' + do k=1,klev + write(lunout,*) qx(igout,k,1)*1000,qx(igout,k,2)*1000. + enddo + endif + +c====================================================================== + +cym => necessaire pour iflag_con != 2 + pmfd(:,:) = 0. + pen_u(:,:) = 0. + pen_d(:,:) = 0. + pde_d(:,:) = 0. + pde_u(:,:) = 0. + aam=0. + + torsfc=0. + forall (k=1: llm) zmasse(:, k) = (paprs(:, k)-paprs(:, k+1)) / rg + + if (first) then + +cCR:nvelles variables convection/poches froides + + print*, '=================================================' + print*, 'Allocation des variables locales et sauvegardees' + call phys_local_var_init +c appel a la lecture du run.def physique + call conf_phys(ok_journe, ok_mensuel, + . ok_instan, ok_hf, + . ok_LES, + . solarlong0,seuil_inversion, + . fact_cldcon, facttemps,ok_newmicro,iflag_radia, + . iflag_cldcon,iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, + . ok_ade, ok_aie, aerosol_couple, + . flag_aerosol, new_aod, + . bl95_b0, bl95_b1, + . iflag_thermals,nsplit_thermals,tau_thermals, + . iflag_thermals_ed,iflag_thermals_optflux, +c nv flags pour la convection et les poches froides + . iflag_coupl,iflag_clos,iflag_wake, read_climoz) + call phys_state_var_init(read_climoz) + print*, '=================================================' + +cIM beg + dnwd0=0.0 + ftd=0.0 + fqd=0.0 + cin=0. +cym Attention pbase pas initialise dans concvl !!!! + pbase=0 + paire_ter(:)=0. +cIM 180608 +c pmflxr=0. +c pmflxs=0. + first=.false. + + endif ! first + + modname = 'physiq' +cIM + IF (ip_ebil_phy.ge.1) THEN + DO i=1,klon + zero_v(i)=0. + END DO + END IF + ok_sync=.TRUE. + + IF (debut) THEN + CALL suphel ! initialiser constantes et parametres phys. + ENDIF + + if(prt_level.ge.1) print*,'CONVERGENCE PHYSIQUE THERM 1 ' + + +c====================================================================== +! Gestion calendrier : mise a jour du module phys_cal_mod +! + CALL phys_cal_update(jD_cur,jH_cur) + +c +c Si c'est le debut, il faut initialiser plusieurs choses +c ******** +c + IF (debut) THEN +!rv +cCRinitialisation de wght_th et lalim_conv pour la definition de la couche alimentation +cde la convection a partir des caracteristiques du thermique + wght_th(:,:)=1. + lalim_conv(:)=1 +cRC + u10m(:,:)=0. + v10m(:,:)=0. + rain_con(:)=0. + snow_con(:)=0. + topswai(:)=0. + topswad(:)=0. + solswai(:)=0. + solswad(:)=0. + + lambda_th(:,:)=0. + wmax_th(:)=0. + tau_overturning_th(:)=0. + + IF (config_inca /= 'none') THEN + ! jg : initialisation jusqu'au ces variables sont dans restart + ccm(:,:,:) = 0. + tau_aero(:,:,:,:) = 0. + piz_aero(:,:,:,:) = 0. + cg_aero(:,:,:,:) = 0. + END IF + + rnebcon0(:,:) = 0.0 + clwcon0(:,:) = 0.0 + rnebcon(:,:) = 0.0 + clwcon(:,:) = 0.0 + +cIM + IF (ip_ebil_phy.ge.1) d_h_vcol_phy=0. +c + print*,'iflag_coupl,iflag_clos,iflag_wake', + . iflag_coupl,iflag_clos,iflag_wake + print*,'CYCLE_DIURNE', cycle_diurne +c + IF (iflag_con.EQ.2.AND.iflag_cldcon.GT.-1) THEN + abort_message = 'Tiedtke needs iflag_cldcon=-2 or -1' + CALL abort_gcm (modname,abort_message,1) + ENDIF +c + IF(ok_isccp.AND.iflag_con.LE.2) THEN + abort_message = 'ISCCP-like outputs may be available for KE + .(iflag_con >= 3); for Tiedtke (iflag_con=-2) put ok_isccp=n' + CALL abort_gcm (modname,abort_message,1) + ENDIF +c +c Initialiser les compteurs: +c + itap = 0 + itaprad = 0 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Un petit travail à faire ici. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (iflag_pbl>1) then + PRINT*, "Using method MELLOR&YAMADA" + endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH 2008/05/02 changement lie a la lecture de nbapp_rad dans phylmd plutot que +! dyn3d +! Attention : la version precedente n'etait pas tres propre. +! Il se peut qu'il faille prendre une valeur differente de nbapp_rad +! pour obtenir le meme resultat. + dtime=pdtphys + radpas = NINT( 86400./dtime/nbapp_rad) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + CALL phyetat0 ("startphy.nc",clesphy0,tabcntr0) +cIM begin + print*,'physiq: clwcon rnebcon ratqs',clwcon(1,1),rnebcon(1,1) + $,ratqs(1,1) +cIM end + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +C on remet le calendrier a zero +c + IF (raz_date .eq. 1) THEN + itau_phy = 0 + ENDIF + +cIM cf. AM 081204 BEG + PRINT*,'cycle_diurne3 =',cycle_diurne +cIM cf. AM 081204 END +c + CALL printflag( tabcntr0,radpas,ok_journe, + , ok_instan, ok_region ) +c + IF (ABS(dtime-pdtphys).GT.0.001) THEN + WRITE(lunout,*) 'Pas physique n est pas correct',dtime, + . pdtphys + abort_message='Pas physique n est pas correct ' +! call abort_gcm(modname,abort_message,1) + dtime=pdtphys + ENDIF + IF (nlon .NE. klon) THEN + WRITE(lunout,*)'nlon et klon ne sont pas coherents', nlon, + . klon + abort_message='nlon et klon ne sont pas coherents' + call abort_gcm(modname,abort_message,1) + ENDIF + IF (nlev .NE. klev) THEN + WRITE(lunout,*)'nlev et klev ne sont pas coherents', nlev, + . klev + abort_message='nlev et klev ne sont pas coherents' + call abort_gcm(modname,abort_message,1) + ENDIF +c + IF (dtime*FLOAT(radpas).GT.21600..AND.cycle_diurne) THEN + WRITE(lunout,*)'Nbre d appels au rayonnement insuffisant' + WRITE(lunout,*)"Au minimum 4 appels par jour si cycle diurne" + abort_message='Nbre d appels au rayonnement insuffisant' + call abort_gcm(modname,abort_message,1) + ENDIF + WRITE(lunout,*)"Clef pour la convection, iflag_con=", iflag_con + WRITE(lunout,*)"Clef pour le driver de la convection, ok_cvl=", + . ok_cvl +c +cKE43 +c Initialisation pour la convection de K.E. (sb): + IF (iflag_con.GE.3) THEN + + WRITE(lunout,*)"*** Convection de Kerry Emanuel 4.3 " + WRITE(lunout,*) + . "On va utiliser le melange convectif des traceurs qui" + WRITE(lunout,*)"est calcule dans convect4.3" + WRITE(lunout,*)" !!! penser aux logical flags de phytrac" + + DO i = 1, klon + ema_cbmf(i) = 0. + ema_pcb(i) = 0. + ema_pct(i) = 0. + ema_workcbmf(i) = 0. + ENDDO +cIM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>BEG + DO i = 1, klon + ibas_con(i) = 1 + itop_con(i) = 1 + ENDDO +cIM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>END +c=============================================================================== +cCR:04.12.07: initialisations poches froides +c Controle de ALE et ALP pour la fermeture convective (jyg) + if (iflag_wake.eq.1) then + CALL ini_wake(0.,0.,it_wape_prescr,wape_prescr,fip_prescr + s ,alp_bl_prescr, ale_bl_prescr) +c 11/09/06 rajout initialisation ALE et ALP du wake et PBL(YU) +c print*,'apres ini_wake iflag_cldcon=', iflag_cldcon + endif + + do i = 1,klon + Ale_bl(i)=0. + Alp_bl(i)=0. + enddo + +c================================================================================ + + ENDIF + + DO i=1,klon + rugoro(i) = f_rugoro * MAX(1.0e-05, zstd(i)*zsig(i)/2.0) + ENDDO + +c34EK + IF (ok_orodr) THEN + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH sans doute a enlever de finitivement ou, si on le garde, l'activer +! justement quand ok_orodr = false. +! ce rugoro est utilise par la couche limite et fait double emploi +! avec les paramétrisations spécifiques de Francois Lott. +! DO i=1,klon +! rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0) +! ENDDO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF (ok_strato) THEN + CALL SUGWD_strato(klon,klev,paprs,pplay) + ELSE + CALL SUGWD(klon,klev,paprs,pplay) + ENDIF + + DO i=1,klon + zuthe(i)=0. + zvthe(i)=0. + if(zstd(i).gt.10.)then + zuthe(i)=(1.-zgam(i))*cos(zthe(i)) + zvthe(i)=(1.-zgam(i))*sin(zthe(i)) + endif + ENDDO + ENDIF +c +c + lmt_pas = NINT(86400./dtime * 1.0) ! tous les jours + WRITE(lunout,*)'La frequence de lecture surface est de ', + . lmt_pas +c +cIM 030306 END + + capemaxcels = 't_max(X)' + t2mincels = 't_min(X)' + t2maxcels = 't_max(X)' + tinst = 'inst(X)' + tave = 'ave(X)' +cIM cf. AM 081204 BEG + write(lunout,*)'AVANT HIST IFLAG_CON=',iflag_con +cIM cf. AM 081204 END +c +c============================================================= +c Initialisation des sorties +c============================================================= + +#ifdef CPP_IOIPSL + +c$OMP MASTER + call phys_output_open(jjmp1,nlevSTD,clevSTD,nbteta, + & ctetaSTD,dtime,ok_veget, + & type_ocean,iflag_pbl,ok_mensuel,ok_journe, + & ok_hf,ok_instan,ok_LES,ok_ade,ok_aie, + & read_climoz, new_aod, aerosol_couple) +c$OMP END MASTER +c$OMP BARRIER + +#ifdef histISCCP +#include "ini_histISCCP.h" +#endif + +#ifdef histmthNMC +#include "ini_histmthNMC.h" +#endif + +#include "ini_histday_seri.h" + +#include "ini_paramLMDZ_phy.h" + +#endif + +cIM 250308bad guide ecrit_hf2mth = 30*1/ecrit_hf + ecrit_hf2mth = ecrit_mth/ecrit_hf + + ecrit_hf = ecrit_hf * un_jour +!IM + IF(ecrit_day.LE.1.) THEN + ecrit_day = ecrit_day * un_jour !en secondes + ENDIF +!IM + ecrit_mth = ecrit_mth * un_jour + ecrit_ins = ecrit_ins * un_jour + ecrit_reg = ecrit_reg * un_jour + ecrit_tra = ecrit_tra * un_jour + ecrit_ISCCP = ecrit_ISCCP * un_jour + ecrit_LES = ecrit_LES * un_jour +c + PRINT*,'physiq ecrit_ hf day mth reg tra ISCCP hf2mth', + . ecrit_hf,ecrit_day,ecrit_mth,ecrit_reg,ecrit_tra,ecrit_ISCCP, + . ecrit_hf2mth +cIM 030306 END + + +cXXXPB Positionner date0 pour initialisation de ORCHIDEE + date0 = jD_ref + WRITE(*,*) 'physiq date0 : ',date0 +c +c +c +c Prescrire l'ozone dans l'atmosphere +c +c +cc DO i = 1, klon +cc DO k = 1, klev +cc CALL o3cm (paprs(i,k)/100.,paprs(i,k+1)/100., wo(i,k),20) +cc ENDDO +cc ENDDO +c + IF (config_inca /= 'none') THEN +#ifdef INCA + CALL VTe(VTphysiq) + CALL VTb(VTinca) +! iii = MOD(NINT(xjour),360) +! calday = FLOAT(iii) + jH_cur + calday = FLOAT(days_elapsed) + jH_cur + WRITE(lunout,*) 'initial time chemini', days_elapsed, calday + + CALL chemini( + $ rg, + $ ra, + $ airephy, + $ rlat, + $ rlon, + $ presnivs, + $ calday, + $ klon, + $ nqtot, + $ pdtphys, + $ annee_ref, + $ day_ref, + $ itau_phy) + + CALL VTe(VTinca) + CALL VTb(VTphysiq) +#endif + END IF +c +c +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Nouvelle initialisation pour le rayonnement RRTM +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call iniradia(klon,klev,paprs(1,1:klev+1)) + +C$omp single + if (read_climoz >= 1) then + call open_climoz(ncid_climoz, press_climoz) + END IF +C$omp end single + ENDIF +! +! **************** Fin de IF ( debut ) *************** +! +! +! Incrementer le compteur de la physique +! + itap = itap + 1 +! +! Update fraction of the sub-surfaces (pctsrf) and +! initialize, where a new fraction has appeared, all variables depending +! on the surface fraction. +! + CALL change_srf_frac(itap, dtime, days_elapsed+1, + * pctsrf, falb1, falb2, ftsol, u10m, v10m, pbl_tke) + +! Tendances bidons pour les processus qui n'affectent pas certaines +! variables. + du0(:,:)=0. + dv0(:,:)=0. + dq0(:,:)=0. + dql0(:,:)=0. +c +c Mettre a zero des variables de sortie (pour securite) +c + DO i = 1, klon + d_ps(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_u(i,k) = 0.0 + d_v(i,k) = 0.0 + ENDDO + ENDDO + DO iq = 1, nqtot + DO k = 1, klev + DO i = 1, klon + d_qx(i,k,iq) = 0.0 + ENDDO + ENDDO + ENDDO + da(:,:)=0. + mp(:,:)=0. + phi(:,:,:)=0. +c +c Ne pas affecter les valeurs entrees de u, v, h, et q +c + DO k = 1, klev + DO i = 1, klon + t_seri(i,k) = t(i,k) + u_seri(i,k) = u(i,k) + v_seri(i,k) = v(i,k) + q_seri(i,k) = qx(i,k,ivap) + ql_seri(i,k) = qx(i,k,iliq) + qs_seri(i,k) = 0. + ENDDO + ENDDO + IF (nqtot.GE.3) THEN + DO iq = 3, nqtot + DO k = 1, klev + DO i = 1, klon + tr_seri(i,k,iq-2) = qx(i,k,iq) + ENDDO + ENDDO + ENDDO + ELSE + DO k = 1, klev + DO i = 1, klon + tr_seri(i,k,1) = 0.0 + ENDDO + ENDDO + ENDIF +C + DO i = 1, klon + ztsol(i) = 0. + ENDDO + DO nsrf = 1, nbsrf + DO i = 1, klon + ztsol(i) = ztsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf) + ENDDO + ENDDO +cIM + IF (ip_ebil_phy.ge.1) THEN + ztit='after dynamic' + CALL diagetpq(airephy,ztit,ip_ebil_phy,1,1,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) +C Comme les tendances de la physique sont ajoute dans la dynamique, +C on devrait avoir que la variation d'entalpie par la dynamique +C est egale a la variation de la physique au pas de temps precedent. +C Donc la somme de ces 2 variations devrait etre nulle. + call diagphy(airephy,ztit,ip_ebil_phy + e , zero_v, zero_v, zero_v, zero_v, zero_v + e , zero_v, zero_v, zero_v, ztsol + e , d_h_vcol+d_h_vcol_phy, d_qt, 0. + s , fs_bound, fq_bound ) + END IF + +c Diagnostiquer la tendance dynamique +c + IF (ancien_ok) THEN + DO k = 1, klev + DO i = 1, klon + d_u_dyn(i,k) = (u_seri(i,k)-u_ancien(i,k))/dtime + d_v_dyn(i,k) = (v_seri(i,k)-v_ancien(i,k))/dtime + d_t_dyn(i,k) = (t_seri(i,k)-t_ancien(i,k))/dtime + d_q_dyn(i,k) = (q_seri(i,k)-q_ancien(i,k))/dtime + ENDDO + ENDDO + ELSE + DO k = 1, klev + DO i = 1, klon + d_u_dyn(i,k) = 0.0 + d_v_dyn(i,k) = 0.0 + d_t_dyn(i,k) = 0.0 + d_q_dyn(i,k) = 0.0 + ENDDO + ENDDO + ancien_ok = .TRUE. + ENDIF +c +c Ajouter le geopotentiel du sol: +c + DO k = 1, klev + DO i = 1, klon + zphi(i,k) = pphi(i,k) + pphis(i) + ENDDO + ENDDO +c +c Verifier les temperatures +c +cIM BEG + IF (check) THEN + amn=MIN(ftsol(1,is_ter),1000.) + amx=MAX(ftsol(1,is_ter),-1000.) + DO i=2, klon + amn=MIN(ftsol(i,is_ter),amn) + amx=MAX(ftsol(i,is_ter),amx) + ENDDO +c + PRINT*,' debut avant hgardfou min max ftsol',itap,amn,amx + ENDIF !(check) THEN +cIM END +c + CALL hgardfou(t_seri,ftsol,'debutphy') +c +cIM BEG + IF (check) THEN + amn=MIN(ftsol(1,is_ter),1000.) + amx=MAX(ftsol(1,is_ter),-1000.) + DO i=2, klon + amn=MIN(ftsol(i,is_ter),amn) + amx=MAX(ftsol(i,is_ter),amx) + ENDDO +c + PRINT*,' debut apres hgardfou min max ftsol',itap,amn,amx + ENDIF !(check) THEN +cIM END +c +c Mettre en action les conditions aux limites (albedo, sst, etc.). +c Prescrire l'ozone et calculer l'albedo sur l'ocean. +c + if (read_climoz >= 1) then +C Ozone from a file +! Update required ozone index: + ro3i = int((days_elapsed + jh_cur - jh_1jan) + $ / ioget_year_len(year_cur) * 360.) + 1 + if (ro3i == 361) ro3i = 360 +C (This should never occur, except perhaps because of roundup +C error. See documentation.) + if (ro3i /= co3i) then +C Update ozone field: + if (read_climoz == 1) then + call regr_pr_av(ncid_climoz, (/"tro3"/), julien=ro3i, + $ press_in_edg=press_climoz, paprs=paprs, v3=wo) + else +C read_climoz == 2 + call regr_pr_av(ncid_climoz, + $ (/"tro3 ", "tro3_daylight"/), + $ julien=ro3i, press_in_edg=press_climoz, paprs=paprs, + $ v3=wo) + end if +! Convert from mole fraction of ozone to column density of ozone in a +! cell, in kDU: + forall (l = 1: read_climoz) wo(:, :, l) = wo(:, :, l) + $ * rmo3 / rmd * zmasse / dobson_u / 1e3 +C (By regridding ozone values for LMDZ only once every 360th of +C year, we have already neglected the variation of pressure in one +C 360th of year. So do not recompute "wo" at each time step even if +C "zmasse" changes a little.) + co3i = ro3i + end if + elseif (MOD(itap-1,lmt_pas) == 0) THEN +C Once per day, update ozone from Royer: + wo(:, :, 1) = ozonecm(rlat, paprs, rjour=real(days_elapsed+1)) + ENDIF +c +c Re-evaporer l'eau liquide nuageuse +c + DO k = 1, klev ! re-evaporation de l'eau liquide nuageuse + DO i = 1, klon + zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k)) +c zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q_seri(i,k)) + zlsdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k)) + zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k))) + zb = MAX(0.0,ql_seri(i,k)) + za = - MAX(0.0,ql_seri(i,k)) + . * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta) + t_seri(i,k) = t_seri(i,k) + za + q_seri(i,k) = q_seri(i,k) + zb + ql_seri(i,k) = 0.0 + d_t_eva(i,k) = za + d_q_eva(i,k) = zb + ENDDO + ENDDO +cIM + IF (ip_ebil_phy.ge.2) THEN + ztit='after reevap' + CALL diagetpq(airephy,ztit,ip_ebil_phy,2,1,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(airephy,ztit,ip_ebil_phy + e , zero_v, zero_v, zero_v, zero_v, zero_v + e , zero_v, zero_v, zero_v, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) +C + END IF + +c +c========================================================================= +! Calculs de l'orbite. +! Necessaires pour le rayonnement et la surface (calcul de l'albedo). +! doit donc etre placé avant radlwsw et pbl_surface + +! calcul selon la routine utilisee pour les planetes + if (new_orbit) then + call ymds2ju(year_cur, mth_eq, day_eq,0., jD_eq) + day_since_equinox = (jD_cur + jH_cur) - jD_eq +! day_since_equinox = (jD_cur) - jD_eq + call solarlong(day_since_equinox, zlongi, dist) + else +! calcul selon la routine utilisee pour l'AR4 +! choix entre calcul de la longitude solaire vraie ou valeur fixee a +! solarlong0 + if (solarlong0<-999.) then + CALL orbite(FLOAT(days_elapsed+1),zlongi,dist) + else + zlongi=solarlong0 ! longitude solaire vraie + dist=1. ! distance au soleil / moyenne + endif + endif + if(prt_level.ge.1) & + & write(lunout,*)'Longitude solaire ',zlongi,solarlong0,dist + +! Avec ou sans cycle diurne + IF (cycle_diurne) THEN + zdtime=dtime*FLOAT(radpas) ! pas de temps du rayonnement (s) + CALL zenang(zlongi,jH_cur,zdtime,rlat,rlon,rmu0,fract) + ELSE + CALL angle(zlongi, rlat, fract, rmu0) + ENDIF + + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c Appel au pbl_surface : Planetary Boudary Layer et Surface +c Cela implique tous les interactions des sous-surfaces et la partie diffusion +c turbulent du couche limit. +c +c Certains varibales de sorties de pbl_surface sont utiliser que pour +c ecriture des fihiers hist_XXXX.nc, ces sont : +c qsol, zq2m, s_pblh, s_lcl, +c s_capCL, s_oliqCL, s_cteiCL,s_pblT, +c s_therm, s_trmb1, s_trmb2, s_trmb3, +c zxrugs, zu10m, zv10m, fder, +c zxqsurf, rh2m, zxfluxu, zxfluxv, +c frugs, agesno, fsollw, fsolsw, +c d_ts, fevap, fluxlat, t2m, +c wfbils, wfbilo, fluxt, fluxu, fluxv, +c +c Certains ne sont pas utiliser du tout : +c dsens, devap, zxsnow, zxfluxt, zxfluxq, q2m, fluxq +c + + CALL pbl_surface( + e dtime, date0, itap, days_elapsed+1, + e debut, lafin, + e rlon, rlat, rugoro, rmu0, + e rain_fall, snow_fall, solsw, sollw, + e t_seri, q_seri, u_seri, v_seri, + e pplay, paprs, pctsrf, + + ftsol, falb1, falb2, u10m, v10m, + s sollwdown, cdragh, cdragm, u1, v1, + s albsol1, albsol2, sens, evap, + s zxtsol, zxfluxlat, zt2m, qsat2m, + s d_t_vdf, d_q_vdf, d_u_vdf, d_v_vdf, + s coefh, slab_wfbils, + d qsol, zq2m, s_pblh, s_lcl, + d s_capCL, s_oliqCL, s_cteiCL,s_pblT, + d s_therm, s_trmb1, s_trmb2, s_trmb3, + d zxrugs, zu10m, zv10m, fder, + d zxqsurf, rh2m, zxfluxu, zxfluxv, + d frugs, agesno, fsollw, fsolsw, + d d_ts, fevap, fluxlat, t2m, + d wfbils, wfbilo, fluxt, fluxu, fluxv, + - dsens, devap, zxsnow, + - zxfluxt, zxfluxq, q2m, fluxq, pbl_tke ) + + +!----------------------------------------------------------------------------------------- +! ajout des tendances de la diffusion turbulente + CALL add_phys_tend(d_u_vdf,d_v_vdf,d_t_vdf,d_q_vdf,dql0,'vdf') +!----------------------------------------------------------------------------------------- + + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + + + IF (ip_ebil_phy.ge.2) THEN + ztit='after surface_main' + CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(airephy,ztit,ip_ebil_phy + e , zero_v, zero_v, zero_v, zero_v, sens + e , evap , zero_v, zero_v, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) + END IF + +c =================================================================== c +c Calcul de Qsat + + DO k = 1, klev + DO i = 1, klon + zx_t = t_seri(i,k) + IF (thermcep) THEN + zdelta = MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k) + zx_qs = MIN(0.5,zx_qs) + zcor = 1./(1.-retv*zx_qs) + zx_qs = zx_qs*zcor + ELSE + IF (zx_t.LT.t_coup) THEN + zx_qs = qsats(zx_t)/pplay(i,k) + ELSE + zx_qs = qsatl(zx_t)/pplay(i,k) + ENDIF + ENDIF + zqsat(i,k)=zx_qs + ENDDO + ENDDO + + if (prt_level.ge.1) then + write(lunout,*) 'L qsat (g/kg) avant clouds_gno' + write(lunout,'(i4,f15.4)') (k,1000.*zqsat(igout,k),k=1,klev) + endif +c +c Appeler la convection (au choix) +c + DO k = 1, klev + DO i = 1, klon + conv_q(i,k) = d_q_dyn(i,k) + . + d_q_vdf(i,k)/dtime + conv_t(i,k) = d_t_dyn(i,k) + . + d_t_vdf(i,k)/dtime + ENDDO + ENDDO + IF (check) THEN + za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy) + WRITE(lunout,*) "avantcon=", za + ENDIF + zx_ajustq = .FALSE. + IF (iflag_con.EQ.2) zx_ajustq=.TRUE. + IF (zx_ajustq) THEN + DO i = 1, klon + z_avant(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + z_avant(i) = z_avant(i) + (q_seri(i,k)+ql_seri(i,k)) + . *(paprs(i,k)-paprs(i,k+1))/RG + ENDDO + ENDDO + ENDIF + +c Calcule de vitesse verticale a partir de flux de masse verticale + DO k = 1, klev + DO i = 1, klon + omega(i,k) = RG*flxmass_w(i,k) / airephy(i) + END DO + END DO + if (prt_level.ge.1) write(lunout,*) 'omega(igout, :) = ', + $ omega(igout, :) + + IF (iflag_con.EQ.1) THEN + stop'reactiver le call conlmd dans physiq.F' +c CALL conlmd (dtime, paprs, pplay, t_seri, q_seri, conv_q, +c . d_t_con, d_q_con, +c . rain_con, snow_con, ibas_con, itop_con) + ELSE IF (iflag_con.EQ.2) THEN + CALL conflx(dtime, paprs, pplay, t_seri, q_seri, + e conv_t, conv_q, -evap, omega, + s d_t_con, d_q_con, rain_con, snow_con, + s pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, + s kcbot, kctop, kdtop, pmflxr, pmflxs) + d_u_con = 0. + d_v_con = 0. + + WHERE (rain_con < 0.) rain_con = 0. + WHERE (snow_con < 0.) snow_con = 0. + DO i = 1, klon + ibas_con(i) = klev+1 - kcbot(i) + itop_con(i) = klev+1 - kctop(i) + ENDDO + ELSE IF (iflag_con.GE.3) THEN +c nb of tracers for the KE convection: +c MAF la partie traceurs est faite dans phytrac +c on met ntra=1 pour limiter les appels mais on peut +c supprimer les calculs / ftra. + ntra = 1 + +c===================================================================================== +cajout pour la parametrisation des poches froides: +ccalcul de t_wake et t_undi: si pas de poches froides, t_wake=t_undi=t_seri + do k=1,klev + do i=1,klon + if (iflag_wake.eq.1) then + t_wake(i,k) = t_seri(i,k) + . +(1-wake_s(i))*wake_deltat(i,k) + q_wake(i,k) = q_seri(i,k) + . +(1-wake_s(i))*wake_deltaq(i,k) + t_undi(i,k) = t_seri(i,k) + . -wake_s(i)*wake_deltat(i,k) + q_undi(i,k) = q_seri(i,k) + . -wake_s(i)*wake_deltaq(i,k) + else + t_wake(i,k) = t_seri(i,k) + q_wake(i,k) = q_seri(i,k) + t_undi(i,k) = t_seri(i,k) + q_undi(i,k) = q_seri(i,k) + endif + enddo + enddo + +cc-- Calcul de l'energie disponible ALE (J/kg) et de la puissance disponible ALP (W/m2) +cc-- pour le soulevement des particules dans le modele convectif +c + do i = 1,klon + ALE(i) = 0. + ALP(i) = 0. + enddo +c +ccalcul de ale_wake et alp_wake + do i = 1,klon + if (iflag_wake.eq.1) then + ale_wake(i) = 0.5*wake_cstar(i)**2 + alp_wake(i) = wake_fip(i) + else + ale_wake(i) = 0. + alp_wake(i) = 0. + endif + enddo +ccombinaison avec ale et alp de couche limite: constantes si pas de couplage, valeurs calculees +cdans le thermique sinon + if (iflag_coupl.eq.0) then + if (debut) print*,'ALE et ALP imposes' + do i = 1,klon +con ne couple que ale +c ALE(i) = max(ale_wake(i),Ale_bl(i)) + ALE(i) = max(ale_wake(i),ale_bl_prescr) +con ne couple que alp +c ALP(i) = alp_wake(i) + Alp_bl(i) + ALP(i) = alp_wake(i) + alp_bl_prescr + enddo + else + IF(prt_level>9)WRITE(lunout,*)'ALE et ALP couples au thermique' + do i = 1,klon + ALE(i) = max(ale_wake(i),Ale_bl(i)) + ALP(i) = alp_wake(i) + Alp_bl(i) +c write(20,*)'ALE',ALE(i),Ale_bl(i),ale_wake(i) +c write(21,*)'ALP',ALP(i),Alp_bl(i),alp_wake(i) + enddo + endif + do i=1,klon + if (alp(i)>alp_max) then + IF(prt_level>9)WRITE(lunout,*) & + & 'WARNING SUPER ALP (seuil=',alp_max, + , '): i, alp, alp_wake,ale',i,alp(i),alp_wake(i),ale(i) + alp(i)=alp_max + endif + if (ale(i)>ale_max) then + IF(prt_level>9)WRITE(lunout,*) & + & 'WARNING SUPER ALE (seuil=',ale_max, + , '): i, alp, alp_wake,ale',i,ale(i),ale_wake(i),alp(i) + ale(i)=ale_max + endif + enddo + +cfin calcul ale et alp +c================================================================================================= + + +c sb, oct02: +c Schema de convection modularise et vectorise: +c (driver commun aux versions 3 et 4) +c + IF (ok_cvl) THEN ! new driver for convectL + + CALL concvl (iflag_con,iflag_clos, + . dtime,paprs,pplay,t_undi,q_undi, + . t_wake,q_wake,wake_s, + . u_seri,v_seri,tr_seri,nbtr, + . ALE,ALP, + . ema_work1,ema_work2, + . d_t_con,d_q_con,d_u_con,d_v_con,d_tr, + . rain_con, snow_con, ibas_con, itop_con, sigd, + . upwd,dnwd,dnwd0, + . Ma,mip,Vprecip,cape,cin,tvp,Tconv,iflagctrl, + . pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,qcondc,wd, + . pmflxr,pmflxs,da,phi,mp, + . ftd,fqd,lalim_conv,wght_th) + +cIM begin +c print*,'physiq: cin pbase dnwd0 ftd fqd ',cin(1),pbase(1), +c .dnwd0(1,1),ftd(1,1),fqd(1,1) +cIM end +cIM cf. FH + clwcon0=qcondc + pmfu(:,:)=upwd(:,:)+dnwd(:,:) + + ELSE ! ok_cvl +c MAF conema3 ne contient pas les traceurs + CALL conema3 (dtime, + . paprs,pplay,t_seri,q_seri, + . u_seri,v_seri,tr_seri,ntra, + . ema_work1,ema_work2, + . d_t_con,d_q_con,d_u_con,d_v_con,d_tr, + . rain_con, snow_con, ibas_con, itop_con, + . upwd,dnwd,dnwd0,bas,top, + . Ma,cape,tvp,rflag, + . pbase + . ,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr + . ,clwcon0) + + ENDIF ! ok_cvl + +c +c Correction precip + rain_con = rain_con * cvl_corr + snow_con = snow_con * cvl_corr +c + + IF (.NOT. ok_gust) THEN + do i = 1, klon + wd(i)=0.0 + enddo + ENDIF + +c =================================================================== c +c Calcul des proprietes des nuages convectifs +c + +c calcul des proprietes des nuages convectifs + clwcon0(:,:)=fact_cldcon*clwcon0(:,:) + call clouds_gno + s (klon,klev,q_seri,zqsat,clwcon0,ptconv,ratqsc,rnebcon0) + +c =================================================================== c + + DO i = 1, klon + ema_pcb(i) = pbase(i) + ENDDO + DO i = 1, klon + +! L'idicage de itop_con peut cacher un pb potentiel +! FH sous la dictee de JYG, CR + ema_pct(i) = paprs(i,itop_con(i)+1) + + if (itop_con(i).gt.klev-3) then + if(prt_level >= 9) then + write(lunout,*)'La convection monte trop haut ' + write(lunout,*)'itop_con(,',i,',)=',itop_con(i) + endif + endif + ENDDO + DO i = 1, klon + ema_cbmf(i) = ema_workcbmf(i) + ENDDO + ELSE IF (iflag_con.eq.0) THEN + write(lunout,*) 'On n appelle pas la convection' + clwcon0=0. + rnebcon0=0. + d_t_con=0. + d_q_con=0. + d_u_con=0. + d_v_con=0. + rain_con=0. + snow_con=0. + bas=1 + top=1 + ELSE + WRITE(lunout,*) "iflag_con non-prevu", iflag_con + CALL abort + ENDIF + +c CALL homogene(paprs, q_seri, d_q_con, u_seri,v_seri, +c . d_u_con, d_v_con) + +!----------------------------------------------------------------------------------------- +! ajout des tendances de la diffusion turbulente + CALL add_phys_tend(d_u_con,d_v_con,d_t_con,d_q_con,dql0,'con') +!----------------------------------------------------------------------------------------- + + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + +cIM + IF (ip_ebil_phy.ge.2) THEN + ztit='after convect' + CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(airephy,ztit,ip_ebil_phy + e , zero_v, zero_v, zero_v, zero_v, zero_v + e , zero_v, rain_con, snow_con, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) + END IF +C + IF (check) THEN + za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy) + WRITE(lunout,*)"aprescon=", za + zx_t = 0.0 + za = 0.0 + DO i = 1, klon + za = za + airephy(i)/FLOAT(klon) + zx_t = zx_t + (rain_con(i)+ + . snow_con(i))*airephy(i)/FLOAT(klon) + ENDDO + zx_t = zx_t/za*dtime + WRITE(lunout,*)"Precip=", zx_t + ENDIF + IF (zx_ajustq) THEN + DO i = 1, klon + z_apres(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + z_apres(i) = z_apres(i) + (q_seri(i,k)+ql_seri(i,k)) + . *(paprs(i,k)-paprs(i,k+1))/RG + ENDDO + ENDDO + DO i = 1, klon + z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*dtime) + . /z_apres(i) + ENDDO + DO k = 1, klev + DO i = 1, klon + IF (z_factor(i).GT.(1.0+1.0E-08) .OR. + . z_factor(i).LT.(1.0-1.0E-08)) THEN + q_seri(i,k) = q_seri(i,k) * z_factor(i) + ENDIF + ENDDO + ENDDO + ENDIF + zx_ajustq=.FALSE. + +c +c============================================================================= +cRR:Evolution de la poche froide: on ne fait pas de separation wake/env +cpour la couche limite diffuse pour l instant +c + if (iflag_wake.eq.1) then + DO k=1,klev + DO i=1,klon + dt_dwn(i,k) = ftd(i,k) + wdt_PBL(i,k) = 0. + dq_dwn(i,k) = fqd(i,k) + wdq_PBL(i,k) = 0. + M_dwn(i,k) = dnwd0(i,k) + M_up(i,k) = upwd(i,k) + dt_a(i,k) = d_t_con(i,k)/dtime - ftd(i,k) + udt_PBL(i,k) = 0. + dq_a(i,k) = d_q_con(i,k)/dtime - fqd(i,k) + udq_PBL(i,k) = 0. + ENDDO + ENDDO +c +ccalcul caracteristiques de la poche froide + call calWAKE (paprs,pplay,dtime + : ,t_seri,q_seri,omega + : ,dt_dwn,dq_dwn,M_dwn,M_up + : ,dt_a,dq_a,sigd + : ,wdt_PBL,wdq_PBL + : ,udt_PBL,udq_PBL + o ,wake_deltat,wake_deltaq,wake_dth + o ,wake_h,wake_s,wake_dens + o ,wake_pe,wake_fip,wake_gfl + o ,dt_wake,dq_wake + o ,wake_k, t_undi,q_undi + o ,wake_omgbdth,wake_dp_omgb + o ,wake_dtKE,wake_dqKE + o ,wake_dtPBL,wake_dqPBL + o ,wake_omg,wake_dp_deltomg + o ,wake_spread,wake_Cstar,wake_d_deltat_gw + o ,wake_ddeltat,wake_ddeltaq) +c +!----------------------------------------------------------------------------------------- +! ajout des tendances des poches froides +! Faire rapidement disparaitre l'ancien dt_wake pour garder un d_t_wake +! coherent avec les autres d_t_... + d_t_wake(:,:)=dt_wake(:,:)*dtime + d_q_wake(:,:)=dq_wake(:,:)*dtime + CALL add_phys_tend(du0,dv0,d_t_wake,d_q_wake,dql0,'wake') +!----------------------------------------------------------------------------------------- + + endif +c print*,'apres callwake iflag_cldcon=', iflag_cldcon +c +c=================================================================== +c Convection seche (thermiques ou ajustement) +c=================================================================== +c + call stratocu_if(klon,klev,pctsrf,paprs, pplay,t_seri + s ,seuil_inversion,weak_inversion,dthmin) + + + + d_t_ajsb(:,:)=0. + d_q_ajsb(:,:)=0. + d_t_ajs(:,:)=0. + d_u_ajs(:,:)=0. + d_v_ajs(:,:)=0. + d_q_ajs(:,:)=0. + clwcon0th(:,:)=0. +c + fm_therm(:,:)=0. + entr_therm(:,:)=0. + detr_therm(:,:)=0. +c + IF(prt_level>9)WRITE(lunout,*) + . 'AVANT LA CONVECTION SECHE , iflag_thermals=' + s ,iflag_thermals,' nsplit_thermals=',nsplit_thermals + if(iflag_thermals.lt.0) then +c Rien +c ==== + IF(prt_level>9)WRITE(lunout,*)'pas de convection' + + + else + +c Thermiques +c ========== + IF(prt_level>9)WRITE(lunout,*)'JUSTE AVANT , iflag_thermals=' + s ,iflag_thermals,' nsplit_thermals=',nsplit_thermals + + + if (iflag_thermals.gt.1) then + call calltherm(pdtphys + s ,pplay,paprs,pphi,weak_inversion + s ,u_seri,v_seri,t_seri,q_seri,zqsat,debut + s ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs + s ,fm_therm,entr_therm,detr_therm + s ,zqasc,clwcon0th,lmax_th,ratqscth + s ,ratqsdiff,zqsatth +con rajoute ale et alp, et les caracteristiques de la couche alim + s ,Ale_bl,Alp_bl,lalim_conv,wght_th, zmax0, f0, zw2,fraca) + endif + + +c Ajustement sec +c ============== + +! Dans le cas où on active les thermiques, on fait partir l'ajustement +! a partir du sommet des thermiques. +! Dans le cas contraire, on demarre au niveau 1. + + if (iflag_thermals.ge.13.or.iflag_thermals.eq.0) then + + if(iflag_thermals.eq.0) then + IF(prt_level>9)WRITE(lunout,*)'ajsec' + limbas(:)=1 + else + limbas(:)=lmax_th(:) + endif + +! Attention : le call ajsec_convV2 n'est maintenu que momentanneement +! pour des test de convergence numerique. +! Le nouveau ajsec est a priori mieux, meme pour le cas +! iflag_thermals = 0 (l'ancienne version peut faire des tendances +! non nulles numeriquement pour des mailles non concernees. + + if (iflag_thermals.eq.0) then + CALL ajsec_convV2(paprs, pplay, t_seri,q_seri + s , d_t_ajsb, d_q_ajsb) + else + CALL ajsec(paprs, pplay, t_seri,q_seri,limbas + s , d_t_ajsb, d_q_ajsb) + endif + +!----------------------------------------------------------------------------------------- +! ajout des tendances de l'ajustement sec ou des thermiques + CALL add_phys_tend(du0,dv0,d_t_ajsb,d_q_ajsb,dql0,'ajsb') + d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_ajsb(:,:) + d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_ajsb(:,:) + +!----------------------------------------------------------------------------------------- + + endif + + endif +c +c=================================================================== +cIM + IF (ip_ebil_phy.ge.2) THEN + ztit='after dry_adjust' + CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + END IF + + +c------------------------------------------------------------------------- +c Caclul des ratqs +c------------------------------------------------------------------------- + +c print*,'calcul des ratqs' +c ratqs convectifs a l'ancienne en fonction de q(z=0)-q / q +c ---------------- +c on ecrase le tableau ratqsc calcule par clouds_gno + if (iflag_cldcon.eq.1) then + do k=1,klev + do i=1,klon + if(ptconv(i,k)) then + ratqsc(i,k)=ratqsbas + s +fact_cldcon*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k) + else + ratqsc(i,k)=0. + endif + enddo + enddo + +c----------------------------------------------------------------------- +c par nversion de la fonction log normale +c----------------------------------------------------------------------- + else if (iflag_cldcon.eq.4) then + ptconvth(:,:)=.false. + ratqsc(:,:)=0. + if(prt_level.ge.9) print*,'avant clouds_gno thermique' + call clouds_gno + s (klon,klev,q_seri,zqsat,clwcon0th,ptconvth,ratqsc,rnebcon0th) + if(prt_level.ge.9) print*,' CLOUDS_GNO OK' + +c----------------------------------------------------------------------- +c par calcul direct de l'ecart-type +c----------------------------------------------------------------------- + + else if (iflag_cldcon>=5) then + wmax_th(:)=0. + zmax_th(:)=0. + do k=1,klev + do i=1,klon + wmax_th(i)=max(wmax_th(i),zw2(i,k)) + if (detr_therm(i,k).gt.0.) zmax_th(i)=pphi(i,k)/rg + enddo + enddo + tau_overturning_th(:)=zmax_th(:)/max(0.5*wmax_th(:),0.1) + print*,'TAU TH OK ',tau_overturning_th(1),detr_therm(1,3) + +c On impose que l'air autour de la fraction couverte par le thermique +c plus son air detraine durant tau_overturning_th soit superieur +c a 0.1 q_seri + zz=0.1 + do k=1,klev + do i=1,klon + lambda_th(i,k)=0.5*(fraca(i,k)+fraca(i,k+1))+ + s tau_overturning_th(i)*detr_therm(i,k) + s *rg/(paprs(i,k)-paprs(i,k+1)) + znum=(1.-zz)*q_seri(i,k) + zden=zqasc(i,k)-zz*q_seri(i,k) + if (znum-lambda_th(i,k)*zden<0.) lambda_th(i,k)=znum/zden + lambda_th(i,k)=min(lambda_th(i,k),0.9) + enddo + enddo + + if(iflag_cldcon==5) then + do k=1,klev + do i=1,klon + ratqsc(i,k)=sqrt(lambda_th(i,k)/(1.-lambda_th(i,k)))* + s abs((zqasc(i,k)-q_seri(i,k))/q_seri(i,k)) + enddo + enddo + else if(iflag_cldcon==6) then + do k=1,klev + do i=1,klon + ratqsc(i,k)=sqrt(lambda_th(i,k))* + s (zqasc(i,k)-q_seri(i,k))/q_seri(i,k) + enddo + enddo + endif + + endif + +c ratqs stables +c ------------- + + if (iflag_ratqs.eq.0) then + +! Le cas iflag_ratqs=0 correspond a la version IPCC 2005 du modele. + do k=1,klev + do i=1, klon + ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)* + s min((paprs(i,1)-pplay(i,k))/(paprs(i,1)-30000.),1.) + enddo + enddo + +! Pour iflag_ratqs=1 ou 2, le ratqs est constant au dessus de +! 300 hPa (ratqshaut), varie lineariement en fonction de la pression +! entre 600 et 300 hPa et est soit constant (ratqsbas) pour iflag_ratqs=1 +! soit lineaire (entre 0 a la surface et ratqsbas) pour iflag_ratqs=2 +! Il s'agit de differents tests dans la phase de reglage du modele +! avec thermiques. + + else if (iflag_ratqs.eq.1) then + + do k=1,klev + do i=1, klon + if (pplay(i,k).ge.60000.) then + ratqss(i,k)=ratqsbas + else if ((pplay(i,k).ge.30000.).and. + s (pplay(i,k).lt.60000.)) then + ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)* + s (60000.-pplay(i,k))/(60000.-30000.) + else + ratqss(i,k)=ratqshaut + endif + enddo + enddo + + else + + do k=1,klev + do i=1, klon + if (pplay(i,k).ge.60000.) then + ratqss(i,k)=ratqsbas + s *(paprs(i,1)-pplay(i,k))/(paprs(i,1)-60000.) + else if ((pplay(i,k).ge.30000.).and. + s (pplay(i,k).lt.60000.)) then + ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)* + s (60000.-pplay(i,k))/(60000.-30000.) + else + ratqss(i,k)=ratqshaut + endif + enddo + enddo + endif + + + + +c ratqs final +c ----------- + + if (iflag_cldcon.eq.1 .or.iflag_cldcon.eq.2 + s .or.iflag_cldcon.ge.4) then + +! On ajoute une constante au ratqsc*2 pour tenir compte de +! fluctuations turbulentes de petite echelle + + do k=1,klev + do i=1,klon + if ((fm_therm(i,k).gt.1.e-10)) then + ratqsc(i,k)=sqrt(ratqsc(i,k)**2+0.05**2) + endif + enddo + enddo + +! les ratqs sont une combinaison de ratqss et ratqsc + print*,'PHYLMD NOUVEAU TAU_RATQS ',tau_ratqs + + if (tau_ratqs>1.e-10) then + facteur=exp(-pdtphys/tau_ratqs) + else + facteur=0. + endif + ratqs(:,:)=ratqsc(:,:)*(1.-facteur)+ratqs(:,:)*facteur +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH 22/09/2009 +! La ligne ci-dessous faisait osciller le modele et donnait une solution +! assymptotique bidon et dépendant fortement du pas de temps. +! ratqs(:,:)=sqrt(ratqs(:,:)**2+ratqss(:,:)**2) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ratqs(:,:)=max(ratqs(:,:),ratqss(:,:)) + else +! on ne prend que le ratqs stable pour fisrtilp + ratqs(:,:)=ratqss(:,:) + endif + + +c +c Appeler le processus de condensation a grande echelle +c et le processus de precipitation +c------------------------------------------------------------------------- + CALL fisrtilp(dtime,paprs,pplay, + . t_seri, q_seri,ptconv,ratqs, + . d_t_lsc, d_q_lsc, d_ql_lsc, rneb, cldliq, + . rain_lsc, snow_lsc, + . pfrac_impa, pfrac_nucl, pfrac_1nucl, + . frac_impa, frac_nucl, + . prfl, psfl, rhcl) + + WHERE (rain_lsc < 0) rain_lsc = 0. + WHERE (snow_lsc < 0) snow_lsc = 0. +!----------------------------------------------------------------------------------------- +! ajout des tendances de la diffusion turbulente + CALL add_phys_tend(du0,dv0,d_t_lsc,d_q_lsc,d_ql_lsc,'lsc') +!----------------------------------------------------------------------------------------- + DO k = 1, klev + DO i = 1, klon + cldfra(i,k) = rneb(i,k) + IF (.NOT.new_oliq) cldliq(i,k) = ql_seri(i,k) + ENDDO + ENDDO + IF (check) THEN + za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy) + WRITE(lunout,*)"apresilp=", za + zx_t = 0.0 + za = 0.0 + DO i = 1, klon + za = za + airephy(i)/FLOAT(klon) + zx_t = zx_t + (rain_lsc(i) + . + snow_lsc(i))*airephy(i)/FLOAT(klon) + ENDDO + zx_t = zx_t/za*dtime + WRITE(lunout,*)"Precip=", zx_t + ENDIF +cIM + IF (ip_ebil_phy.ge.2) THEN + ztit='after fisrt' + CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(airephy,ztit,ip_ebil_phy + e , zero_v, zero_v, zero_v, zero_v, zero_v + e , zero_v, rain_lsc, snow_lsc, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) + END IF + + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + +c +c------------------------------------------------------------------- +c PRESCRIPTION DES NUAGES POUR LE RAYONNEMENT +c------------------------------------------------------------------- + +c 1. NUAGES CONVECTIFS +c +cIM cf FH +c IF (iflag_cldcon.eq.-1) THEN ! seulement pour Tiedtke + IF (iflag_cldcon.le.-1) THEN ! seulement pour Tiedtke + snow_tiedtke=0. +c print*,'avant calcul de la pseudo precip ' +c print*,'iflag_cldcon',iflag_cldcon + if (iflag_cldcon.eq.-1) then + rain_tiedtke=rain_con + else +c print*,'calcul de la pseudo precip ' + rain_tiedtke=0. +c print*,'calcul de la pseudo precip 0' + do k=1,klev + do i=1,klon + if (d_q_con(i,k).lt.0.) then + rain_tiedtke(i)=rain_tiedtke(i)-d_q_con(i,k)/pdtphys + s *(paprs(i,k)-paprs(i,k+1))/rg + endif + enddo + enddo + endif +c +c call dump2d(iim,jjm,rain_tiedtke(2:klon-1),'PSEUDO PRECIP ') +c + +c Nuages diagnostiques pour Tiedtke + CALL diagcld1(paprs,pplay, +cIM cf FH . rain_con,snow_con,ibas_con,itop_con, + . rain_tiedtke,snow_tiedtke,ibas_con,itop_con, + . diafra,dialiq) + DO k = 1, klev + DO i = 1, klon + IF (diafra(i,k).GT.cldfra(i,k)) THEN + cldliq(i,k) = dialiq(i,k) + cldfra(i,k) = diafra(i,k) + ENDIF + ENDDO + ENDDO + + ELSE IF (iflag_cldcon.ge.3) THEN +c On prend pour les nuages convectifs le max du calcul de la +c convection et du calcul du pas de temps precedent diminue d'un facteur +c facttemps + facteur = pdtphys *facttemps + do k=1,klev + do i=1,klon + rnebcon(i,k)=rnebcon(i,k)*facteur + if (rnebcon0(i,k)*clwcon0(i,k).gt.rnebcon(i,k)*clwcon(i,k)) + s then + rnebcon(i,k)=rnebcon0(i,k) + clwcon(i,k)=clwcon0(i,k) + endif + enddo + enddo + +c +cjq - introduce the aerosol direct and first indirect radiative forcings +cjq - Johannes Quaas, 27/11/2003 (quaas@lmd.jussieu.fr) + IF (ok_ade.OR.ok_aie) THEN + IF (.NOT. aerosol_couple) + & CALL readaerosol_optic( + & debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, + & pdtphys, pplay, paprs, t_seri, rhcl, presnivs, + & mass_solu_aero, mass_solu_aero_pi, + & tau_aero, piz_aero, cg_aero, + & tausum_aero, tau3d_aero) + ELSE + tau_aero(:,:,:,:) = 0. + piz_aero(:,:,:,:) = 0. + cg_aero(:,:,:,:) = 0. + ENDIF + +cIM calcul nuages par le simulateur ISCCP +c +#ifdef histISCCP + IF (ok_isccp) THEN +c +cIM lecture invtau, tautab des fichiers formattes +c + IF (debut) THEN +c$OMP MASTER +c + open(99,file='tautab.formatted', FORM='FORMATTED') + read(99,'(f30.20)') tautab_omp + close(99) +c + open(99,file='invtau.formatted',form='FORMATTED') + read(99,'(i10)') invtau_omp + +c print*,'calcul_simulISCCP invtau_omp',invtau_omp +c write(6,'(a,8i10)') 'invtau_omp',(invtau_omp(i),i=1,100) + + close(99) +c$OMP END MASTER +c$OMP BARRIER + tautab=tautab_omp + invtau=invtau_omp +c + ENDIF !debut +c +cIM appel simulateur toutes les NINT(freq_ISCCP/dtime) heures + IF (MOD(itap,NINT(freq_ISCCP/dtime)).EQ.0) THEN +#include "calcul_simulISCCP.h" + ENDIF !(MOD(itap,NINT(freq_ISCCP/dtime)) + ENDIF !ok_isccp +#endif + +c On prend la somme des fractions nuageuses et des contenus en eau + cldfra(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.) + cldliq(:,:)=cldliq(:,:)+rnebcon(:,:)*clwcon(:,:) + + ENDIF +c +c 2. NUAGES STARTIFORMES +c + IF (ok_stratus) THEN + CALL diagcld2(paprs,pplay,t_seri,q_seri, diafra,dialiq) + DO k = 1, klev + DO i = 1, klon + IF (diafra(i,k).GT.cldfra(i,k)) THEN + cldliq(i,k) = dialiq(i,k) + cldfra(i,k) = diafra(i,k) + ENDIF + ENDDO + ENDDO + ENDIF +c +c Precipitation totale +c + DO i = 1, klon + rain_fall(i) = rain_con(i) + rain_lsc(i) + snow_fall(i) = snow_con(i) + snow_lsc(i) + ENDDO +cIM + IF (ip_ebil_phy.ge.2) THEN + ztit="after diagcld" + CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + END IF +c +c Calculer l'humidite relative pour diagnostique +c + DO k = 1, klev + DO i = 1, klon + zx_t = t_seri(i,k) + IF (thermcep) THEN + zdelta = MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k) + zx_qs = MIN(0.5,zx_qs) + zcor = 1./(1.-retv*zx_qs) + zx_qs = zx_qs*zcor + ELSE + IF (zx_t.LT.t_coup) THEN + zx_qs = qsats(zx_t)/pplay(i,k) + ELSE + zx_qs = qsatl(zx_t)/pplay(i,k) + ENDIF + ENDIF + zx_rh(i,k) = q_seri(i,k)/zx_qs + zqsat(i,k)=zx_qs + ENDDO + ENDDO + +cIM Calcul temp.potentielle a 2m (tpot) et temp. potentielle +c equivalente a 2m (tpote) pour diagnostique +c + DO i = 1, klon + tpot(i)=zt2m(i)*(100000./paprs(i,1))**RKAPPA + IF (thermcep) THEN + IF(zt2m(i).LT.RTT) then + Lheat=RLSTT + ELSE + Lheat=RLVTT + ENDIF + ELSE + IF (zt2m(i).LT.RTT) THEN + Lheat=RLSTT + ELSE + Lheat=RLVTT + ENDIF + ENDIF + tpote(i) = tpot(i)* + . EXP((Lheat *qsat2m(i))/(RCPD*zt2m(i))) + ENDDO + + IF (config_inca /= 'none') THEN +#ifdef INCA + CALL VTe(VTphysiq) + CALL VTb(VTinca) + calday = FLOAT(days_elapsed + 1) + jH_cur + + IF (config_inca == 'aero') THEN + CALL AEROSOL_METEO_CALC( + $ calday,pdtphys,pplay,paprs,t,pmflxr,pmflxs, + $ prfl,psfl,pctsrf,airephy,rlat,rlon,u10m,v10m) + END IF + + zxsnow_dummy(:) = 0.0 + + CALL chemhook_begin (calday, + $ days_elapsed+1, + $ jH_cur, + $ pctsrf(1,1), + $ rlat, + $ rlon, + $ airephy, + $ paprs, + $ pplay, + $ coefh, + $ pphi, + $ t_seri, + $ u, + $ v, + $ wo(:, :, 1), + $ q_seri, + $ zxtsol, + $ zxsnow_dummy, + $ solsw, + $ albsol1, + $ rain_fall, + $ snow_fall, + $ itop_con, + $ ibas_con, + $ cldfra, + $ iim, + $ jjm, + $ tr_seri, + $ ftsol, + $ paprs, + $ cdragh, + $ cdragm, + $ pctsrf, + $ pdtphys, + $ itap) + + CALL VTe(VTinca) + CALL VTb(VTphysiq) +#endif + END IF !config_inca /= 'none' +c +c Calculer les parametres optiques des nuages et quelques +c parametres pour diagnostiques: +c + + IF (aerosol_couple) THEN + mass_solu_aero(:,:) = ccm(:,:,1) + mass_solu_aero_pi(:,:) = ccm(:,:,2) + END IF + + if (ok_newmicro) then + CALL newmicro (paprs, pplay,ok_newmicro, + . t_seri, cldliq, cldfra, cldtau, cldemi, + . cldh, cldl, cldm, cldt, cldq, + . flwp, fiwp, flwc, fiwc, + e ok_aie, + e mass_solu_aero, mass_solu_aero_pi, + e bl95_b0, bl95_b1, + s cldtaupi, re, fl, ref_liq, ref_ice) + else + CALL nuage (paprs, pplay, + . t_seri, cldliq, cldfra, cldtau, cldemi, + . cldh, cldl, cldm, cldt, cldq, + e ok_aie, + e mass_solu_aero, mass_solu_aero_pi, + e bl95_b0, bl95_b1, + s cldtaupi, re, fl) + + endif +c +c Appeler le rayonnement mais calculer tout d'abord l'albedo du sol. +c + IF (MOD(itaprad,radpas).EQ.0) THEN + + DO i = 1, klon + albsol1(i) = falb1(i,is_oce) * pctsrf(i,is_oce) + . + falb1(i,is_lic) * pctsrf(i,is_lic) + . + falb1(i,is_ter) * pctsrf(i,is_ter) + . + falb1(i,is_sic) * pctsrf(i,is_sic) + albsol2(i) = falb2(i,is_oce) * pctsrf(i,is_oce) + . + falb2(i,is_lic) * pctsrf(i,is_lic) + . + falb2(i,is_ter) * pctsrf(i,is_ter) + . + falb2(i,is_sic) * pctsrf(i,is_sic) + ENDDO + + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + + IF (aerosol_couple) THEN +#ifdef INCA + CALL radlwsw_inca + e (kdlon,kflev,dist, rmu0, fract, solaire, + e paprs, pplay,zxtsol,albsol1, albsol2, t_seri,q_seri, + e wo(:, :, 1), + e cldfra, cldemi, cldtau, + s heat,heat0,cool,cool0,radsol,albpla, + s topsw,toplw,solsw,sollw, + s sollwdown, + s topsw0,toplw0,solsw0,sollw0, + s lwdn0, lwdn, lwup0, lwup, + s swdn0, swdn, swup0, swup, + e ok_ade, ok_aie, + e tau_aero, piz_aero, cg_aero, + s topswad_aero, solswad_aero, + s topswad0_aero, solswad0_aero, + s topsw_aero, topsw0_aero, + s solsw_aero, solsw0_aero, + e cldtaupi, + s topswai_aero, solswai_aero) + +#endif + ELSE + + CALL radlwsw + e (dist, rmu0, fract, + e paprs, pplay,zxtsol,albsol1, albsol2, + e t_seri,q_seri,wo, + e cldfra, cldemi, cldtau, + e ok_ade, ok_aie, + e tau_aero, piz_aero, cg_aero, + e cldtaupi,new_aod, + e zqsat, flwc, fiwc, + s heat,heat0,cool,cool0,radsol,albpla, + s topsw,toplw,solsw,sollw, + s sollwdown, + s topsw0,toplw0,solsw0,sollw0, + s lwdn0, lwdn, lwup0, lwup, + s swdn0, swdn, swup0, swup, + s topswad_aero, solswad_aero, + s topswai_aero, solswai_aero, + o topswad0_aero, solswad0_aero, + o topsw_aero, topsw0_aero, + o solsw_aero, solsw0_aero, + o topswcf_aero, solswcf_aero) + + + ENDIF ! aerosol_couple + itaprad = 0 + ENDIF ! MOD(itaprad,radpas) + itaprad = itaprad + 1 + + if (iflag_radia.eq.0) then + print *,'--------------------------------------------------' + print *,'>>>> ATTENTION rayonnement desactive pour ce cas' + print *,'>>>> heat et cool mis a zero ' + print *,'--------------------------------------------------' + heat=0. + cool=0. + endif + +c +c Ajouter la tendance des rayonnements (tous les pas) +c + DO k = 1, klev + DO i = 1, klon + t_seri(i,k) = t_seri(i,k) + . + (heat(i,k)-cool(i,k)) * dtime/RDAY + ENDDO + ENDDO +c + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + +cIM + IF (ip_ebil_phy.ge.2) THEN + ztit='after rad' + CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(airephy,ztit,ip_ebil_phy + e , topsw, toplw, solsw, sollw, zero_v + e , zero_v, zero_v, zero_v, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) + END IF +c +c +c Calculer l'hydrologie de la surface +c +c CALL hydrol(dtime,pctsrf,rain_fall, snow_fall, zxevap, +c . agesno, ftsol,fqsurf,fsnow, ruis) +c + +c +c Calculer le bilan du sol et la derive de temperature (couplage) +c + DO i = 1, klon +c bils(i) = radsol(i) - sens(i) - evap(i)*RLVTT +c a la demande de JLD + bils(i) = radsol(i) - sens(i) + zxfluxlat(i) + ENDDO +c +cmoddeblott(jan95) +c Appeler le programme de parametrisation de l'orographie +c a l'echelle sous-maille: +c + IF (ok_orodr) THEN +c +c selection des points pour lesquels le shema est actif: + igwd=0 + DO i=1,klon + itest(i)=0 +c IF ((zstd(i).gt.10.0)) THEN + IF (((zpic(i)-zmea(i)).GT.100.).AND.(zstd(i).GT.10.0)) THEN + itest(i)=1 + igwd=igwd+1 + idx(igwd)=i + ENDIF + ENDDO +c igwdim=MAX(1,igwd) +c + IF (ok_strato) THEN + + CALL drag_noro_strato(klon,klev,dtime,paprs,pplay, + e zmea,zstd, zsig, zgam, zthe,zpic,zval, + e igwd,idx,itest, + e t_seri, u_seri, v_seri, + s zulow, zvlow, zustrdr, zvstrdr, + s d_t_oro, d_u_oro, d_v_oro) + + ELSE + CALL drag_noro(klon,klev,dtime,paprs,pplay, + e zmea,zstd, zsig, zgam, zthe,zpic,zval, + e igwd,idx,itest, + e t_seri, u_seri, v_seri, + s zulow, zvlow, zustrdr, zvstrdr, + s d_t_oro, d_u_oro, d_v_oro) + ENDIF +c +c ajout des tendances +!----------------------------------------------------------------------------------------- +! ajout des tendances de la trainee de l'orographie + CALL add_phys_tend(d_u_oro,d_v_oro,d_t_oro,dq0,dql0,'oro') +!----------------------------------------------------------------------------------------- +c + ENDIF ! fin de test sur ok_orodr +c + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + + IF (ok_orolf) THEN +c +c selection des points pour lesquels le shema est actif: + igwd=0 + DO i=1,klon + itest(i)=0 + IF ((zpic(i)-zmea(i)).GT.100.) THEN + itest(i)=1 + igwd=igwd+1 + idx(igwd)=i + ENDIF + ENDDO +c igwdim=MAX(1,igwd) +c + IF (ok_strato) THEN + + CALL lift_noro_strato(klon,klev,dtime,paprs,pplay, + e rlat,zmea,zstd,zpic,zgam,zthe,zpic,zval, + e igwd,idx,itest, + e t_seri, u_seri, v_seri, + s zulow, zvlow, zustrli, zvstrli, + s d_t_lif, d_u_lif, d_v_lif ) + + ELSE + CALL lift_noro(klon,klev,dtime,paprs,pplay, + e rlat,zmea,zstd,zpic, + e itest, + e t_seri, u_seri, v_seri, + s zulow, zvlow, zustrli, zvstrli, + s d_t_lif, d_u_lif, d_v_lif) + ENDIF +c +!----------------------------------------------------------------------------------------- +! ajout des tendances de la portance de l'orographie + CALL add_phys_tend(d_u_lif,d_v_lif,d_t_lif,dq0,dql0,'lif') +!----------------------------------------------------------------------------------------- +c + ENDIF ! fin de test sur ok_orolf +C HINES GWD PARAMETRIZATION + + IF (ok_hines) then + + CALL hines_gwd(klon,klev,dtime,paprs,pplay, + i rlat,t_seri,u_seri,v_seri, + o zustrhi,zvstrhi, + o d_t_hin, d_u_hin, d_v_hin) +c +c ajout des tendances + CALL add_phys_tend(d_u_hin,d_v_hin,d_t_hin,dq0,dql0,'lif') + + ENDIF +c + +c +cIM cf. FLott BEG +C STRESS NECESSAIRES: TOUTE LA PHYSIQUE + + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + + DO i = 1, klon + zustrph(i)=0. + zvstrph(i)=0. + ENDDO + DO k = 1, klev + DO i = 1, klon + zustrph(i)=zustrph(i)+(u_seri(i,k)-u(i,k))/dtime* + c (paprs(i,k)-paprs(i,k+1))/rg + zvstrph(i)=zvstrph(i)+(v_seri(i,k)-v(i,k))/dtime* + c (paprs(i,k)-paprs(i,k+1))/rg + ENDDO + ENDDO +c +cIM calcul composantes axiales du moment angulaire et couple des montagnes +c + IF (is_sequential) THEN + + CALL aaam_bud (27,klon,klev,jD_cur-jD_ref,jH_cur, + C ra,rg,romega, + C rlat,rlon,pphis, + C zustrdr,zustrli,zustrph, + C zvstrdr,zvstrli,zvstrph, + C paprs,u,v, + C aam, torsfc) + ENDIF +cIM cf. FLott END +cIM + IF (ip_ebil_phy.ge.2) THEN + ztit='after orography' + CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + END IF +c +c +!==================================================================== +! Interface Simulateur COSP (Calipso, ISCCP, MISR, ..) +!==================================================================== +! Abderrahmane 24.08.09 + + IF (ok_cosp) THEN +! adeclarer +#ifdef CPP_COSP + IF (MOD(itap,NINT(freq_cosp/dtime)).EQ.0) THEN + + print*,'freq_cosp',freq_cosp + mr_ozone=wo(:, :, 1) * dobson_u * 1e3 / zmasse +! print*,'Dans physiq.F avant appel cosp ref_liq,ref_ice=', +! s ref_liq,ref_ice + call phys_cosp(itap,dtime,freq_cosp, + $ ecrit_mth,ecrit_day,ecrit_hf,overlap, + $ klon,klev,rlon,rlat,presnivs, + $ ref_liq,ref_ice, + $ pctsrf(:,is_ter)+pctsrf(:,is_lic), + $ zu10m,zv10m, + $ zphi,paprs(:,1:klev),pplay,zxtsol,t_seri, + $ qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, + $ prfl(:,1:klev),psfl(:,1:klev), + $ pmflxr(:,1:klev),pmflxs(:,1:klev), + $ mr_ozone,cldtau, cldemi) +! L calipso2D,calipso3D,cfadlidar,parasolrefl,atb,betamol, +! L cfaddbze,clcalipso2,dbze,cltlidarradar, +! M clMISR, +! R clisccp2,boxtauisccp,boxptopisccp,tclisccp,ctpisccp, +! I tauisccp,albisccp,meantbisccp,meantbclrisccp) + + ENDIF + +#endif + ENDIF !ok_cosp +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +cAA +cAA Installation de l'interface online-offline pour traceurs +cAA +c==================================================================== +c Calcul des tendances traceurs +c==================================================================== +C + + call phytrac ( + I itap, days_elapsed+1, jH_cur, debut, + I lafin, dtime, u, v, t, + I paprs, pplay, pmfu, pmfd, + I pen_u, pde_u, pen_d, pde_d, + I cdragh, coefh, fm_therm, entr_therm, + I u1, v1, ftsol, pctsrf, + I rlat, frac_impa, frac_nucl,rlon, + I presnivs, pphis, pphi, albsol1, + I qx(:,:,ivap),rhcl, cldfra, rneb, + I diafra, cldliq, itop_con, ibas_con, + I pmflxr, pmflxs, prfl, psfl, + I da, phi, mp, upwd, + I dnwd, aerosol_couple, flxmass_w, + I tau_aero, piz_aero, cg_aero, ccm, + I rfname, + O tr_seri) + + IF (offline) THEN + + print*,'Attention on met a 0 les thermiques pour phystoke' + call phystokenc ( + I nlon,klev,pdtphys,rlon,rlat, + I t,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, + I fm_therm,entr_therm, + I cdragh,coefh,u1,v1,ftsol,pctsrf, + I frac_impa, frac_nucl, + I pphis,airephy,dtime,itap) + + + ENDIF + +c +c Calculer le transport de l'eau et de l'energie (diagnostique) +c + CALL transp (paprs,zxtsol, + e t_seri, q_seri, u_seri, v_seri, zphi, + s ve, vq, ue, uq) +c +cIM global posePB BEG + IF(1.EQ.0) THEN +c + CALL transp_lay (paprs,zxtsol, + e t_seri, q_seri, u_seri, v_seri, zphi, + s ve_lay, vq_lay, ue_lay, uq_lay) +c + ENDIF !(1.EQ.0) THEN +cIM global posePB END +c Accumuler les variables a stocker dans les fichiers histoire: +c +c+jld ec_conser + DO k = 1, klev + DO i = 1, klon + ZRCPD = RCPD*(1.0+RVTMP2*q_seri(i,k)) + d_t_ec(i,k)=0.5/ZRCPD + $ *(u(i,k)**2+v(i,k)**2-u_seri(i,k)**2-v_seri(i,k)**2) + ENDDO + ENDDO + + DO k = 1, klev + DO i = 1, klon + t_seri(i,k)=t_seri(i,k)+d_t_ec(i,k) + d_t_ec(i,k) = d_t_ec(i,k)/dtime + END DO + END DO +c-jld ec_conser +cIM + IF (ip_ebil_phy.ge.1) THEN + ztit='after physic' + CALL diagetpq(airephy,ztit,ip_ebil_phy,1,1,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) +C Comme les tendances de la physique sont ajoute dans la dynamique, +C on devrait avoir que la variation d'entalpie par la dynamique +C est egale a la variation de la physique au pas de temps precedent. +C Donc la somme de ces 2 variations devrait etre nulle. + + call diagphy(airephy,ztit,ip_ebil_phy + e , topsw, toplw, solsw, sollw, sens + e , evap, rain_fall, snow_fall, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) +C + d_h_vcol_phy=d_h_vcol +C + END IF +C +c======================================================================= +c SORTIES +c======================================================================= + +cIM Interpolation sur les niveaux de pression du NMC +c ------------------------------------------------- +c +#include "calcul_STDlev.h" + twriteSTD(:,:,1)=tsumSTD(:,:,2) + qwriteSTD(:,:,1)=qsumSTD(:,:,2) + rhwriteSTD(:,:,1)=rhsumSTD(:,:,2) + phiwriteSTD(:,:,1)=phisumSTD(:,:,2) + uwriteSTD(:,:,1)=usumSTD(:,:,2) + vwriteSTD(:,:,1)=vsumSTD(:,:,2) + wwriteSTD(:,:,1)=wsumSTD(:,:,2) + + twriteSTD(:,:,2)=tsumSTD(:,:,1) + qwriteSTD(:,:,2)=qsumSTD(:,:,1) + rhwriteSTD(:,:,2)=rhsumSTD(:,:,1) + phiwriteSTD(:,:,2)=phisumSTD(:,:,1) + uwriteSTD(:,:,2)=usumSTD(:,:,1) + vwriteSTD(:,:,2)=vsumSTD(:,:,1) + wwriteSTD(:,:,2)=wsumSTD(:,:,1) + + twriteSTD(:,:,3)=tlevSTD(:,:) + qwriteSTD(:,:,3)=qlevSTD(:,:) + rhwriteSTD(:,:,3)=rhlevSTD(:,:) + phiwriteSTD(:,:,3)=philevSTD(:,:) + uwriteSTD(:,:,3)=ulevSTD(:,:) + vwriteSTD(:,:,3)=vlevSTD(:,:) + wwriteSTD(:,:,3)=wlevSTD(:,:) + + twriteSTD(:,:,4)=tlevSTD(:,:) + qwriteSTD(:,:,4)=qlevSTD(:,:) + rhwriteSTD(:,:,4)=rhlevSTD(:,:) + phiwriteSTD(:,:,4)=philevSTD(:,:) + uwriteSTD(:,:,4)=ulevSTD(:,:) + vwriteSTD(:,:,4)=vlevSTD(:,:) + wwriteSTD(:,:,4)=wlevSTD(:,:) +c +c slp sea level pressure + slp(:) = paprs(:,1)*exp(pphis(:)/(RD*t_seri(:,1))) +c +ccc prw = eau precipitable + DO i = 1, klon + prw(i) = 0. + DO k = 1, klev + prw(i) = prw(i) + + . q_seri(i,k)*(paprs(i,k)-paprs(i,k+1))/RG + ENDDO + ENDDO +c +cIM initialisation + calculs divers diag AMIP2 +c +#include "calcul_divers.h" +c + IF (config_inca /= 'none') THEN +#ifdef INCA + CALL VTe(VTphysiq) + CALL VTb(VTinca) + + CALL chemhook_end (calday, + $ dtime, + $ pplay, + $ t_seri, + $ tr_seri, + $ nbtr, + $ paprs, + $ q_seri, + $ annee_ref, + $ day_ini, + $ airephy, + $ pphi, + $ pphis, + $ zx_rh) + + CALL VTe(VTinca) + CALL VTb(VTphysiq) +#endif + END IF + +c============================================================= +c +c Convertir les incrementations en tendances +c + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + + DO k = 1, klev + DO i = 1, klon + d_u(i,k) = ( u_seri(i,k) - u(i,k) ) / dtime + d_v(i,k) = ( v_seri(i,k) - v(i,k) ) / dtime + d_t(i,k) = ( t_seri(i,k)-t(i,k) ) / dtime + d_qx(i,k,ivap) = ( q_seri(i,k) - qx(i,k,ivap) ) / dtime + d_qx(i,k,iliq) = ( ql_seri(i,k) - qx(i,k,iliq) ) / dtime + ENDDO + ENDDO +c + IF (nqtot.GE.3) THEN + DO iq = 3, nqtot + DO k = 1, klev + DO i = 1, klon + d_qx(i,k,iq) = ( tr_seri(i,k,iq-2) - qx(i,k,iq) ) / dtime + ENDDO + ENDDO + ENDDO + ENDIF +c +cIM rajout diagnostiques bilan KP pour analyse MJO par Jun-Ichi Yano +cIM global posePB#include "write_bilKP_ins.h" +cIM global posePB#include "write_bilKP_ave.h" +c +c Sauvegarder les valeurs de t et q a la fin de la physique: +c + DO k = 1, klev + DO i = 1, klon + u_ancien(i,k) = u_seri(i,k) + v_ancien(i,k) = v_seri(i,k) + t_ancien(i,k) = t_seri(i,k) + q_ancien(i,k) = q_seri(i,k) + ENDDO + ENDDO +c +!========================================================================== +! Sorties des tendances pour un point particulier +! a utiliser en 1D, avec igout=1 ou en 3D sur un point particulier +! pour le debug +! La valeur de igout est attribuee plus haut dans le programme +!========================================================================== + + if (prt_level.ge.1) then + write(lunout,*) 'FIN DE PHYSIQ !!!!!!!!!!!!!!!!!!!!' + write(lunout,*) + s 'nlon,klev,nqtot,debut,lafin,jD_cur, jH_cur, pdtphys pct tlos' + write(lunout,*) + s nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur ,pdtphys, + s pctsrf(igout,is_ter), pctsrf(igout,is_lic),pctsrf(igout,is_oce), + s pctsrf(igout,is_sic) + write(lunout,*) 'd_t_dyn,d_t_con,d_t_lsc,d_t_ajsb,d_t_ajs,d_t_eva' + do k=1,klev + write(lunout,*) d_t_dyn(igout,k),d_t_con(igout,k), + s d_t_lsc(igout,k),d_t_ajsb(igout,k),d_t_ajs(igout,k), + s d_t_eva(igout,k) + enddo + write(lunout,*) 'cool,heat' + do k=1,klev + write(lunout,*) cool(igout,k),heat(igout,k) + enddo + + write(lunout,*) 'd_t_oli,d_t_vdf,d_t_oro,d_t_lif,d_t_ec' + do k=1,klev + write(lunout,*) d_t_oli(igout,k),d_t_vdf(igout,k), + s d_t_oro(igout,k),d_t_lif(igout,k),d_t_ec(igout,k) + enddo + + write(lunout,*) 'd_ps ',d_ps(igout) + write(lunout,*) 'd_u, d_v, d_t, d_qx1, d_qx2 ' + do k=1,klev + write(lunout,*) d_u(igout,k),d_v(igout,k),d_t(igout,k), + s d_qx(igout,k,1),d_qx(igout,k,2) + enddo + endif + +!========================================================================== + +c============================================================ +c Calcul de la temperature potentielle +c============================================================ + DO k = 1, klev + DO i = 1, klon + theta(i,k)=t(i,k)*(100000./pplay(i,k))**(RD/RCPD) + ENDDO + ENDDO +c + +c 22.03.04 BEG +c============================================================= +c Ecriture des sorties +c============================================================= +#ifdef CPP_IOIPSL + +c Recupere des varibles calcule dans differents modules +c pour ecriture dans histxxx.nc + + ! Get some variables from module fonte_neige_mod + CALL fonte_neige_get_vars(pctsrf, + . zxfqcalving, zxfqfonte, zxffonte) + + +#include "phys_output_write.h" + +#ifdef histISCCP +#include "write_histISCCP.h" +#endif + +#ifdef histmthNMC +#include "write_histmthNMC.h" +#endif + +#include "write_histday_seri.h" + +#include "write_paramLMDZ_phy.h" + +#endif + +c 22.03.04 END +c +c==================================================================== +c Si c'est la fin, il faut conserver l'etat de redemarrage +c==================================================================== +c + + + IF (lafin) THEN + itau_phy = itau_phy + itap + CALL phyredem ("restartphy.nc") +! open(97,form="unformatted",file="finbin") +! write(97) u_seri,v_seri,t_seri,q_seri +! close(97) +C$OMP MASTER + if (read_climoz >= 1) then + if (is_mpi_root) then + call nf95_close(ncid_climoz) + end if + deallocate(press_climoz) ! pointer + end if +C$OMP END MASTER + ENDIF + +! first=.false. + + RETURN + END + FUNCTION qcheck(klon,klev,paprs,q,ql,aire) + IMPLICIT none +c +c Calculer et imprimer l'eau totale. A utiliser pour verifier +c la conservation de l'eau +c +#include "YOMCST.h" + INTEGER klon,klev + REAL paprs(klon,klev+1), q(klon,klev), ql(klon,klev) + REAL aire(klon) + REAL qtotal, zx, qcheck + INTEGER i, k +c + zx = 0.0 + DO i = 1, klon + zx = zx + aire(i) + ENDDO + qtotal = 0.0 + DO k = 1, klev + DO i = 1, klon + qtotal = qtotal + (q(i,k)+ql(i,k)) * aire(i) + . *(paprs(i,k)-paprs(i,k+1))/RG + ENDDO + ENDDO +c + qcheck = qtotal/zx +c + RETURN + END + SUBROUTINE gr_fi_ecrit(nfield,nlon,iim,jjmp1,fi,ecrit) + IMPLICIT none +c +c Tranformer une variable de la grille physique a +c la grille d'ecriture +c + INTEGER nfield,nlon,iim,jjmp1, jjm + REAL fi(nlon,nfield), ecrit(iim*jjmp1,nfield) +c + INTEGER i, n, ig +c + jjm = jjmp1 - 1 + DO n = 1, nfield + DO i=1,iim + ecrit(i,n) = fi(1,n) + ecrit(i+jjm*iim,n) = fi(nlon,n) + ENDDO + DO ig = 1, nlon - 2 + ecrit(iim+ig,n) = fi(1+ig,n) + ENDDO + ENDDO + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phystokenc.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phystokenc.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phystokenc.F (revision 1280) @@ -0,0 +1,434 @@ +! +c +c + SUBROUTINE phystokenc ( + I nlon,nlev,pdtphys,rlon,rlat, + I pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, + I pfm_therm,pentr_therm, + I cdragh, pcoefh,yu1,yv1,ftsol,pctsrf, + I frac_impa,frac_nucl, + I pphis,paire,dtime,itap) + USE ioipsl + USE dimphy + USE infotrac, ONLY : nqtot + USE iophy + IMPLICIT none + +c====================================================================== +c Auteur(s) FH +c Objet: Moniteur general des tendances traceurs +c + +c====================================================================== +#include "dimensions.h" +#include "tracstoke.h" +#include "indicesol.h" +#include "control.h" +c====================================================================== + +c Arguments: +c +c EN ENTREE: +c ========== +c +c divers: +c ------- +c + integer nlon ! nombre de points horizontaux + integer nlev ! nombre de couches verticales + real pdtphys ! pas d'integration pour la physique (seconde) +c + integer physid, itap + save physid +c$OMP THREADPRIVATE(physid) + integer ndex2d(iim*(jjm+1)),ndex3d(iim*(jjm+1)*klev) + +c convection: +c ----------- +c + REAL pmfu(klon,klev) ! flux de masse dans le panache montant + REAL pmfd(klon,klev) ! flux de masse dans le panache descendant + REAL pen_u(klon,klev) ! flux entraine dans le panache montant + REAL pde_u(klon,klev) ! flux detraine dans le panache montant + REAL pen_d(klon,klev) ! flux entraine dans le panache descendant + REAL pde_d(klon,klev) ! flux detraine dans le panache descendant + real pt(klon,klev) + REAL,allocatable,save :: t(:,:) +c$OMP THREADPRIVATE(t) +c + REAL rlon(klon), rlat(klon), dtime + REAL zx_tmp_3d(iim,jjm+1,klev),zx_tmp_2d(iim,jjm+1) + +c Couche limite: +c -------------- +c + REAL cdragh(klon) ! cdrag + REAL pcoefh(klon,klev) ! coeff melange CL + REAL pcoefh_buf(klon,klev) ! coeff melange CL + cdrag + REAL yv1(klon) + REAL yu1(klon),pphis(klon),paire(klon) + +c Les Thermiques : (Abderr 25 11 02) +c --------------- + REAL pfm_therm(klon,klev+1) + real fm_therm1(klon,klev) + REAL pentr_therm(klon,klev) + + REAL,allocatable,save :: entr_therm(:,:) + REAL,allocatable,save :: fm_therm(:,:) +c$OMP THREADPRIVATE(entr_therm) +c$OMP THREADPRIVATE(fm_therm) +c +c Lessivage: +c ---------- +c + REAL frac_impa(klon,klev) + REAL frac_nucl(klon,klev) +c +c Arguments necessaires pour les sources et puits de traceur +C + real ftsol(klon,nbsrf) ! Temperature du sol (surf)(Kelvin) + real pctsrf(klon,nbsrf) ! Pourcentage de sol f(nature du sol) +c====================================================================== +c + INTEGER i, k +c + REAL,allocatable,save :: mfu(:,:) ! flux de masse dans le panache montant + REAL,allocatable,save :: mfd(:,:) ! flux de masse dans le panache descendant + REAL,allocatable,save :: en_u(:,:) ! flux entraine dans le panache montant + REAL,allocatable,save :: de_u(:,:) ! flux detraine dans le panache montant + REAL,allocatable,save :: en_d(:,:) ! flux entraine dans le panache descendant + REAL,allocatable,save :: de_d(:,:) ! flux detraine dans le panache descendant + REAL,allocatable,save :: coefh(:,:) ! flux detraine dans le panache descendant + + REAL,allocatable,save :: pyu1(:) + REAL,allocatable,save :: pyv1(:) + REAL,allocatable,save :: pftsol(:,:) + REAL,allocatable,save :: ppsrf(:,:) +c$OMP THREADPRIVATE(mfu,mfd,en_u,de_u,en_d,de_d,coefh) +c$OMP THREADPRIVATE(pyu1,pyv1,pftsol,ppsrf) + real pftsol1(klon),pftsol2(klon),pftsol3(klon),pftsol4(klon) + real ppsrf1(klon),ppsrf2(klon),ppsrf3(klon),ppsrf4(klon) + + REAL dtcum + + integer iadvtr,irec + real zmin,zmax + logical ok_sync + + save dtcum + save iadvtr,irec +c$OMP THREADPRIVATE(dtcum,iadvtr,irec) + data iadvtr,irec/0,1/ + logical,save :: first=.true. +c$OMP THREADPRIVATE(first) +c +c Couche limite: +c====================================================================== + +c Dans le meme vecteur on recombine le drag et les coeff d'echange + pcoefh_buf(:,1) = cdragh(:) + pcoefh_buf(:,2:klev) = pcoefh(:,2:klev) + + ok_sync = .true. + print*,'Dans phystokenc.F' + print*,'iadvtr= ',iadvtr + print*,'istphy= ',istphy + print*,'istdyn= ',istdyn + + if (first) then + + allocate( t(klon,klev)) + allocate( mfu(klon,klev)) + allocate( mfd(klon,klev)) + allocate( en_u(klon,klev)) + allocate( de_u(klon,klev)) + allocate( en_d(klon,klev)) + allocate( de_d(klon,klev)) + allocate( coefh(klon,klev)) + allocate( entr_therm(klon,klev)) + allocate( fm_therm(klon,klev)) + allocate( pyu1(klon)) + allocate( pyv1(klon)) + allocate( pftsol(klon,nbsrf)) + allocate( ppsrf(klon,nbsrf)) + + first=.false. + endif + + IF (iadvtr.eq.0) THEN + + CALL initphysto('phystoke', + . rlon,rlat,dtime, dtime*istphy,dtime*istphy,nqtot,physid) + + write(*,*) 'apres initphysto ds phystokenc' + + + ENDIF +c + ndex2d = 0 + ndex3d = 0 + i=itap +cym CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d) + CALL histwrite_phy(physid,"phis",i,pphis) +c + i=itap +cym CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d) + CALL histwrite_phy(physid,"aire",i,paire) + + iadvtr=iadvtr+1 +c + if (mod(iadvtr,istphy).eq.1.or.istphy.eq.1) then + print*,'reinitialisation des champs cumules + s a iadvtr=',iadvtr + do k=1,klev + do i=1,klon + mfu(i,k)=0. + mfd(i,k)=0. + en_u(i,k)=0. + de_u(i,k)=0. + en_d(i,k)=0. + de_d(i,k)=0. + coefh(i,k)=0. + t(i,k)=0. + fm_therm(i,k)=0. + entr_therm(i,k)=0. + enddo + enddo + do i=1,klon + pyv1(i)=0. + pyu1(i)=0. + end do + do k=1,nbsrf + do i=1,klon + pftsol(i,k)=0. + ppsrf(i,k)=0. + enddo + enddo + + dtcum=0. + endif + + do k=1,klev + do i=1,klon + mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys + mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys + en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys + de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys + en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys + de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys + coefh(i,k)=coefh(i,k)+pcoefh_buf(i,k)*pdtphys + t(i,k)=t(i,k)+pt(i,k)*pdtphys + fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys + entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys + enddo + enddo + do i=1,klon + pyv1(i)=pyv1(i)+yv1(i)*pdtphys + pyu1(i)=pyu1(i)+yu1(i)*pdtphys + end do + do k=1,nbsrf + do i=1,klon + pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys + ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys + enddo + enddo + + dtcum=dtcum+pdtphys + + IF(mod(iadvtr,istphy).eq.0) THEN +c +c normalisation par le temps cumule + do k=1,klev + do i=1,klon + mfu(i,k)=mfu(i,k)/dtcum + mfd(i,k)=mfd(i,k)/dtcum + en_u(i,k)=en_u(i,k)/dtcum + de_u(i,k)=de_u(i,k)/dtcum + en_d(i,k)=en_d(i,k)/dtcum + de_d(i,k)=de_d(i,k)/dtcum + coefh(i,k)=coefh(i,k)/dtcum +c Unitel a enlever + t(i,k)=t(i,k)/dtcum + fm_therm(i,k)=fm_therm(i,k)/dtcum + entr_therm(i,k)=entr_therm(i,k)/dtcum + enddo + enddo + do i=1,klon + pyv1(i)=pyv1(i)/dtcum + pyu1(i)=pyu1(i)/dtcum + end do + do k=1,nbsrf + do i=1,klon + pftsol(i,k)=pftsol(i,k)/dtcum + pftsol1(i) = pftsol(i,1) + pftsol2(i) = pftsol(i,2) + pftsol3(i) = pftsol(i,3) + pftsol4(i) = pftsol(i,4) + + ppsrf(i,k)=ppsrf(i,k)/dtcum + ppsrf1(i) = ppsrf(i,1) + ppsrf2(i) = ppsrf(i,2) + ppsrf3(i) = ppsrf(i,3) + ppsrf4(i) = ppsrf(i,4) + + enddo + enddo +c +c ecriture des champs +c + irec=irec+1 + +ccccc +cym CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t, zx_tmp_3d) + CALL histwrite_phy(physid,"t",itap,t) + +cym CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfu, zx_tmp_3d) + CALL histwrite_phy(physid,"mfu",itap,mfu) +cym CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfd, zx_tmp_3d) + CALL histwrite_phy(physid,"mfd",itap,mfd) +cym CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_u, zx_tmp_3d) + CALL histwrite_phy(physid,"en_u",itap,en_u) +cym CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_u, zx_tmp_3d) + CALL histwrite_phy(physid,"de_u",itap,de_u) +cym CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_d, zx_tmp_3d) + CALL histwrite_phy(physid,"en_d",itap,en_d) +cym CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_d, zx_tmp_3d) + CALL histwrite_phy(physid,"de_d",itap,de_d) +cym CALL gr_fi_ecrit(klev,klon,iim,jjm+1, coefh, zx_tmp_3d) + CALL histwrite_phy(physid,"coefh",itap,coefh) + +c ajou... + do k=1,klev + do i=1,klon + fm_therm1(i,k)=fm_therm(i,k) + enddo + enddo + +cym CALL gr_fi_ecrit(klev,klon,iim,jjm+1, fm_therm1, zx_tmp_3d) + CALL histwrite_phy(physid,"fm_th",itap,fm_therm1) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjm+1, entr_therm, zx_tmp_3d) + CALL histwrite_phy(physid,"en_th",itap,entr_therm) +cccc +cym CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_impa,zx_tmp_3d) + CALL histwrite_phy(physid,"frac_impa",itap,frac_impa) + +cym CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_nucl,zx_tmp_3d) + CALL histwrite_phy(physid,"frac_nucl",itap,frac_nucl) + +cym CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyu1,zx_tmp_2d) + CALL histwrite_phy(physid,"pyu1",itap,pyu1) + +cym CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyv1,zx_tmp_2d) + CALL histwrite_phy(physid,"pyv1",itap,pyv1) + +cym CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol1, zx_tmp_2d) + CALL histwrite_phy(physid,"ftsol1",itap,pftsol1) +cym CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol2, zx_tmp_2d) + CALL histwrite_phy(physid,"ftsol2",itap,pftsol2) +cym CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol3, zx_tmp_2d) + CALL histwrite_phy(physid,"ftsol3",itap,pftsol3) +cym CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol4, zx_tmp_2d) + CALL histwrite_phy(physid,"ftsol4",itap,pftsol4) + +cym CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf1, zx_tmp_2d) + CALL histwrite_phy(physid,"psrf1",itap,ppsrf1) +cym CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf2, zx_tmp_2d) + CALL histwrite_phy(physid,"psrf2",itap,ppsrf2) +cym CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf3, zx_tmp_2d) + CALL histwrite_phy(physid,"psrf3",itap,ppsrf3) +cym CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf4, zx_tmp_2d) + CALL histwrite_phy(physid,"psrf4",itap,ppsrf4) + +c$OMP MASTER + if (ok_sync) call histsync(physid) +c$OMP END MASTER +c if (ok_sync) call histsync + +c +cAA Test sur la valeur des coefficients de lessivage +c + zmin=1e33 + zmax=-1e33 + do k=1,klev + do i=1,klon + zmax=max(zmax,frac_nucl(i,k)) + zmin=min(zmin,frac_nucl(i,k)) + enddo + enddo + Print*,'------ coefs de lessivage (min et max) --------' + Print*,'facteur de nucleation ',zmin,zmax + zmin=1e33 + zmax=-1e33 + do k=1,klev + do i=1,klon + zmax=max(zmax,frac_impa(i,k)) + zmin=min(zmin,frac_impa(i,k)) + enddo + enddo + Print*,'facteur d impaction ',zmin,zmax + + ENDIF + +c reinitialisation des champs cumules + go to 768 + if (mod(iadvtr,istphy).eq.1) then + do k=1,klev + do i=1,klon + mfu(i,k)=0. + mfd(i,k)=0. + en_u(i,k)=0. + de_u(i,k)=0. + en_d(i,k)=0. + de_d(i,k)=0. + coefh(i,k)=0. + t(i,k)=0. + fm_therm(i,k)=0. + entr_therm(i,k)=0. + enddo + enddo + do i=1,klon + pyv1(i)=0. + pyu1(i)=0. + end do + do k=1,nbsrf + do i=1,klon + pftsol(i,k)=0. + ppsrf(i,k)=0. + enddo + enddo + + dtcum=0. + endif + + do k=1,klev + do i=1,klon + mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys + mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys + en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys + de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys + en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys + de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys + coefh(i,k)=coefh(i,k)+pcoefh_buf(i,k)*pdtphys + t(i,k)=t(i,k)+pt(i,k)*pdtphys + fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys + entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys + enddo + enddo + do i=1,klon + pyv1(i)=pyv1(i)+yv1(i)*pdtphys + pyu1(i)=pyu1(i)+yu1(i)*pdtphys + end do + do k=1,nbsrf + do i=1,klon + pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys + ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys + enddo + enddo + + dtcum=dtcum+pdtphys +768 continue + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phytrac.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phytrac.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/phytrac.F90 (revision 1280) @@ -0,0 +1,412 @@ +!$Id $ + +SUBROUTINE phytrac( & + nstep, julien, gmtime, debutphy, & + lafin, pdtphys, u, v, t_seri, & + paprs, pplay, pmfu, pmfd, & + pen_u, pde_u, pen_d, pde_d, & + cdragh, coefh, fm_therm, entr_therm,& + yu1, yv1, ftsol, pctsrf, & + xlat, frac_impa,frac_nucl,xlon, & + presnivs, pphis, pphi, albsol, & + sh, rh, cldfra, rneb, & + diafra, cldliq, itop_con, ibas_con, & + pmflxr, pmflxs, prfl, psfl, & + da, phi, mp, upwd, & + dnwd, aerosol_couple, flxmass_w, & + tau_aero, piz_aero, cg_aero, ccm, & + rfname, & + tr_seri) +! +!====================================================================== +! Auteur(s) FH +! Objet: Moniteur general des tendances traceurs +!====================================================================== + + USE ioipsl + USE dimphy + USE infotrac + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE comgeomphy + USE iophy + USE traclmdz_mod + USE tracinca_mod + + + IMPLICIT NONE + + INCLUDE "YOMCST.h" + INCLUDE "dimensions.h" + INCLUDE "indicesol.h" + INCLUDE "clesphys.h" + INCLUDE "temps.h" + INCLUDE "paramet.h" + INCLUDE "control.h" + INCLUDE "thermcell.h" +!========================================================================== +! -- ARGUMENT DESCRIPTION -- +!========================================================================== + +! Input arguments +!---------------- +!Configuration grille,temps: + INTEGER,INTENT(IN) :: nstep ! Appel physique + INTEGER,INTENT(IN) :: julien ! Jour julien + REAL,INTENT(IN) :: gmtime + REAL,INTENT(IN) :: pdtphys ! Pas d'integration pour la physique (seconde) + LOGICAL,INTENT(IN) :: debutphy ! le flag de l'initialisation de la physique + LOGICAL,INTENT(IN) :: lafin ! le flag de la fin de la physique + + REAL,DIMENSION(klon),INTENT(IN) :: xlat ! latitudes pour chaque point + REAL,DIMENSION(klon),INTENT(IN) :: xlon ! longitudes pour chaque point +! +!Physique: +!-------- + REAL,DIMENSION(klon,klev),INTENT(IN) :: t_seri ! Temperature + REAL,DIMENSION(klon,klev),INTENT(IN) :: u ! + REAL,DIMENSION(klon,klev),INTENT(IN) :: v ! + REAL,DIMENSION(klon,klev),INTENT(IN) :: sh ! humidite specifique + REAL,DIMENSION(klon,klev),INTENT(IN) :: rh ! humidite relative + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs ! pression pour chaque inter-couche (en Pa) + REAL,DIMENSION(klon,klev),INTENT(IN) :: pplay ! pression pour le mileu de chaque couche (en Pa) + REAL,DIMENSION(klon,klev),INTENT(IN) :: pphi ! geopotentiel + REAL,DIMENSION(klon),INTENT(IN) :: pphis + REAL,DIMENSION(klev),INTENT(IN) :: presnivs + REAL,DIMENSION(klon,klev),INTENT(IN) :: cldliq ! eau liquide nuageuse + REAL,DIMENSION(klon,klev),INTENT(IN) :: cldfra ! fraction nuageuse (tous les nuages) + REAL,DIMENSION(klon,klev),INTENT(IN) :: diafra ! fraction nuageuse (convection ou stratus artificiels) + REAL,DIMENSION(klon,klev),INTENT(IN) :: rneb ! fraction nuageuse (grande echelle) + INTEGER,DIMENSION(klon),INTENT(IN) :: itop_con + INTEGER,DIMENSION(klon),INTENT(IN) :: ibas_con + REAL,DIMENSION(klon),INTENT(IN) :: albsol ! albedo surface +! +!Convection: +!---------- + REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfu ! flux de masse dans le panache montant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfd ! flux de masse dans le panache descendant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_u ! flux entraine dans le panache montant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_u ! flux detraine dans le panache montant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_d ! flux entraine dans le panache descendant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_d ! flux detraine dans le panache descendant + +!...Tiedke + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: pmflxr, pmflxs ! Flux precipitant de pluie, neige aux interfaces [convection] + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: prfl, psfl ! Flux precipitant de pluie, neige aux interfaces [large-scale] + + LOGICAL,INTENT(IN) :: aerosol_couple + REAL,DIMENSION(klon,klev),INTENT(IN) :: flxmass_w + REAL,DIMENSION(klon,klev,9,2),INTENT(IN) :: tau_aero + REAL,DIMENSION(klon,klev,9,2),INTENT(IN) :: piz_aero + REAL,DIMENSION(klon,klev,9,2),INTENT(IN) :: cg_aero + CHARACTER(len=4),DIMENSION(9),INTENT(IN) :: rfname + REAL,DIMENSION(klon,klev,2),INTENT(IN) :: ccm +!... K.Emanuel + REAL,DIMENSION(klon,klev),INTENT(IN) :: da + REAL,DIMENSION(klon,klev,klev),INTENT(IN):: phi + REAL,DIMENSION(klon,klev),INTENT(IN) :: mp + REAL,DIMENSION(klon,klev),INTENT(IN) :: upwd ! saturated updraft mass flux + REAL,DIMENSION(klon,klev),INTENT(IN) :: dnwd ! saturated downdraft mass flux +! +!Thermiques: +!---------- + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: fm_therm + REAL,DIMENSION(klon,klev),INTENT(IN) :: entr_therm +! +!Couche limite: +!-------------- +! + REAL,DIMENSION(klon,klev),INTENT(IN) :: cdragh ! coeff drag pour T et Q + REAL,DIMENSION(klon,klev),INTENT(IN) :: coefh ! coeff melange CL (m**2/s) + REAL,DIMENSION(klon),INTENT(IN) :: yu1 ! vents au premier niveau + REAL,DIMENSION(klon),INTENT(IN) :: yv1 ! vents au premier niveau +! +!Lessivage: +!---------- +! +! pour le ON-LINE +! + REAL,DIMENSION(klon,klev),INTENT(IN) :: frac_impa ! fraction d'aerosols non impactes + REAL,DIMENSION(klon,klev),INTENT(IN) :: frac_nucl ! fraction d'aerosols non nuclees + +! Arguments necessaires pour les sources et puits de traceur: + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol ! Temperature du sol (surf)(Kelvin) + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Pourcentage de sol (nature du sol) + + +! Output argument +!---------------- + REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT) :: tr_seri ! Concentration Traceur [U/KgA] + +!======================================================================================= +! -- LOCAL VARIABLES -- +!======================================================================================= + + INTEGER :: i, k, it + INTEGER :: nsplit + +!Sources et Reservoirs de traceurs (ex:Radon): +!-------------------------------------------- +! + REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: source ! a voir lorsque le flux de surface est prescrit +!$OMP THREADPRIVATE(source) + +! +!Entrees/Sorties: (cf ini_histrac.h et write_histrac.h) +!--------------- + INTEGER :: iiq, ierr + INTEGER :: nhori, nvert + REAL :: zsto, zout, zjulian + INTEGER,SAVE :: nid_tra ! pointe vers le fichier histrac.nc +!$OMP THREADPRIVATE(nid_tra) + REAL,DIMENSION(klon) :: zx_tmp_fi2d ! variable temporaire grille physique + INTEGER :: itau_w ! pas de temps ecriture = nstep + itau_phy + LOGICAL,PARAMETER :: ok_sync=.TRUE. + +! +! Nature du traceur +!------------------ + LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: aerosol ! aerosol(it) = true => aerosol => lessivage +!$OMP THREADPRIVATE(aerosol) ! aerosol(it) = false => gaz + REAL,DIMENSION(klon,klev) :: delp ! epaisseur de couche (Pa) +! +! Tendances de traceurs (Td): +!------------------------ +! + REAL,DIMENSION(klon,klev) :: d_tr ! Td dans l'atmosphere + REAL,DIMENSION(klon,klev,nbtr) :: d_tr_cl ! Td couche limite/traceur + REAL,DIMENSION(klon,klev,nbtr) :: d_tr_cv ! Td convection/traceur + REAL,DIMENSION(klon,klev,nbtr) :: d_tr_th ! Td thermique + REAL,DIMENSION(klon,klev,nbtr) :: d_tr_lessi_impa ! Td du lessivage par impaction + REAL,DIMENSION(klon,klev,nbtr) :: d_tr_lessi_nucl ! Td du lessivage par nucleation +! +! Physique +!---------- + REAL,DIMENSION(klon,klev,nbtr) :: flestottr ! flux de lessivage dans chaque couche + REAL,DIMENSION(klon,klev) :: zmasse ! densité atmosphérique Kg/m2 + REAL,DIMENSION(klon,klev) :: ztra_th + +!Controles: +!--------- + LOGICAL,SAVE :: couchelimite=.TRUE. + LOGICAL,SAVE :: convection=.TRUE. + LOGICAL,SAVE :: lessivage +!$OMP THREADPRIVATE(couchelimite,convection,lessivage) + + CHARACTER(len=8),DIMENSION(nbtr) :: solsym + + +!###################################################################### +! -- INITIALIZATION -- +!###################################################################### + IF (debutphy) THEN + WRITE(*,*) 'FIRST TIME IN PHYTRAC : pdtphys(sec) = ',pdtphys,'ecrit_tra (sec) = ',ecrit_tra + ALLOCATE( source(klon,nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('phytrac', 'pb in allocation 1',1) + + ALLOCATE( aerosol(nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('phytrac', 'pb in allocation 2',1) + + + ! Initialize module for specific tracers + SELECT CASE(type_trac) + CASE('lmdz') + CALL traclmdz_init(pctsrf, ftsol, tr_seri, aerosol, lessivage) + CASE('inca') + source(:,:)=0. + CALL tracinca_init(aerosol,lessivage) + END SELECT +! +! Initialize diagnostic output +! ---------------------------- +#ifdef CPP_IOIPSL + INCLUDE "ini_histrac.h" +#endif + END IF +!############################################ END INITIALIZATION ####### + +!=============================================================================== +! -- Do specific treatment according to chemestry model or local LMDZ tracers +! +!=============================================================================== + SELECT CASE(type_trac) + CASE('lmdz') + ! -- Traitement des traceurs avec traclmdz + + CALL traclmdz(& + nstep, pdtphys, t_seri, & + paprs, pplay, cdragh, coefh, & + yu1, yv1, ftsol, pctsrf, & + xlat, couchelimite, & + tr_seri, source, solsym, d_tr_cl) + + CASE('inca') + ! -- CHIMIE INCA config_inca = aero or chem -- + + CALL tracinca(& + nstep, julien, gmtime, lafin, & + pdtphys, t_seri, paprs, pplay, & + pmfu, ftsol, pctsrf, pphis, & + pphi, albsol, sh, rh, & + cldfra, rneb, diafra, cldliq, & + itop_con, ibas_con, pmflxr, pmflxs, & + prfl, psfl, aerosol_couple, flxmass_w, & + tau_aero, piz_aero, cg_aero, ccm, & + rfname, & + tr_seri, source, solsym) + END SELECT + +!====================================================================== +! -- Calcul de l'effet de la convection -- +!====================================================================== + IF (convection) THEN + DO it=1, nbtr + IF ( conv_flg(it) == 0 ) CYCLE + + IF (iflag_con.LT.2) THEN + d_tr_cv(:,:,:)=0. + ELSE IF (iflag_con.EQ.2) THEN +!..Tiedke + CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, & + pplay, paprs, tr_seri(:,:,it), d_tr_cv(:,:,it)) + ELSE +!..K.Emanuel + CALL cvltr(pdtphys, da, phi, mp, paprs,pplay, tr_seri(:,:,it),& + upwd,dnwd,d_tr_cv(:,:,it)) + END IF + + DO k = 1, klev + DO i = 1, klon + tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cv(i,k,it) + END DO + END DO + + CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'convection it = '//solsym(it)) + + END DO ! nbtr + END IF ! convection + +!====================================================================== +! -- Calcul de l'effet des thermiques -- +!====================================================================== + + DO k=1,klev + DO i=1,klon + zmasse(i,k)=(paprs(i,k)-paprs(i,k+1))/rg + END DO + END DO + + DO it=1,nbtr + DO k=1,klev + DO i=1,klon + d_tr_th(i,k,it)=0. + tr_seri(i,k,it)=MAX(tr_seri(i,k,it),0.) + tr_seri(i,k,it)=MIN(tr_seri(i,k,it),1.e10) + END DO + END DO + END DO + + IF (iflag_thermals.GT.0) THEN + nsplit=10 + DO it=1, nbtr + DO isplit=1,nsplit + + CALL dqthermcell(klon,klev,pdtphys/nsplit, & + fm_therm,entr_therm,zmasse, & + tr_seri(1:klon,1:klev,it),d_tr,ztra_th) + + DO k=1,klev + DO i=1,klon + d_tr(i,k)=pdtphys*d_tr(i,k)/nsplit + d_tr_th(i,k,it)=d_tr_th(i,k,it)+d_tr(i,k) + tr_seri(i,k,it)=MAX(tr_seri(i,k,it)+d_tr(i,k),0.) + END DO + END DO + END DO ! nsplit + END DO ! it + END IF ! Thermiques + +!====================================================================== +! -- Calcul de l'effet de la couche limite -- +!====================================================================== + + IF (couchelimite) THEN + + DO k = 1, klev + DO i = 1, klon + delp(i,k) = paprs(i,k)-paprs(i,k+1) + END DO + END DO + + DO it=1, nbtr + + IF( pbl_flg(it) /= 0 ) THEN + + CALL cltrac(pdtphys, coefh,t_seri, & + tr_seri(:,:,it), source(:,it), & + paprs, pplay, delp, & + d_tr_cl(:,:,it)) + + DO k = 1, klev + DO i = 1, klon + tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cl(i,k,it) + END DO + END DO + END IF + + END DO + + END IF ! couche limite + + +!====================================================================== +! Calcul de l'effet de la precipitation +!====================================================================== + + IF (lessivage) THEN + + d_tr_lessi_nucl(:,:,:) = 0. + d_tr_lessi_impa(:,:,:) = 0. + flestottr(:,:,:) = 0. +!========================= +! LESSIVAGE LARGE SCALE : +!========================= + +! Tendance des aerosols nuclees et impactes +! ----------------------------------------- + DO it = 1, nbtr + IF (aerosol(it)) THEN + DO k = 1, klev + DO i = 1, klon + d_tr_lessi_nucl(i,k,it) = d_tr_lessi_nucl(i,k,it) + & + ( 1 - frac_nucl(i,k) )*tr_seri(i,k,it) + d_tr_lessi_impa(i,k,it) = d_tr_lessi_impa(i,k,it) + & + ( 1 - frac_impa(i,k) )*tr_seri(i,k,it) + +! +! Flux lessivage total +! ------------------------------------------------------------ + flestottr(i,k,it) = flestottr(i,k,it) - & + ( d_tr_lessi_nucl(i,k,it) + & + d_tr_lessi_impa(i,k,it) ) * & + ( paprs(i,k)-paprs(i,k+1) ) / & + (RG * pdtphys) +! +! Mise a jour des traceurs due a l'impaction,nucleation +! ---------------------------------------------------------------------- + tr_seri(i,k,it)=tr_seri(i,k,it)*frac_impa(i,k)*frac_nucl(i,k) + END DO + END DO + END IF + END DO + + END IF ! lessivage + +!============================================================= +! Ecriture des sorties +!============================================================= +#ifdef CPP_IOIPSL + INCLUDE "write_histrac.h" +#endif + +END SUBROUTINE phytrac Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/planete.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/planete.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/planete.h (revision 1280) @@ -0,0 +1,12 @@ +c----------------------------------------------------------------------- +c INCLUDE planet.h + + COMMON/planet/aphelie,periheli,year_day,peri_day, & + & obliquit, & + & timeperi,e_elips,p_elips,unitastr + + REAL aphelie,periheli,year_day,peri_day, & + & obliquit, & + & timeperi,e_elips,p_elips,unitastr + +c----------------------------------------------------------------------- Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/plevel.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/plevel.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/plevel.F (revision 1280) @@ -0,0 +1,132 @@ +! +! $Header$ +! +c================================================================ +c================================================================ + SUBROUTINE plevel(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres) +c================================================================ +c================================================================ + USE netcdf + USE dimphy + IMPLICIT none + +cym#include "dimensions.h" +cy#include "dimphy.h" + +c================================================================ +c +c Interpoler des champs 3-D u, v et g du modele a un niveau de +c pression donnee (pres) +c +c INPUT: ilon ----- nombre de points +c ilev ----- nombre de couches +c lnew ----- true si on doit reinitialiser les poids +c pgcm ----- pressions modeles +c pres ----- pression vers laquelle on interpolle +c Qgcm ----- champ GCM +c Qpres ---- champ interpolle au niveau pres +c +c================================================================ +c +c arguments : +c ----------- + + INTEGER ilon, ilev + logical lnew + + REAL pgcm(ilon,ilev) + REAL Qgcm(ilon,ilev) + real pres + REAL Qpres(ilon) + +c local : +c ------- + +cym INTEGER lt(klon), lb(klon) +cym REAL ptop, pbot, aist(klon), aisb(klon) + +cym save lt,lb,ptop,pbot,aist,aisb + INTEGER,ALLOCATABLE,SAVE,DIMENSION(:) :: lt,lb + REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: aist,aisb +c$OMP THREADPRIVATE(lt,lb,aist,aisb) + REAL,SAVE :: ptop, pbot +c$OMP THREADPRIVATE(ptop, pbot) + LOGICAL,SAVE :: first = .true. +c$OMP THREADPRIVATE(first) + INTEGER i, k +c + REAL missing_val +c + missing_val=nf90_fill_real +c + if (first) then + allocate(lt(klon),lb(klon),aist(klon),aisb(klon)) + first=.false. + endif + +c===================================================================== + if (lnew) then +c on r�nitialise les r�ndicages et les poids +c===================================================================== + + +c Chercher les 2 couches les plus proches du niveau a obtenir +c +c Eventuellement, faire l'extrapolation a partir des deux couches +c les plus basses ou les deux couches les plus hautes: + DO 130 i = 1, klon + IF ( ABS(pres-pgcm(i,ilev) ) .LT. + . ABS(pres-pgcm(i,1)) ) THEN + lt(i) = ilev ! 2 + lb(i) = ilev-1 ! 1 + ELSE + lt(i) = 2 + lb(i) = 1 + ENDIF + 130 CONTINUE + DO 150 k = 1, ilev-1 + DO 140 i = 1, klon + pbot = pgcm(i,k) + ptop = pgcm(i,k+1) + IF (ptop.LE.pres .AND. pbot.GE.pres) THEN + lt(i) = k+1 + lb(i) = k + ENDIF + 140 CONTINUE + 150 CONTINUE +c +c Interpolation lineaire: +c + DO i = 1, klon +c interpolation en logarithme de pression: +c +c ... Modif . P. Le Van ( 20/01/98) .... +c Modif Fr��ic Hourdin (3/01/02) + + aist(i) = LOG( pgcm(i,lb(i))/ pres ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) ) + aisb(i) = LOG( pres / pgcm(i,lt(i)) ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i))) + enddo + + + endif ! lnew + +c====================================================================== +c inteprollation +c====================================================================== + + do i=1,klon + Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i) + enddo +c +c Je mets les vents a zero quand je rencontre une montagne + do i = 1, klon + if (pgcm(i,1).LT.pres) THEN + Qpres(i)=missing_val + endif + enddo + +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/plevel_new.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/plevel_new.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/plevel_new.F (revision 1280) @@ -0,0 +1,138 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/plevel.F,v 1.1.1.1.10.1 2006/08/17 15:41:51 fairhead Exp $ +! +c================================================================ +c================================================================ + SUBROUTINE plevel_new(ilon,ilev,klevSTD,lnew,pgcm,pres,Qgcm,Qpres) +c================================================================ +c================================================================ + USE netcdf + USE dimphy + IMPLICIT none + +cym#include "dimensions.h" +cy#include "dimphy.h" + +c================================================================ +c +c Interpoler des champs 3-D u, v et g du modele a un niveau de +c pression donnee (pres) +c +c INPUT: ilon ----- nombre de points +c ilev ----- nombre de couches +c lnew ----- true si on doit reinitialiser les poids +c pgcm ----- pressions modeles +c pres ----- pression vers laquelle on interpolle +c Qgcm ----- champ GCM +c Qpres ---- champ interpolle au niveau pres +c +c================================================================ +c +c arguments : +c ----------- + + INTEGER ilon, ilev, klevSTD + logical lnew + + REAL pgcm(ilon,ilev) + REAL Qgcm(ilon,ilev) + real pres(klevSTD) + REAL Qpres(ilon, klevSTD) + +c local : +c ------- + +cym INTEGER lt(klon), lb(klon) +cym REAL ptop, pbot, aist(klon), aisb(klon) + +cym save lt,lb,ptop,pbot,aist,aisb + INTEGER,ALLOCATABLE,SAVE,DIMENSION(:,:) :: lt,lb + REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: aist,aisb +c$OMP THREADPRIVATE(lt,lb,aist,aisb) + REAL,SAVE :: ptop, pbot +c$OMP THREADPRIVATE(ptop, pbot) + LOGICAL,SAVE :: first = .true. + INTEGER :: nlev +c$OMP THREADPRIVATE(first) + INTEGER i, k +c + REAL missing_val +c + missing_val=nf90_fill_real +c + if (first) then + allocate(lt(klon,klevSTD),lb(klon,klevSTD)) + allocate(aist(klon,klevSTD),aisb(klon, klevSTD)) + first=.false. + endif + +c===================================================================== + if (lnew) then +c on reinitialise les reindicages et les poids +c===================================================================== + + +c Chercher les 2 couches les plus proches du niveau a obtenir +c +c Eventuellement, faire l'extrapolation a partir des deux couches +c les plus basses ou les deux couches les plus hautes: +c +c + DO nlev = 1, klevSTD + DO i = 1, klon + IF ( ABS(pres(nlev)-pgcm(i,ilev) ) .LT. + & ABS(pres(nlev)-pgcm(i,1)) ) THEN + lt(i,nlev) = ilev ! 2 + lb(i,nlev) = ilev-1 ! 1 + ELSE + lt(i,nlev) = 2 + lb(i,nlev) = 1 + ENDIF + ENDDO + DO k = 1, ilev-1 + DO i = 1, klon + pbot = pgcm(i,k) + ptop = pgcm(i,k+1) + IF (ptop.LE.pres(nlev) .AND. pbot.GE.pres(nlev)) THEN + lt(i,nlev) = k+1 + lb(i,nlev) = k + ENDIF + ENDDO + ENDDO + +c Interpolation lineaire: + DO i = 1, klon +c interpolation en logarithme de pression: +c +c ... Modif . P. Le Van ( 20/01/98) .... +c Modif Frederic Hourdin (3/01/02) + + aist(i,nlev) = LOG( pgcm(i,lb(i,nlev))/ pres(nlev) ) + & / LOG( pgcm(i,lb(i,nlev))/ pgcm(i,lt(i,nlev)) ) + aisb(i,nlev) = LOG( pres(nlev) / pgcm(i,lt(i,nlev)) ) + & / LOG( pgcm(i,lb(i,nlev))/ pgcm(i,lt(i,nlev))) + ENDDO + ENDDO + + ENDIF ! lnew + +c====================================================================== +c inteprollation +c ET je mets les vents a zero quand je rencontre une montagne +c====================================================================== + + DO nlev = 1, klevSTD + DO i=1,klon + IF (pgcm(i,1).LT.pres(nlev)) THEN + Qpres(i,nlev) = missing_val + ELSE + Qpres(i,nlev) = + & Qgcm(i,lb(i,nlev))*aisb(i,nlev) + + & Qgcm(i,lt(i,nlev))*aist(i,nlev) + ENDIF + ENDDO + ENDDO + +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/print_debug_phys.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/print_debug_phys.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/print_debug_phys.F90 (revision 1280) @@ -0,0 +1,20 @@ +SUBROUTINE print_debug_phys (i,debug_lev,text) + +use dimphy +use phys_local_var_mod +use phys_state_var_mod +IMPLICIT NONE +integer i,debug_lev +CHARACTER*(*) text + + +integer k + +print*,'PLANTAGE POUR LE POINT i=',i,text +print*,'l u, v, T, q, ql' +DO k = 1, klev + write(*,'(i3,2f8.4,3f14.4,2e14.2)') k,rlon(i),rlat(i),u_seri(i,k),v_seri(i,k),t_seri(i,k),q_seri(i,k),ql_seri(i,k) +ENDDO + +RETURN +END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/printflag.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/printflag.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/printflag.F (revision 1280) @@ -0,0 +1,183 @@ +! +! $Header$ +! + SUBROUTINE printflag( tabcntr0, radpas, + , ok_journe,ok_instan,ok_region ) +c + +c +c Auteur : P. Le Van + + IMPLICIT NONE + + REAL tabcntr0( 100 ) + LOGICAL cycle_diurn0,soil_model0,new_oliq0,ok_orodr0 + LOGICAL ok_orolf0,ok_limitvr0 + LOGICAL ok_journe,ok_instan,ok_region + INTEGER radpas , radpas0 +c +#include "clesphys.h" +c +c + PRINT 100 + PRINT *,' ******************************************************* + ,************' + PRINT *,' ******** Choix des principales cles de la physique + , *********' + PRINT *,' ******************************************************* + ,************' + PRINT 100 + PRINT 10, cycle_diurne, soil_model + PRINT 100 + + IF ( iflag_con.EQ. 1 ) THEN + PRINT *,' ***** Shema convection LMD + , ******' + ELSE IF ( iflag_con.EQ. 2 ) THEN + PRINT *,' ***** Shema convection Tiedtke + , ******' + ELSE IF ( iflag_con.GE. 3 ) THEN + PRINT *,' ***** Shema convection Emanuel + , ******' + ENDIF + PRINT 100 + + PRINT 11, new_oliq, ok_orodr, ok_orolf + PRINT 100 + + PRINT 7, ok_limitvrai + PRINT 100 + + PRINT 12, nbapp_rad + PRINT 100 + + PRINT 8, radpas + PRINT 100 + + PRINT 4,ok_journe,ok_instan,ok_region + PRINT 100 + PRINT 100 +c +c + cycle_diurn0 = .FALSE. + soil_model0 = .FALSE. + new_oliq0 = .FALSE. + ok_orodr0 = .FALSE. + ok_orolf0 = .FALSE. + ok_limitvr0 = .FALSE. + + IF( tabcntr0( 7 ).EQ. 1. ) cycle_diurn0 = .TRUE. + IF( tabcntr0( 8 ).EQ. 1. ) soil_model0 = .TRUE. + IF( tabcntr0( 9 ).EQ. 1. ) new_oliq0 = .TRUE. + IF( tabcntr0(10 ).EQ. 1. ) ok_orodr0 = .TRUE. + IF( tabcntr0(11 ).EQ. 1. ) ok_orolf0 = .TRUE. + IF( tabcntr0(12 ).EQ. 1. ) ok_limitvr0 = .TRUE. + + PRINT *,' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + ,$$$$$$$$$$$$$' + PRINT 100 +c + IF( INT( tabcntr0( 5 ) ) .NE. iflag_con ) THEN + PRINT 20, INT(tabcntr0(5)), iflag_con + PRINT 100 + ENDIF + + IF( INT( tabcntr0( 6 ) ) .NE. nbapp_rad ) THEN + PRINT 21, INT(tabcntr0(6)), nbapp_rad + radpas0 = NINT( 86400./tabcntr0(1)/INT( tabcntr0(6) ) ) + PRINT 100 + PRINT 22, radpas0, radpas + PRINT 100 + ENDIF + + IF( cycle_diurn0.AND..NOT.cycle_diurne.OR..NOT.cycle_diurn0.AND. + , cycle_diurne ) THEN + PRINT 13, cycle_diurn0, cycle_diurne + PRINT 100 + ENDIF + + IF( soil_model0.AND..NOT.soil_model.OR..NOT.soil_model0.AND. + , soil_model ) THEN + PRINT 14, soil_model0, soil_model + PRINT 100 + ENDIF + + IF( new_oliq0.AND..NOT.new_oliq.OR..NOT.new_oliq0.AND. + , new_oliq ) THEN + PRINT 16, new_oliq0, new_oliq + PRINT 100 + ENDIF + + IF( ok_orodr0.AND..NOT.ok_orodr.OR..NOT.ok_orodr0.AND. + , ok_orodr ) THEN + PRINT 15, ok_orodr0, ok_orodr + PRINT 100 + ENDIF + + IF( ok_orolf0.AND..NOT.ok_orolf.OR..NOT.ok_orolf0.AND. + , ok_orolf ) THEN + PRINT 17, ok_orolf0, ok_orolf + PRINT 100 + ENDIF + + IF( ok_limitvr0.AND..NOT.ok_limitvrai.OR..NOT.ok_limitvr0. + , AND.ok_limitvrai ) THEN + PRINT 18, ok_limitvr0, ok_limitvrai + PRINT 100 + ENDIF + + PRINT 100 + PRINT *,' ******************************************************* + ,************' + PRINT 100 + + 4 FORMAT(2x,5("*"),' ok_journe= ',l3,3x,',ok_instan = ', + , l3,3x,',ok_region = ',l3,3x,5("*") ) + + 7 FORMAT(2x,5("*"),15x,' ok_limitvrai = ',l3,16x,5("*") ) + + 8 FORMAT(2x,'***** radpas = ' , + , i4,6x,' *****') + + 10 FORMAT(2x,5("*"),' Cycle_diurne = ',l3,4x,', Soil_model = ', + , l3,12x,6("*") ) + + + 11 FORMAT(2x,5("*"),' new_oliq = ',l3,3x,', Ok_orodr = ', + , l3,3x,', Ok_orolf = ',l3,3x,5("*") ) + + + 12 FORMAT(2x,'***** Nb d appels /jour des routines de rayonn. = ' , + , i4,6x,' *****') + + 13 FORMAT(2x,'$$$$$$$$ Attention !! cycle_diurne different sur', + , /1x,10x,' startphy = ',l3,2x,' et run.def = ',l3) + + 14 FORMAT(2x,'$$$$$$$$ Attention !! soil_model different sur', + , /1x,10x,' startphy = ',l3,2x,' et run.def = ',l3) + + 15 FORMAT(2x,'$$$$$$$$ Attention !! ok_orodr different sur', + , /1x,10x,' startphy = ',l3,2x,' et run.def = ',l3) + + 16 FORMAT(2x,'$$$$$$$$ Attention !! new_oliq different sur', + , /1x,10x,' startphy = ',l3,2x,' et run.def = ',l3) + + 17 FORMAT(2x,'$$$$$$$$ Attention !! ok_orolf different sur', + , /1x,10x,' startphy = ',l3,2x,' et run.def = ',l3) + + 18 FORMAT(2x,'$$$$$$$$ Attention !! ok_limitvrai different sur', + , /1x,10x,' startphy = ',l3,2x,' et run.def = ',l3) + + 20 FORMAT(/2x,'$$$$$$$$ Attention !! iflag_con different sur', + , /1x,10x,' startphy = ',i3,2x,' et run.def = ',i3 ) + + 21 FORMAT(2x,'$$$$$$$$ Attention !! nbapp_rad different sur', + , /1x,10x,' startphy = ',i3,2x,' et run.def = ',i3 ) + + 22 FORMAT(2x,'$$$$$$$$ Attention !! radpas different sur', + , /1x,10x,' startphy = ',i3,2x,' et run.def = ',i3 ) + + 100 FORMAT(/) + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.160.98.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.160.98.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.160.98.h (revision 1280) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=78,kflev=klev) ! 78*199 Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.192.143.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.192.143.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.192.143.h (revision 1280) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=10,kflev=klev) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.32.24.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.32.24.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.32.24.h (revision 1280) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=klon,kflev=klev) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.48.32.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.48.32.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.48.32.h (revision 1280) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=149,kflev=klev) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.72.46.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.72.46.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.72.46.h (revision 1280) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=1621,kflev=klev) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.96.72.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.96.72.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.96.72.h (revision 1280) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=487,kflev=klev) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.defaut.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.defaut.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.defaut.h (revision 1280) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=klon,kflev=klev) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddim.h (revision 1280) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=149,kflev=klev) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddimlw.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddimlw.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/raddimlw.h (revision 1280) @@ -0,0 +1,11 @@ +! +! $Header$ +! + INTEGER NUA + PARAMETER (NUA=24) + INTEGER NTRA + PARAMETER (NTRA=15) + INTEGER Ninter + PARAMETER (Ninter=6) + INTEGER NG1, NG1P1 + PARAMETER (NG1=2, NG1P1=NG1+1) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radepsi.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radepsi.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radepsi.h (revision 1280) @@ -0,0 +1,16 @@ +! +! $Header$ +! + REAL(KIND=8) ZEELOG, ZEPSC, ZEPSCO, ZEPSCQ, ZEPSCT, ZEPSCW + REAL(KIND=8) ZEPSEC, ZEPSCR + PARAMETER (ZEELOG = 1.E-07) !1.e-10 (not good for 32-bit machines) + PARAMETER (ZEPSC = 1.E-20) + PARAMETER (ZEPSCO = 1.E-10) + PARAMETER (ZEPSCQ = 1.E-10) + PARAMETER (ZEPSCT = 1.E-20) + PARAMETER (ZEPSCW = 1.E-20) + PARAMETER (ZEPSEC = 1.0E-12) + PARAMETER (ZEPSCR = 1.0E-10) +c + REAL(KIND=8) REPSCT + PARAMETER (REPSCT=1.0E-10) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radiation_AR4.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radiation_AR4.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radiation_AR4.F (revision 1280) @@ -0,0 +1,5999 @@ +cIM ctes ds clesphys.h SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC, + SUBROUTINE SW_LMDAR4(PSCT, PRMU0, PFRAC, + S PPMB, PDP, + S PPSOL, PALBD, PALBP, + S PTAVE, PWV, PQS, POZON, PAER, + S PCLDSW, PTAU, POMEGA, PCG, + S PHEAT, PHEAT0, + S PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0, + S ZFSUP,ZFSDN,ZFSUP0,ZFSDN0, + S tauae, pizae, cgae, + s PTAUA, POMEGAA, + S PTOPSWAD,PSOLSWAD,PTOPSWAI,PSOLSWAI, + J ok_ade, ok_aie ) + USE dimphy + IMPLICIT none + +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "YOMCST.h" +C +C ------------------------------------------------------------------ +C +C PURPOSE. +C -------- +C +C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO +C SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980). +C +C METHOD. +C ------- +C +C 1. COMPUTES ABSORBER AMOUNTS (SWU) +C 2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL (SW1S) +C 3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL (SW2S) +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT +C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C 95-01-01 J.-J. MORCRETTE Direct/Diffuse Albedo +c 03-11-27 J. QUAAS Introduce aerosol forcings (based on BOUCHER) +C ------------------------------------------------------------------ +C +C* ARGUMENTS: +C + REAL(KIND=8) PSCT ! constante solaire (valeur conseillee: 1370) +cIM ctes ds clesphys.h REAL(KIND=8) RCO2 ! concentration CO2 (IPCC: 353.E-06*44.011/28.97) +#include "clesphys.h" +C + REAL(KIND=8) PPSOL(KDLON) ! SURFACE PRESSURE (PA) + REAL(KIND=8) PDP(KDLON,KFLEV) ! LAYER THICKNESS (PA) + REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB) +C + REAL(KIND=8) PRMU0(KDLON) ! COSINE OF ZENITHAL ANGLE + REAL(KIND=8) PFRAC(KDLON) ! fraction de la journee +C + REAL(KIND=8) PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K) + REAL(KIND=8) PWV(KDLON,KFLEV) ! SPECIFIC HUMIDITY (KG/KG) + REAL(KIND=8) PQS(KDLON,KFLEV) ! SATURATED WATER VAPOUR (KG/KG) + REAL(KIND=8) POZON(KDLON,KFLEV) ! OZONE CONCENTRATION (KG/KG) + REAL(KIND=8) PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS +C + REAL(KIND=8) PALBD(KDLON,2) ! albedo du sol (lumiere diffuse) + REAL(KIND=8) PALBP(KDLON,2) ! albedo du sol (lumiere parallele) +C + REAL(KIND=8) PCLDSW(KDLON,KFLEV) ! CLOUD FRACTION + REAL(KIND=8) PTAU(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS + REAL(KIND=8) PCG(KDLON,2,KFLEV) ! ASYMETRY FACTOR + REAL(KIND=8) POMEGA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO +C + REAL(KIND=8) PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY) + REAL(KIND=8) PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky + REAL(KIND=8) PALBPLA(KDLON) ! PLANETARY ALBEDO + REAL(KIND=8) PTOPSW(KDLON) ! SHORTWAVE FLUX AT T.O.A. + REAL(KIND=8) PSOLSW(KDLON) ! SHORTWAVE FLUX AT SURFACE + REAL(KIND=8) PTOPSW0(KDLON) ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY) + REAL(KIND=8) PSOLSW0(KDLON) ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY) +C +C* LOCAL VARIABLES: +C + real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2 + + REAL(KIND=8) ZOZ(KDLON,KFLEV) +! column-density of ozone in layer, in kilo-Dobsons + + REAL(KIND=8) ZAKI(KDLON,2) + REAL(KIND=8) ZCLD(KDLON,KFLEV) + REAL(KIND=8) ZCLEAR(KDLON) + REAL(KIND=8) ZDSIG(KDLON,KFLEV) + REAL(KIND=8) ZFACT(KDLON) + REAL(KIND=8) ZFD(KDLON,KFLEV+1) + REAL(KIND=8) ZFDOWN(KDLON,KFLEV+1) + REAL(KIND=8) ZFU(KDLON,KFLEV+1) + REAL(KIND=8) ZFUP(KDLON,KFLEV+1) + REAL(KIND=8) ZRMU(KDLON) + REAL(KIND=8) ZSEC(KDLON) + REAL(KIND=8) ZUD(KDLON,5,KFLEV+1) + REAL(KIND=8) ZCLDSW0(KDLON,KFLEV) +c + REAL(KIND=8) ZFSUP(KDLON,KFLEV+1) + REAL(KIND=8) ZFSDN(KDLON,KFLEV+1) + REAL(KIND=8) ZFSUP0(KDLON,KFLEV+1) + REAL(KIND=8) ZFSDN0(KDLON,KFLEV+1) +C + INTEGER inu, jl, jk, i, k, kpl1 +c + INTEGER swpas ! Every swpas steps, sw is calculated + PARAMETER(swpas=1) +c + INTEGER itapsw + LOGICAL appel1er + DATA itapsw /0/ + DATA appel1er /.TRUE./ + SAVE itapsw,appel1er +c$OMP THREADPRIVATE(appel1er) +c$OMP THREADPRIVATE(itapsw) +cjq-Introduced for aerosol forcings + real(kind=8) flag_aer + logical ok_ade, ok_aie ! use aerosol forcings or not? + real(kind=8) tauae(kdlon,kflev,2) ! aerosol optical properties + real(kind=8) pizae(kdlon,kflev,2) ! (see aeropt.F) + real(kind=8) cgae(kdlon,kflev,2) ! -"- + REAL(KIND=8) PTAUA(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS (pre-industrial value) + REAL(KIND=8) POMEGAA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO + REAL(KIND=8) PTOPSWAD(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR) + REAL(KIND=8) PSOLSWAD(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR) + REAL(KIND=8) PTOPSWAI(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND) + REAL(KIND=8) PSOLSWAI(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND) +cjq - Fluxes including aerosol effects + REAL(KIND=8),allocatable,save :: ZFSUPAD(:,:) +c$OMP THREADPRIVATE(ZFSUPAD) + REAL(KIND=8),allocatable,save :: ZFSDNAD(:,:) +c$OMP THREADPRIVATE(ZFSDNAD) + REAL(KIND=8),allocatable,save :: ZFSUPAI(:,:) +c$OMP THREADPRIVATE(ZFSUPAI) + REAL(KIND=8),allocatable,save :: ZFSDNAI(:,:) +c$OMP THREADPRIVATE(ZFSDNAI) + logical initialized +cym SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes +!rv + save flag_aer +c$OMP THREADPRIVATE(flag_aer) + data initialized/.false./ + save initialized +c$OMP THREADPRIVATE(initialized) +cjq-end + REAL tmp_ + if(.not.initialized) then + flag_aer=0. + initialized=.TRUE. + allocate(ZFSUPAD(KDLON,KFLEV+1)) + allocate(ZFSDNAD(KDLON,KFLEV+1)) + allocate(ZFSUPAI(KDLON,KFLEV+1)) + allocate(ZFSDNAI(KDLON,KFLEV+1)) + DO JK = 1 , KDLON*(KFLEV+1) + ZFSUPAD(JK,1) = 0.0 ! ZFSUPAD(:,:)=0. + ZFSDNAD(JK,1) = 0.0 ! ZFSDNAD(:,:)=0. + ZFSUPAI(JK,1) = 0.0 ! ZFSUPAI(:,:)=0. + ZFSDNAI(JK,1) = 0.0 ! ZFSDNAI(:,:)=0. + END DO + endif +!rv + +c + IF (appel1er) THEN + PRINT*, 'SW calling frequency : ', swpas + PRINT*, " In general, it should be 1" + appel1er = .FALSE. + ENDIF +C ------------------------------------------------------------------ + IF (MOD(itapsw,swpas).EQ.0) THEN +c + tmp_ = 1./( dobson_u * 1e3 * RG) +!cdir collapse + DO JK = 1 , KFLEV + DO JL = 1, KDLON + ZCLDSW0(JL,JK) = 0.0 + ZOZ(JL,JK) = POZON(JL,JK)*tmp_*PDP(JL,JK) + ENDDO + ENDDO +C +C +c clear-sky: +cIM ctes ds clesphys.h CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL, + CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL, + S PRMU0,PFRAC,PTAVE,PWV, + S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, + S PAER, flag_aer, tauae, pizae, cgae, + S PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0, + S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, + S ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, + S PAER, flag_aer, tauae, pizae, cgae, + S ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0, + S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, + S PWV, PQS, + S ZFDOWN, ZFUP) + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP0(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN0(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + + flag_aer=0.0 + CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL, + S PRMU0,PFRAC,PTAVE,PWV, + S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, + S PAER, flag_aer, tauae, pizae, cgae, + S PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, + S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, + S ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, + S PAER, flag_aer, tauae, pizae, cgae, + S ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, + S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, + S PWV, PQS, + S ZFDOWN, ZFUP) + +c cloudy-sky: + + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + +c + IF (ok_ade) THEN +c +c cloudy-sky + aerosol dir OB + flag_aer=1.0 + CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL, + S PRMU0,PFRAC,PTAVE,PWV, + S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, + S PAER, flag_aer, tauae, pizae, cgae, + S PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, + S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, + S ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, + S PAER, flag_aer, tauae, pizae, cgae, + S ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, + S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, + S PWV, PQS, + S ZFDOWN, ZFUP) + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUPAD(JL,JK) = ZFSUP(JL,JK) + ZFSDNAD(JL,JK) = ZFSDN(JL,JK) + ZFSUP(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + + ENDIF ! ok_ade + + IF (ok_aie) THEN + +cjq cloudy-sky + aerosol direct + aerosol indirect + flag_aer=1.0 + CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL, + S PRMU0,PFRAC,PTAVE,PWV, + S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, + S PAER, flag_aer, tauae, pizae, cgae, + S PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, + S ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD, + S ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, + S PAER, flag_aer, tauae, pizae, cgae, + S ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, + S ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD, + S PWV, PQS, + S ZFDOWN, ZFUP) + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUPAI(JL,JK) = ZFSUP(JL,JK) + ZFSDNAI(JL,JK) = ZFSDN(JL,JK) + ZFSUP(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + ENDIF ! ok_aie +cjq -end + + itapsw = 0 + ENDIF + itapsw = itapsw + 1 +C + DO k = 1, KFLEV + kpl1 = k+1 + DO i = 1, KDLON + PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k)) + . -(ZFSDN(i,k)-ZFSDN(i,kpl1)) + PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k) + PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k)) + . -(ZFSDN0(i,k)-ZFSDN0(i,kpl1)) + PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k) + ENDDO + ENDDO + DO i = 1, KDLON + PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20) +c + PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1) + PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1) +c + PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1) + PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1) +c-OB + PSOLSWAD(i) = ZFSDNAD(i,1) - ZFSUPAD(i,1) + PTOPSWAD(i) = ZFSDNAD(i,KFLEV+1) - ZFSUPAD(i,KFLEV+1) +c + PSOLSWAI(i) = ZFSDNAI(i,1) - ZFSUPAI(i,1) + PTOPSWAI(i) = ZFSDNAI(i,KFLEV+1) - ZFSUPAI(i,KFLEV+1) +c-fin + ENDDO +C + RETURN + END +c +cIM ctes ds clesphys.h SUBROUTINE SWU (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC, + SUBROUTINE SWU_LMDAR4 (PSCT,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC, + S PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT, + S PRMU,PSEC,PUD) + USE dimphy + USE radiation_AR4_param, only : + S ZPDH2O,ZPDUMG,ZPRH2O,ZPRUMG,RTDH2O,RTDUMG,RTH2O,RTUMG + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "radepsi.h" +#include "radopt.h" +#include "YOMCST.h" +C +C* ARGUMENTS: +C + REAL(KIND=8) PSCT +cIM ctes ds clesphys.h REAL(KIND=8) RCO2 +#include "clesphys.h" + REAL(KIND=8) PCLDSW(KDLON,KFLEV) + REAL(KIND=8) PPMB(KDLON,KFLEV+1) + REAL(KIND=8) PPSOL(KDLON) + REAL(KIND=8) PRMU0(KDLON) + REAL(KIND=8) PFRAC(KDLON) + REAL(KIND=8) PTAVE(KDLON,KFLEV) + REAL(KIND=8) PWV(KDLON,KFLEV) +C + REAL(KIND=8) PAKI(KDLON,2) + REAL(KIND=8) PCLD(KDLON,KFLEV) + REAL(KIND=8) PCLEAR(KDLON) + REAL(KIND=8) PDSIG(KDLON,KFLEV) + REAL(KIND=8) PFACT(KDLON) + REAL(KIND=8) PRMU(KDLON) + REAL(KIND=8) PSEC(KDLON) + REAL(KIND=8) PUD(KDLON,5,KFLEV+1) +C +C* LOCAL VARIABLES: +C + INTEGER IIND(2) + REAL(KIND=8) ZC1J(KDLON,KFLEV+1) + REAL(KIND=8) ZCLEAR(KDLON) + REAL(KIND=8) ZCLOUD(KDLON) + REAL(KIND=8) ZN175(KDLON) + REAL(KIND=8) ZN190(KDLON) + REAL(KIND=8) ZO175(KDLON) + REAL(KIND=8) ZO190(KDLON) + REAL(KIND=8) ZSIGN(KDLON) + REAL(KIND=8) ZR(KDLON,2) + REAL(KIND=8) ZSIGO(KDLON) + REAL(KIND=8) ZUD(KDLON,2) + REAL(KIND=8) ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW + INTEGER jl, jk, jkp1, jkl, jklp1, ja +C +C ------------------------------------------------------------------ +C +C* 1. COMPUTES AMOUNTS OF ABSORBERS +C ----------------------------- +C + 100 CONTINUE +C + IIND(1)=1 + IIND(2)=2 +C +C +C* 1.1 INITIALIZES QUANTITIES +C ---------------------- +C + 110 CONTINUE +C + DO 111 JL = 1, KDLON + PUD(JL,1,KFLEV+1)=0. + PUD(JL,2,KFLEV+1)=0. + PUD(JL,3,KFLEV+1)=0. + PUD(JL,4,KFLEV+1)=0. + PUD(JL,5,KFLEV+1)=0. + PFACT(JL)= PRMU0(JL) * PFRAC(JL) * PSCT + PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35. + PSEC(JL)=1./PRMU(JL) + ZC1J(JL,KFLEV+1)=0. + 111 CONTINUE +C +C* 1.3 AMOUNTS OF ABSORBERS +C -------------------- +C + 130 CONTINUE +C + DO 131 JL= 1, KDLON + ZUD(JL,1) = 0. + ZUD(JL,2) = 0. + ZO175(JL) = PPSOL(JL)** (ZPDUMG+1.) + ZO190(JL) = PPSOL(JL)** (ZPDH2O+1.) + ZSIGO(JL) = PPSOL(JL) + ZCLEAR(JL)=1. + ZCLOUD(JL)=0. + 131 CONTINUE +C + DO 133 JK = 1 , KFLEV + JKP1 = JK + 1 + JKL = KFLEV+1 - JK + JKLP1 = JKL+1 + DO 132 JL = 1, KDLON + ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O + ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG + ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ ) + ZSIGN(JL) = 100. * PPMB(JL,JKP1) + PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL) + ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.) + ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.) + ZDSCO2 = ZO175(JL) - ZN175(JL) + ZDSH2O = ZO190(JL) - ZN190(JL) + PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O) + . * ZDSH2O * ZWH2O * ZRTH + PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG) + . * ZDSCO2 * RCO2 * ZRTU + ZFPPW=1.6078*ZWH2O/(1.+0.608*ZWH2O) + PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW + PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW) + ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK) + ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK) + ZSIGO(JL) = ZSIGN(JL) + ZO175(JL) = ZN175(JL) + ZO190(JL) = ZN190(JL) +C + IF (NOVLP.EQ.1) THEN + ZCLEAR(JL)=ZCLEAR(JL) + S *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL))) + S /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC)) + ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL) + ZCLOUD(JL) = PCLDSW(JL,JKL) + ELSE IF (NOVLP.EQ.2) THEN + ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL)) + ZC1J(JL,JKL) = ZCLOUD(JL) + ELSE IF (NOVLP.EQ.3) THEN + ZCLEAR(JL) = ZCLEAR(JL)*(1.-PCLDSW(JL,JKL)) + ZCLOUD(JL) = 1.0 - ZCLEAR(JL) + ZC1J(JL,JKL) = ZCLOUD(JL) + END IF + 132 CONTINUE + 133 CONTINUE + DO 134 JL=1, KDLON + PCLEAR(JL)=1.-ZC1J(JL,1) + 134 CONTINUE + DO 136 JK=1,KFLEV + DO 135 JL=1, KDLON + IF (PCLEAR(JL).LT.1.) THEN + PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL)) + ELSE + PCLD(JL,JK)=0. + END IF + 135 CONTINUE + 136 CONTINUE +C +C +C* 1.4 COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS +C ----------------------------------------------- +C + 140 CONTINUE +C + DO 142 JA = 1,2 + DO 141 JL = 1, KDLON + ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL) + 141 CONTINUE + 142 CONTINUE +C + CALL SWTT1_LMDAR4(2, 2, IIND, ZUD, ZR) +C + DO 144 JA = 1,2 + DO 143 JL = 1, KDLON + PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA) + 143 CONTINUE + 144 CONTINUE +C +C +C ------------------------------------------------------------------ +C + RETURN + END + SUBROUTINE SW1S_LMDAR4 ( KNU + S , PAER , flag_aer, tauae, pizae, cgae + S , PALBD , PALBP, PCG , PCLD , PCLEAR, PCLDSW + S , PDSIG , POMEGA, POZ , PRMU , PSEC , PTAU , PUD + S , PFD , PFU) + USE dimphy + USE radiation_AR4_param, only : RSUN, RRAY + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +C +C ------------------------------------------------------------------ +C PURPOSE. +C -------- +C +C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO +C SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980). +C +C METHOD. +C ------- +C +C 1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO +C CONTINUUM SCATTERING +C 2. MULTIPLY BY OZONE TRANSMISSION FUNCTION +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT +C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO +C ------------------------------------------------------------------ +C +C* ARGUMENTS: +C + INTEGER KNU +c-OB + real(kind=8) flag_aer + real(kind=8) tauae(kdlon,kflev,2) + real(kind=8) pizae(kdlon,kflev,2) + real(kind=8) cgae(kdlon,kflev,2) + REAL(KIND=8) PAER(KDLON,KFLEV,5) + REAL(KIND=8) PALBD(KDLON,2) + REAL(KIND=8) PALBP(KDLON,2) + REAL(KIND=8) PCG(KDLON,2,KFLEV) + REAL(KIND=8) PCLD(KDLON,KFLEV) + REAL(KIND=8) PCLDSW(KDLON,KFLEV) + REAL(KIND=8) PCLEAR(KDLON) + REAL(KIND=8) PDSIG(KDLON,KFLEV) + REAL(KIND=8) POMEGA(KDLON,2,KFLEV) + REAL(KIND=8) POZ(KDLON,KFLEV) + REAL(KIND=8) PRMU(KDLON) + REAL(KIND=8) PSEC(KDLON) + REAL(KIND=8) PTAU(KDLON,2,KFLEV) + REAL(KIND=8) PUD(KDLON,5,KFLEV+1) +C + REAL(KIND=8) PFD(KDLON,KFLEV+1) + REAL(KIND=8) PFU(KDLON,KFLEV+1) +C +C* LOCAL VARIABLES: +C + INTEGER IIND(4) +C + REAL(KIND=8) ZCGAZ(KDLON,KFLEV) + REAL(KIND=8) ZDIFF(KDLON) + REAL(KIND=8) ZDIRF(KDLON) + REAL(KIND=8) ZPIZAZ(KDLON,KFLEV) + REAL(KIND=8) ZRAYL(KDLON) + REAL(KIND=8) ZRAY1(KDLON,KFLEV+1) + REAL(KIND=8) ZRAY2(KDLON,KFLEV+1) + REAL(KIND=8) ZREFZ(KDLON,2,KFLEV+1) + REAL(KIND=8) ZRJ(KDLON,6,KFLEV+1) + REAL(KIND=8) ZRJ0(KDLON,6,KFLEV+1) + REAL(KIND=8) ZRK(KDLON,6,KFLEV+1) + REAL(KIND=8) ZRK0(KDLON,6,KFLEV+1) + REAL(KIND=8) ZRMUE(KDLON,KFLEV+1) + REAL(KIND=8) ZRMU0(KDLON,KFLEV+1) + REAL(KIND=8) ZR(KDLON,4) + REAL(KIND=8) ZTAUAZ(KDLON,KFLEV) + REAL(KIND=8) ZTRA1(KDLON,KFLEV+1) + REAL(KIND=8) ZTRA2(KDLON,KFLEV+1) + REAL(KIND=8) ZW(KDLON,4) +C + INTEGER jl, jk, k, jaj, ikm1, ikl + +C ------------------------------------------------------------------ +C +C* 1. FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON) +C ----------------------- ------------------ +C + 100 CONTINUE +C +C +C* 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING +C ----------------------------------------- +C + 110 CONTINUE +C + DO 111 JL = 1, KDLON + ZRAYL(JL) = RRAY(KNU,1) + PRMU(JL) * (RRAY(KNU,2) + PRMU(JL) + S * (RRAY(KNU,3) + PRMU(JL) * (RRAY(KNU,4) + PRMU(JL) + S * (RRAY(KNU,5) + PRMU(JL) * RRAY(KNU,6) )))) + 111 CONTINUE +C +C +C ------------------------------------------------------------------ +C +C* 2. CONTINUUM SCATTERING CALCULATIONS +C --------------------------------- +C + 200 CONTINUE +C +C* 2.1 CLEAR-SKY FRACTION OF THE COLUMN +C -------------------------------- +C + 210 CONTINUE +C + CALL SWCLR_LMDAR4 ( KNU + S , PAER , flag_aer, tauae, pizae, cgae + S , PALBP , PDSIG , ZRAYL, PSEC + S , ZCGAZ , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0 + S , ZRK0 , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2) +C +C +C* 2.2 CLOUDY FRACTION OF THE COLUMN +C ----------------------------- +C + 220 CONTINUE +C + CALL SWR_LMDAR4 ( KNU + S , PALBD ,PCG ,PCLD ,PDSIG ,POMEGA,ZRAYL + S , PSEC ,PTAU + S , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ ,ZRK,ZRMUE + S , ZTAUAZ,ZTRA1 ,ZTRA2) +C +C +C ------------------------------------------------------------------ +C +C* 3. OZONE ABSORPTION +C ---------------- +C + 300 CONTINUE +C + IIND(1)=1 + IIND(2)=3 + IIND(3)=1 + IIND(4)=3 +C +C +C* 3.1 DOWNWARD FLUXES +C --------------- +C + 310 CONTINUE +C + JAJ = 2 +C + DO 311 JL = 1, KDLON + ZW(JL,1)=0. + ZW(JL,2)=0. + ZW(JL,3)=0. + ZW(JL,4)=0. + PFD(JL,KFLEV+1)=((1.-PCLEAR(JL))*ZRJ(JL,JAJ,KFLEV+1) + S + PCLEAR(JL) *ZRJ0(JL,JAJ,KFLEV+1)) * RSUN(KNU) + 311 CONTINUE + DO 314 JK = 1 , KFLEV + IKL = KFLEV+1-JK + DO 312 JL = 1, KDLON + ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKL)/ZRMUE(JL,IKL) + ZW(JL,2)=ZW(JL,2)+POZ(JL, IKL)/ZRMUE(JL,IKL) + ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKL)/ZRMU0(JL,IKL) + ZW(JL,4)=ZW(JL,4)+POZ(JL, IKL)/ZRMU0(JL,IKL) + 312 CONTINUE +C + CALL SWTT1_LMDAR4(KNU, 4, IIND, ZW, ZR) +C + DO 313 JL = 1, KDLON + ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRJ(JL,JAJ,IKL) + ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRJ0(JL,JAJ,IKL) + PFD(JL,IKL) = ((1.-PCLEAR(JL)) * ZDIFF(JL) + S +PCLEAR(JL) * ZDIRF(JL)) * RSUN(KNU) + 313 CONTINUE + 314 CONTINUE +C +C +C* 3.2 UPWARD FLUXES +C ------------- +C + 320 CONTINUE +C + DO 325 JL = 1, KDLON + PFU(JL,1) = ((1.-PCLEAR(JL))*ZDIFF(JL)*PALBD(JL,KNU) + S + PCLEAR(JL) *ZDIRF(JL)*PALBP(JL,KNU)) + S * RSUN(KNU) + 325 CONTINUE +C + DO 328 JK = 2 , KFLEV+1 + IKM1=JK-1 + DO 326 JL = 1, KDLON + ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKM1)*1.66 + ZW(JL,2)=ZW(JL,2)+POZ(JL, IKM1)*1.66 + ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKM1)*1.66 + ZW(JL,4)=ZW(JL,4)+POZ(JL, IKM1)*1.66 + 326 CONTINUE +C + CALL SWTT1_LMDAR4(KNU, 4, IIND, ZW, ZR) +C + DO 327 JL = 1, KDLON + ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRK(JL,JAJ,JK) + ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRK0(JL,JAJ,JK) + PFU(JL,JK) = ((1.-PCLEAR(JL)) * ZDIFF(JL) + S +PCLEAR(JL) * ZDIRF(JL)) * RSUN(KNU) + 327 CONTINUE + 328 CONTINUE +C +C ------------------------------------------------------------------ +C + RETURN + END + SUBROUTINE SW2S_LMDAR4 ( KNU + S , PAER , flag_aer, tauae, pizae, cgae + S , PAKI, PALBD, PALBP, PCG , PCLD, PCLEAR, PCLDSW + S , PDSIG ,POMEGA,POZ , PRMU , PSEC , PTAU + S , PUD ,PWV , PQS + S , PFDOWN,PFUP ) + USE dimphy + USE radiation_AR4_param, only : RSUN, RRAY + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "radepsi.h" +C +C ------------------------------------------------------------------ +C PURPOSE. +C -------- +C +C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE +C SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980). +C +C METHOD. +C ------- +C +C 1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO +C CONTINUUM SCATTERING +C 2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR +C A GREY MOLECULAR ABSORPTION +C 3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS +C OF ABSORBERS +C 4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS +C 5. MULTIPLY BY OZONE TRANSMISSION FUNCTION +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT +C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO +C ------------------------------------------------------------------ +C* ARGUMENTS: +C + INTEGER KNU +c-OB + real(kind=8) flag_aer + real(kind=8) tauae(kdlon,kflev,2) + real(kind=8) pizae(kdlon,kflev,2) + real(kind=8) cgae(kdlon,kflev,2) + REAL(KIND=8) PAER(KDLON,KFLEV,5) + REAL(KIND=8) PAKI(KDLON,2) + REAL(KIND=8) PALBD(KDLON,2) + REAL(KIND=8) PALBP(KDLON,2) + REAL(KIND=8) PCG(KDLON,2,KFLEV) + REAL(KIND=8) PCLD(KDLON,KFLEV) + REAL(KIND=8) PCLDSW(KDLON,KFLEV) + REAL(KIND=8) PCLEAR(KDLON) + REAL(KIND=8) PDSIG(KDLON,KFLEV) + REAL(KIND=8) POMEGA(KDLON,2,KFLEV) + REAL(KIND=8) POZ(KDLON,KFLEV) + REAL(KIND=8) PQS(KDLON,KFLEV) + REAL(KIND=8) PRMU(KDLON) + REAL(KIND=8) PSEC(KDLON) + REAL(KIND=8) PTAU(KDLON,2,KFLEV) + REAL(KIND=8) PUD(KDLON,5,KFLEV+1) + REAL(KIND=8) PWV(KDLON,KFLEV) +C + REAL(KIND=8) PFDOWN(KDLON,KFLEV+1) + REAL(KIND=8) PFUP(KDLON,KFLEV+1) +C +C* LOCAL VARIABLES: +C + INTEGER IIND2(2), IIND3(3) + REAL(KIND=8) ZCGAZ(KDLON,KFLEV) + REAL(KIND=8) ZFD(KDLON,KFLEV+1) + REAL(KIND=8) ZFU(KDLON,KFLEV+1) + REAL(KIND=8) ZG(KDLON) + REAL(KIND=8) ZGG(KDLON) + REAL(KIND=8) ZPIZAZ(KDLON,KFLEV) + REAL(KIND=8) ZRAYL(KDLON) + REAL(KIND=8) ZRAY1(KDLON,KFLEV+1) + REAL(KIND=8) ZRAY2(KDLON,KFLEV+1) + REAL(KIND=8) ZREF(KDLON) + REAL(KIND=8) ZREFZ(KDLON,2,KFLEV+1) + REAL(KIND=8) ZRE1(KDLON) + REAL(KIND=8) ZRE2(KDLON) + REAL(KIND=8) ZRJ(KDLON,6,KFLEV+1) + REAL(KIND=8) ZRJ0(KDLON,6,KFLEV+1) + REAL(KIND=8) ZRK(KDLON,6,KFLEV+1) + REAL(KIND=8) ZRK0(KDLON,6,KFLEV+1) + REAL(KIND=8) ZRL(KDLON,8) + REAL(KIND=8) ZRMUE(KDLON,KFLEV+1) + REAL(KIND=8) ZRMU0(KDLON,KFLEV+1) + REAL(KIND=8) ZRMUZ(KDLON) + REAL(KIND=8) ZRNEB(KDLON) + REAL(KIND=8) ZRUEF(KDLON,8) + REAL(KIND=8) ZR1(KDLON) + REAL(KIND=8) ZR2(KDLON,2) + REAL(KIND=8) ZR3(KDLON,3) + REAL(KIND=8) ZR4(KDLON) + REAL(KIND=8) ZR21(KDLON) + REAL(KIND=8) ZR22(KDLON) + REAL(KIND=8) ZS(KDLON) + REAL(KIND=8) ZTAUAZ(KDLON,KFLEV) + REAL(KIND=8) ZTO1(KDLON) + REAL(KIND=8) ZTR(KDLON,2,KFLEV+1) + REAL(KIND=8) ZTRA1(KDLON,KFLEV+1) + REAL(KIND=8) ZTRA2(KDLON,KFLEV+1) + REAL(KIND=8) ZTR1(KDLON) + REAL(KIND=8) ZTR2(KDLON) + REAL(KIND=8) ZW(KDLON) + REAL(KIND=8) ZW1(KDLON) + REAL(KIND=8) ZW2(KDLON,2) + REAL(KIND=8) ZW3(KDLON,3) + REAL(KIND=8) ZW4(KDLON) + REAL(KIND=8) ZW5(KDLON) +C + INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1 + INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs + REAL(KIND=8) ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11 +C + +C +C ------------------------------------------------------------------ +C +C* 1. SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON) +C ------------------------------------------- +C + 100 CONTINUE +C +C +C* 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING +C ----------------------------------------- +C + 110 CONTINUE +C + DO 111 JL = 1, KDLON + ZRMUM1 = 1. - PRMU(JL) + ZRAYL(JL) = RRAY(KNU,1) + ZRMUM1 * (RRAY(KNU,2) + ZRMUM1 + S * (RRAY(KNU,3) + ZRMUM1 * (RRAY(KNU,4) + ZRMUM1 + S * (RRAY(KNU,5) + ZRMUM1 * RRAY(KNU,6) )))) + 111 CONTINUE +C +C +C ------------------------------------------------------------------ +C +C* 2. CONTINUUM SCATTERING CALCULATIONS +C --------------------------------- +C + 200 CONTINUE +C +C* 2.1 CLEAR-SKY FRACTION OF THE COLUMN +C -------------------------------- +C + 210 CONTINUE +C + CALL SWCLR_LMDAR4 ( KNU + S , PAER , flag_aer, tauae, pizae, cgae + S , PALBP , PDSIG , ZRAYL, PSEC + S , ZCGAZ , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0 + S , ZRK0 , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2) +C +C +C* 2.2 CLOUDY FRACTION OF THE COLUMN +C ----------------------------- +C + 220 CONTINUE +C + CALL SWR_LMDAR4 ( KNU + S , PALBD , PCG , PCLD , PDSIG, POMEGA, ZRAYL + S , PSEC , PTAU + S , ZCGAZ , ZPIZAZ, ZRAY1, ZRAY2, ZREFZ , ZRJ , ZRK, ZRMUE + S , ZTAUAZ, ZTRA1 , ZTRA2) +C +C +C ------------------------------------------------------------------ +C +C* 3. SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION +C ------------------------------------------------------ +C + 300 CONTINUE +C + JN = 2 +C + DO 361 JABS=1,2 +C +C +C* 3.1 SURFACE CONDITIONS +C ------------------ +C + 310 CONTINUE +C + DO 311 JL = 1, KDLON + ZREFZ(JL,2,1) = PALBD(JL,KNU) + ZREFZ(JL,1,1) = PALBD(JL,KNU) + 311 CONTINUE +C +C +C* 3.2 INTRODUCING CLOUD EFFECTS +C ------------------------- +C + 320 CONTINUE +C + DO 324 JK = 2 , KFLEV+1 + JKM1 = JK - 1 + IKL=KFLEV+1-JKM1 + DO 322 JL = 1, KDLON + ZRNEB(JL) = PCLD(JL,JKM1) + IF (JABS.EQ.1 .AND. ZRNEB(JL).GT.2.*ZEELOG) THEN + ZWH2O=MAX(PWV(JL,JKM1),ZEELOG) + ZCNEB=MAX(ZEELOG,MIN(ZRNEB(JL),1.-ZEELOG)) + ZBB=PUD(JL,JABS,JKM1)*PQS(JL,JKM1)/ZWH2O + ZAA=MAX((PUD(JL,JABS,JKM1)-ZCNEB*ZBB)/(1.-ZCNEB),ZEELOG) + ELSE + ZAA=PUD(JL,JABS,JKM1) + ZBB=ZAA + END IF + ZRKI = PAKI(JL,JABS) + ZS(JL) = EXP(-ZRKI * ZAA * 1.66) + ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK)) + ZTR1(JL) = 0. + ZRE1(JL) = 0. + ZTR2(JL) = 0. + ZRE2(JL) = 0. +C + ZW(JL)= POMEGA(JL,KNU,JKM1) + ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL) + S + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1) + S + ZBB * ZRKI + + ZR21(JL) = PTAU(JL,KNU,JKM1) + ZTAUAZ(JL,JKM1) + ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL) + ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1) + S + (1. - ZR22(JL)) * ZCGAZ(JL,JKM1) + ZW(JL) = ZR21(JL) / ZTO1(JL) + ZREF(JL) = ZREFZ(JL,1,JKM1) + ZRMUZ(JL) = ZRMUE(JL,JK) + 322 CONTINUE +C + CALL SWDE_LMDAR4(ZGG, ZREF, ZRMUZ, ZTO1, ZW, + S ZRE1, ZRE2, ZTR1, ZTR2) +C + DO 323 JL = 1, KDLON +C + ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1) + S + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1) + S * ZTRA2(JL,JKM1) ) * ZG(JL) * ZS(JL) + S + ZRNEB(JL) * ZRE1(JL) +C + ZTR(JL,2,JKM1)=ZRNEB(JL)*ZTR1(JL) + S + (ZTRA1(JL,JKM1)) * ZG(JL) * (1.-ZRNEB(JL)) +C + ZREFZ(JL,1,JK)=(1.-ZRNEB(JL))*(ZRAY1(JL,JKM1) + S +ZREFZ(JL,1,JKM1)*ZTRA1(JL,JKM1)*ZTRA2(JL,JKM1) + S /(1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))*ZG(JL)*ZS(JL) + S + ZRNEB(JL) * ZRE2(JL) +C + ZTR(JL,1,JKM1)= ZRNEB(JL) * ZTR2(JL) + S + (ZTRA1(JL,JKM1)/(1.-ZRAY2(JL,JKM1) + S * ZREFZ(JL,1,JKM1))) + S * ZG(JL) * (1. -ZRNEB(JL)) +C + 323 CONTINUE + 324 CONTINUE +C +C* 3.3 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL +C ------------------------------------------------- +C + 330 CONTINUE +C + DO 351 JREF=1,2 +C + JN = JN + 1 +C + DO 331 JL = 1, KDLON + ZRJ(JL,JN,KFLEV+1) = 1. + ZRK(JL,JN,KFLEV+1) = ZREFZ(JL,JREF,KFLEV+1) + 331 CONTINUE +C + DO 333 JK = 1 , KFLEV + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 332 JL = 1, KDLON + ZRE11 = ZRJ(JL,JN,JKLP1) * ZTR(JL,JREF,JKL) + ZRJ(JL,JN,JKL) = ZRE11 + ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,JREF,JKL) + 332 CONTINUE + 333 CONTINUE + 351 CONTINUE + 361 CONTINUE +C +C +C ------------------------------------------------------------------ +C +C* 4. INVERT GREY AND CONTINUUM FLUXES +C -------------------------------- +C + 400 CONTINUE +C +C +C* 4.1 UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES +C --------------------------------------------- +C + 410 CONTINUE +C + DO 414 JK = 1 , KFLEV+1 + DO 413 JAJ = 1 , 5 , 2 + JAJP = JAJ + 1 + DO 412 JL = 1, KDLON + ZRJ(JL,JAJ,JK)= ZRJ(JL,JAJ,JK) - ZRJ(JL,JAJP,JK) + ZRK(JL,JAJ,JK)= ZRK(JL,JAJ,JK) - ZRK(JL,JAJP,JK) + ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG ) + ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG ) + 412 CONTINUE + 413 CONTINUE + 414 CONTINUE +C + DO 417 JK = 1 , KFLEV+1 + DO 416 JAJ = 2 , 6 , 2 + DO 415 JL = 1, KDLON + ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG ) + ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG ) + 415 CONTINUE + 416 CONTINUE + 417 CONTINUE +C +C* 4.2 EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE +C --------------------------------------------- +C + 420 CONTINUE +C + DO 437 JK = 1 , KFLEV+1 + JKKI = 1 + DO 425 JAJ = 1 , 2 + IIND2(1)=JAJ + IIND2(2)=JAJ + DO 424 JN = 1 , 2 + JN2J = JN + 2 * JAJ + JKKP4 = JKKI + 4 +C +C* 4.2.1 EFFECTIVE ABSORBER AMOUNTS +C -------------------------- +C + 4210 CONTINUE +C + DO 4211 JL = 1, KDLON + ZW2(JL,1) = LOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK)) + S / PAKI(JL,JAJ) + ZW2(JL,2) = LOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK)) + S / PAKI(JL,JAJ) + 4211 CONTINUE +C +C* 4.2.2 TRANSMISSION FUNCTION +C --------------------- +C + 4220 CONTINUE +C + CALL SWTT1_LMDAR4(KNU, 2, IIND2, ZW2, ZR2) +C + DO 4221 JL = 1, KDLON + ZRL(JL,JKKI) = ZR2(JL,1) + ZRUEF(JL,JKKI) = ZW2(JL,1) + ZRL(JL,JKKP4) = ZR2(JL,2) + ZRUEF(JL,JKKP4) = ZW2(JL,2) + 4221 CONTINUE +C + JKKI=JKKI+1 + 424 CONTINUE + 425 CONTINUE +C +C* 4.3 UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION +C ------------------------------------------------------ +C + 430 CONTINUE +C + DO 431 JL = 1, KDLON + PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3) + S + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4) + PFUP(JL,JK) = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7) + S + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8) + 431 CONTINUE + 437 CONTINUE +C +C +C ------------------------------------------------------------------ +C +C* 5. MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES +C ---------------------------------------- +C + 500 CONTINUE +C +C +C* 5.1 DOWNWARD FLUXES +C --------------- +C + 510 CONTINUE +C + JAJ = 2 + IIND3(1)=1 + IIND3(2)=2 + IIND3(3)=3 +C + DO 511 JL = 1, KDLON + ZW3(JL,1)=0. + ZW3(JL,2)=0. + ZW3(JL,3)=0. + ZW4(JL) =0. + ZW5(JL) =0. + ZR4(JL) =1. + ZFD(JL,KFLEV+1)= ZRJ0(JL,JAJ,KFLEV+1) + 511 CONTINUE + DO 514 JK = 1 , KFLEV + IKL = KFLEV+1-JK + DO 512 JL = 1, KDLON + ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)/ZRMU0(JL,IKL) + ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)/ZRMU0(JL,IKL) + ZW3(JL,3)=ZW3(JL,3)+POZ(JL, IKL)/ZRMU0(JL,IKL) + ZW4(JL) =ZW4(JL) +PUD(JL,4,IKL)/ZRMU0(JL,IKL) + ZW5(JL) =ZW5(JL) +PUD(JL,5,IKL)/ZRMU0(JL,IKL) + 512 CONTINUE +C + CALL SWTT1_LMDAR4(KNU, 3, IIND3, ZW3, ZR3) +C + DO 513 JL = 1, KDLON +C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) + ZFD(JL,IKL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL) + S * ZRJ0(JL,JAJ,IKL) + 513 CONTINUE + 514 CONTINUE +C +C +C* 5.2 UPWARD FLUXES +C ------------- +C + 520 CONTINUE +C + DO 525 JL = 1, KDLON + ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU) + 525 CONTINUE +C + DO 528 JK = 2 , KFLEV+1 + IKM1=JK-1 + DO 526 JL = 1, KDLON + ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66 + ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66 + ZW3(JL,3)=ZW3(JL,3)+POZ(JL, IKM1)*1.66 + ZW4(JL) =ZW4(JL) +PUD(JL,4,IKM1)*1.66 + ZW5(JL) =ZW5(JL) +PUD(JL,5,IKM1)*1.66 + 526 CONTINUE +C + CALL SWTT1_LMDAR4(KNU, 3, IIND3, ZW3, ZR3) +C + DO 527 JL = 1, KDLON +C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) + ZFU(JL,JK) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL) + S * ZRK0(JL,JAJ,JK) + 527 CONTINUE + 528 CONTINUE +C +C +C ------------------------------------------------------------------ +C +C* 6. INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION +C -------------------------------------------------- +C + 600 CONTINUE + IABS=3 +C +C* 6.1 DOWNWARD FLUXES +C --------------- +C + 610 CONTINUE + DO 611 JL = 1, KDLON + ZW1(JL)=0. + ZW4(JL)=0. + ZW5(JL)=0. + ZR1(JL)=0. + PFDOWN(JL,KFLEV+1) = ((1.-PCLEAR(JL))*PFDOWN(JL,KFLEV+1) + S + PCLEAR(JL) * ZFD(JL,KFLEV+1)) * RSUN(KNU) + 611 CONTINUE +C + DO 614 JK = 1 , KFLEV + IKL=KFLEV+1-JK + DO 612 JL = 1, KDLON + ZW1(JL) = ZW1(JL)+POZ(JL, IKL)/ZRMUE(JL,IKL) + ZW4(JL) = ZW4(JL)+PUD(JL,4,IKL)/ZRMUE(JL,IKL) + ZW5(JL) = ZW5(JL)+PUD(JL,5,IKL)/ZRMUE(JL,IKL) +C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) + 612 CONTINUE +C + CALL SWTT_LMDAR4(KNU, IABS, ZW1, ZR1) +C + DO 613 JL = 1, KDLON + PFDOWN(JL,IKL) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL)*PFDOWN(JL,IKL) + S +PCLEAR(JL)*ZFD(JL,IKL)) * RSUN(KNU) + 613 CONTINUE + 614 CONTINUE +C +C +C* 6.2 UPWARD FLUXES +C ------------- +C + 620 CONTINUE + DO 621 JL = 1, KDLON + PFUP(JL,1) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,1) + S +PCLEAR(JL)*ZFU(JL,1)) * RSUN(KNU) + 621 CONTINUE +C + DO 624 JK = 2 , KFLEV+1 + IKM1=JK-1 + DO 622 JL = 1, KDLON + ZW1(JL) = ZW1(JL)+POZ(JL ,IKM1)*1.66 + ZW4(JL) = ZW4(JL)+PUD(JL,4,IKM1)*1.66 + ZW5(JL) = ZW5(JL)+PUD(JL,5,IKM1)*1.66 +C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) + 622 CONTINUE +C + CALL SWTT_LMDAR4(KNU, IABS, ZW1, ZR1) +C + DO 623 JL = 1, KDLON + PFUP(JL,JK) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,JK) + S +PCLEAR(JL)*ZFU(JL,JK)) * RSUN(KNU) + 623 CONTINUE + 624 CONTINUE +C +C ------------------------------------------------------------------ +C + RETURN + END + SUBROUTINE SWCLR_LMDAR4 ( KNU + S , PAER , flag_aer, tauae, pizae, cgae + S , PALBP , PDSIG , PRAYL , PSEC + S , PCGAZ , PPIZAZ, PRAY1 , PRAY2 , PREFZ , PRJ + S , PRK , PRMU0 , PTAUAZ, PTRA1 , PTRA2 ) + USE dimphy + USE radiation_AR4_param, only : TAUA, RPIZA, RCGA + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "radepsi.h" +#include "radopt.h" +C +C ------------------------------------------------------------------ +C PURPOSE. +C -------- +C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF +C CLEAR-SKY COLUMN +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT +C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 94-11-15 +C ------------------------------------------------------------------ +C* ARGUMENTS: +C + INTEGER KNU +c-OB + real(kind=8) flag_aer + real(kind=8) tauae(kdlon,kflev,2) + real(kind=8) pizae(kdlon,kflev,2) + real(kind=8) cgae(kdlon,kflev,2) + REAL(KIND=8) PAER(KDLON,KFLEV,5) + REAL(KIND=8) PALBP(KDLON,2) + REAL(KIND=8) PDSIG(KDLON,KFLEV) + REAL(KIND=8) PRAYL(KDLON) + REAL(KIND=8) PSEC(KDLON) +C + REAL(KIND=8) PCGAZ(KDLON,KFLEV) + REAL(KIND=8) PPIZAZ(KDLON,KFLEV) + REAL(KIND=8) PRAY1(KDLON,KFLEV+1) + REAL(KIND=8) PRAY2(KDLON,KFLEV+1) + REAL(KIND=8) PREFZ(KDLON,2,KFLEV+1) + REAL(KIND=8) PRJ(KDLON,6,KFLEV+1) + REAL(KIND=8) PRK(KDLON,6,KFLEV+1) + REAL(KIND=8) PRMU0(KDLON,KFLEV+1) + REAL(KIND=8) PTAUAZ(KDLON,KFLEV) + REAL(KIND=8) PTRA1(KDLON,KFLEV+1) + REAL(KIND=8) PTRA2(KDLON,KFLEV+1) +C +C* LOCAL VARIABLES: +C + REAL(KIND=8) ZC0I(KDLON,KFLEV+1) + REAL(KIND=8) ZCLE0(KDLON,KFLEV) + REAL(KIND=8) ZCLEAR(KDLON) + REAL(KIND=8) ZR21(KDLON) + REAL(KIND=8) ZR23(KDLON) + REAL(KIND=8) ZSS0(KDLON) + REAL(KIND=8) ZSCAT(KDLON) + REAL(KIND=8) ZTR(KDLON,2,KFLEV+1) +C + INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in + REAL(KIND=8) ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE + REAL(KIND=8) ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1 + REAL(KIND=8) ZBMU0, ZBMU1, ZRE11 +C + +C ------------------------------------------------------------------ +C +C* 1. OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH +C -------------------------------------------- +C + 100 CONTINUE +C +!cdir collapse + DO 103 JK = 1 , KFLEV+1 + DO 102 JA = 1 , 6 + DO 101 JL = 1, KDLON + PRJ(JL,JA,JK) = 0. + PRK(JL,JA,JK) = 0. + 101 CONTINUE + 102 CONTINUE + 103 CONTINUE +C + DO 108 JK = 1 , KFLEV +c-OB +c DO 104 JL = 1, KDLON +c PCGAZ(JL,JK) = 0. +c PPIZAZ(JL,JK) = 0. +c PTAUAZ(JL,JK) = 0. +c 104 CONTINUE +c-OB +c DO 106 JAE=1,5 +c DO 105 JL = 1, KDLON +c PTAUAZ(JL,JK)=PTAUAZ(JL,JK) +c S +PAER(JL,JK,JAE)*TAUA(KNU,JAE) +c PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE) +c S * TAUA(KNU,JAE)*RPIZA(KNU,JAE) +c PCGAZ(JL,JK) = PCGAZ(JL,JK) +PAER(JL,JK,JAE) +c S * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE) +c 105 CONTINUE +c 106 CONTINUE +c-OB + DO 105 JL = 1, KDLON + PTAUAZ(JL,JK)=flag_aer * tauae(JL,JK,KNU) + PPIZAZ(JL,JK)=flag_aer * pizae(JL,JK,KNU) + PCGAZ (JL,JK)=flag_aer * cgae(JL,JK,KNU) + 105 CONTINUE +C + IF (flag_aer.GT.0) THEN +c-OB + DO 107 JL = 1, KDLON +c PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK) +c PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK) + ZTRAY = PRAYL(JL) * PDSIG(JL,JK) + ZRATIO = ZTRAY / (ZTRAY + PTAUAZ(JL,JK)) + ZGAR = PCGAZ(JL,JK) + ZFF = ZGAR * ZGAR + PTAUAZ(JL,JK)=ZTRAY+PTAUAZ(JL,JK)*(1.-PPIZAZ(JL,JK)*ZFF) + PCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR) + PPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)*PPIZAZ(JL,JK)*(1.-ZFF) + S / (1. - PPIZAZ(JL,JK) * ZFF) + 107 CONTINUE + ELSE + DO JL = 1, KDLON + ZTRAY = PRAYL(JL) * PDSIG(JL,JK) + PTAUAZ(JL,JK) = ZTRAY + PCGAZ(JL,JK) = 0. + PPIZAZ(JL,JK) = 1.-REPSCT + END DO + END IF ! check flag_aer +c 107 CONTINUE +c PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5) +c $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON) +c 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5) +C + 108 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL +C ---------------------------------------------- +C + 200 CONTINUE +C + DO 201 JL = 1, KDLON + ZR23(JL) = 0. + ZC0I(JL,KFLEV+1) = 0. + ZCLEAR(JL) = 1. + ZSCAT(JL) = 0. + 201 CONTINUE +C + JK = 1 + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 202 JL = 1, KDLON + ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL) + ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL) + ZR21(JL) = EXP(-ZCORAE ) + ZSS0(JL) = 1.-ZR21(JL) + ZCLE0(JL,JKL) = ZSS0(JL) +C + IF (NOVLP.EQ.1) THEN +c* maximum-random + ZCLEAR(JL) = ZCLEAR(JL) + S *(1.0-MAX(ZSS0(JL),ZSCAT(JL))) + S /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC)) + ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL) + ZSCAT(JL) = ZSS0(JL) + ELSE IF (NOVLP.EQ.2) THEN +C* maximum + ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) ) + ZC0I(JL,JKL) = ZSCAT(JL) + ELSE IF (NOVLP.EQ.3) THEN +c* random + ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL)) + ZSCAT(JL) = 1.0 - ZCLEAR(JL) + ZC0I(JL,JKL) = ZSCAT(JL) + END IF + 202 CONTINUE +C + DO 205 JK = 2 , KFLEV + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 204 JL = 1, KDLON + ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL) + ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL) + ZR21(JL) = EXP(-ZCORAE ) + ZSS0(JL) = 1.-ZR21(JL) + ZCLE0(JL,JKL) = ZSS0(JL) +c + IF (NOVLP.EQ.1) THEN +c* maximum-random + ZCLEAR(JL) = ZCLEAR(JL) + S *(1.0-MAX(ZSS0(JL),ZSCAT(JL))) + S /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC)) + ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL) + ZSCAT(JL) = ZSS0(JL) + ELSE IF (NOVLP.EQ.2) THEN +C* maximum + ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) ) + ZC0I(JL,JKL) = ZSCAT(JL) + ELSE IF (NOVLP.EQ.3) THEN +c* random + ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL)) + ZSCAT(JL) = 1.0 - ZCLEAR(JL) + ZC0I(JL,JKL) = ZSCAT(JL) + END IF + 204 CONTINUE + 205 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING +C ----------------------------------------------- +C + 300 CONTINUE +C + DO 301 JL = 1, KDLON + PRAY1(JL,KFLEV+1) = 0. + PRAY2(JL,KFLEV+1) = 0. + PREFZ(JL,2,1) = PALBP(JL,KNU) + PREFZ(JL,1,1) = PALBP(JL,KNU) + PTRA1(JL,KFLEV+1) = 1. + PTRA2(JL,KFLEV+1) = 1. + 301 CONTINUE +C + DO 346 JK = 2 , KFLEV+1 + JKM1 = JK-1 + DO 342 JL = 1, KDLON +C +C +C ------------------------------------------------------------------ +C +C* 3.1 EQUIVALENT ZENITH ANGLE +C ----------------------- +C + 310 CONTINUE +C + ZMUE = (1.-ZC0I(JL,JK)) * PSEC(JL) + S + ZC0I(JL,JK) * 1.66 + PRMU0(JL,JK) = 1./ZMUE +C +C +C ------------------------------------------------------------------ +C +C* 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS +C ---------------------------------------------------- +C + 320 CONTINUE +C + ZGAP = PCGAZ(JL,JKM1) + ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE + ZWW = PPIZAZ(JL,JKM1) + ZTO = PTAUAZ(JL,JKM1) + ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE + S + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE + PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN + PTRA1(JL,JKM1) = 1. / ZDEN +C + ZMU1 = 0.5 + ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1 + ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1 + S + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1 + PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1 + PTRA2(JL,JKM1) = 1. / ZDEN1 +C +C +C + PREFZ(JL,1,JK) = (PRAY1(JL,JKM1) + S + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1) + S * PTRA2(JL,JKM1) + S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1))) +C + ZTR(JL,1,JKM1) = (PTRA1(JL,JKM1) + S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1))) +C + PREFZ(JL,2,JK) = (PRAY1(JL,JKM1) + S + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1) + S * PTRA2(JL,JKM1) ) +C + ZTR(JL,2,JKM1) = PTRA1(JL,JKM1) +C + 342 CONTINUE + 346 CONTINUE + DO 347 JL = 1, KDLON + ZMUE = (1.-ZC0I(JL,1))*PSEC(JL)+ZC0I(JL,1)*1.66 + PRMU0(JL,1)=1./ZMUE + 347 CONTINUE +C +C +C ------------------------------------------------------------------ +C +C* 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL +C ------------------------------------------------- +C + 350 CONTINUE +C + IF (KNU.EQ.1) THEN + JAJ = 2 + DO 351 JL = 1, KDLON + PRJ(JL,JAJ,KFLEV+1) = 1. + PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1) + 351 CONTINUE +C + DO 353 JK = 1 , KFLEV + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 352 JL = 1, KDLON + ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL, 1,JKL) + PRJ(JL,JAJ,JKL) = ZRE11 + PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL, 1,JKL) + 352 CONTINUE + 353 CONTINUE + 354 CONTINUE +C + ELSE +C + DO 358 JAJ = 1 , 2 + DO 355 JL = 1, KDLON + PRJ(JL,JAJ,KFLEV+1) = 1. + PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1) + 355 CONTINUE +C + DO 357 JK = 1 , KFLEV + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 356 JL = 1, KDLON + ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL) + PRJ(JL,JAJ,JKL) = ZRE11 + PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL) + 356 CONTINUE + 357 CONTINUE + 358 CONTINUE +C + END IF +C +C ------------------------------------------------------------------ +C + RETURN + END + SUBROUTINE SWR_LMDAR4 ( KNU + S , PALBD , PCG , PCLD , PDSIG, POMEGA, PRAYL + S , PSEC , PTAU + S , PCGAZ , PPIZAZ, PRAY1, PRAY2, PREFZ , PRJ , PRK , PRMUE + S , PTAUAZ, PTRA1 , PTRA2 ) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "radepsi.h" +#include "radopt.h" +C +C ------------------------------------------------------------------ +C PURPOSE. +C -------- +C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF +C CONTINUUM SCATTERING +C +C METHOD. +C ------- +C +C 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL +C OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION) +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT +C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C ------------------------------------------------------------------ +C* ARGUMENTS: +C + INTEGER KNU + REAL(KIND=8) PALBD(KDLON,2) + REAL(KIND=8) PCG(KDLON,2,KFLEV) + REAL(KIND=8) PCLD(KDLON,KFLEV) + REAL(KIND=8) PDSIG(KDLON,KFLEV) + REAL(KIND=8) POMEGA(KDLON,2,KFLEV) + REAL(KIND=8) PRAYL(KDLON) + REAL(KIND=8) PSEC(KDLON) + REAL(KIND=8) PTAU(KDLON,2,KFLEV) +C + REAL(KIND=8) PRAY1(KDLON,KFLEV+1) + REAL(KIND=8) PRAY2(KDLON,KFLEV+1) + REAL(KIND=8) PREFZ(KDLON,2,KFLEV+1) + REAL(KIND=8) PRJ(KDLON,6,KFLEV+1) + REAL(KIND=8) PRK(KDLON,6,KFLEV+1) + REAL(KIND=8) PRMUE(KDLON,KFLEV+1) + REAL(KIND=8) PCGAZ(KDLON,KFLEV) + REAL(KIND=8) PPIZAZ(KDLON,KFLEV) + REAL(KIND=8) PTAUAZ(KDLON,KFLEV) + REAL(KIND=8) PTRA1(KDLON,KFLEV+1) + REAL(KIND=8) PTRA2(KDLON,KFLEV+1) +C +C* LOCAL VARIABLES: +C + REAL(KIND=8) ZC1I(KDLON,KFLEV+1) + REAL(KIND=8) ZCLEQ(KDLON,KFLEV) + REAL(KIND=8) ZCLEAR(KDLON) + REAL(KIND=8) ZCLOUD(KDLON) + REAL(KIND=8) ZGG(KDLON) + REAL(KIND=8) ZREF(KDLON) + REAL(KIND=8) ZRE1(KDLON) + REAL(KIND=8) ZRE2(KDLON) + REAL(KIND=8) ZRMUZ(KDLON) + REAL(KIND=8) ZRNEB(KDLON) + REAL(KIND=8) ZR21(KDLON) + REAL(KIND=8) ZR22(KDLON) + REAL(KIND=8) ZR23(KDLON) + REAL(KIND=8) ZSS1(KDLON) + REAL(KIND=8) ZTO1(KDLON) + REAL(KIND=8) ZTR(KDLON,2,KFLEV+1) + REAL(KIND=8) ZTR1(KDLON) + REAL(KIND=8) ZTR2(KDLON) + REAL(KIND=8) ZW(KDLON) +C + INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj + REAL(KIND=8) ZFACOA, ZFACOC, ZCORAE, ZCORCD + REAL(KIND=8) ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1 + REAL(KIND=8) ZMU1, ZRE11, ZBMU0, ZBMU1 +C +C ------------------------------------------------------------------ +C +C* 1. INITIALIZATION +C -------------- +C + 100 CONTINUE +C + DO 103 JK = 1 , KFLEV+1 + DO 102 JA = 1 , 6 + DO 101 JL = 1, KDLON + PRJ(JL,JA,JK) = 0. + PRK(JL,JA,JK) = 0. + 101 CONTINUE + 102 CONTINUE + 103 CONTINUE +C +C +C ------------------------------------------------------------------ +C +C* 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL +C ---------------------------------------------- +C + 200 CONTINUE +C + DO 201 JL = 1, KDLON + ZR23(JL) = 0. + ZC1I(JL,KFLEV+1) = 0. + ZCLEAR(JL) = 1. + ZCLOUD(JL) = 0. + 201 CONTINUE +C + JK = 1 + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 202 JL = 1, KDLON + ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL) + ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL) + S * PCG(JL,KNU,JKL) + ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL) + ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL) + ZR21(JL) = EXP(-ZCORAE ) + ZR22(JL) = EXP(-ZCORCD ) + ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL)) + S + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL)) + ZCLEQ(JL,JKL) = ZSS1(JL) +C + IF (NOVLP.EQ.1) THEN +c* maximum-random + ZCLEAR(JL) = ZCLEAR(JL) + S *(1.0-MAX(ZSS1(JL),ZCLOUD(JL))) + S /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC)) + ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL) + ZCLOUD(JL) = ZSS1(JL) + ELSE IF (NOVLP.EQ.2) THEN +C* maximum + ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) ) + ZC1I(JL,JKL) = ZCLOUD(JL) + ELSE IF (NOVLP.EQ.3) THEN +c* random + ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL)) + ZCLOUD(JL) = 1.0 - ZCLEAR(JL) + ZC1I(JL,JKL) = ZCLOUD(JL) + END IF + 202 CONTINUE +C + DO 205 JK = 2 , KFLEV + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 204 JL = 1, KDLON + ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL) + ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL) + S * PCG(JL,KNU,JKL) + ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL) + ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL) + ZR21(JL) = EXP(-ZCORAE ) + ZR22(JL) = EXP(-ZCORCD ) + ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL)) + S + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL)) + ZCLEQ(JL,JKL) = ZSS1(JL) +c + IF (NOVLP.EQ.1) THEN +c* maximum-random + ZCLEAR(JL) = ZCLEAR(JL) + S *(1.0-MAX(ZSS1(JL),ZCLOUD(JL))) + S /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC)) + ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL) + ZCLOUD(JL) = ZSS1(JL) + ELSE IF (NOVLP.EQ.2) THEN +C* maximum + ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) ) + ZC1I(JL,JKL) = ZCLOUD(JL) + ELSE IF (NOVLP.EQ.3) THEN +c* random + ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL)) + ZCLOUD(JL) = 1.0 - ZCLEAR(JL) + ZC1I(JL,JKL) = ZCLOUD(JL) + END IF + 204 CONTINUE + 205 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING +C ----------------------------------------------- +C + 300 CONTINUE +C + DO 301 JL = 1, KDLON + PRAY1(JL,KFLEV+1) = 0. + PRAY2(JL,KFLEV+1) = 0. + PREFZ(JL,2,1) = PALBD(JL,KNU) + PREFZ(JL,1,1) = PALBD(JL,KNU) + PTRA1(JL,KFLEV+1) = 1. + PTRA2(JL,KFLEV+1) = 1. + 301 CONTINUE +C + DO 346 JK = 2 , KFLEV+1 + JKM1 = JK-1 + DO 342 JL = 1, KDLON + ZRNEB(JL)= PCLD(JL,JKM1) + ZRE1(JL)=0. + ZTR1(JL)=0. + ZRE2(JL)=0. + ZTR2(JL)=0. +C +C +C ------------------------------------------------------------------ +C +C* 3.1 EQUIVALENT ZENITH ANGLE +C ----------------------- +C + 310 CONTINUE +C + ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL) + S + ZC1I(JL,JK) * 1.66 + PRMUE(JL,JK) = 1./ZMUE +C +C +C ------------------------------------------------------------------ +C +C* 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS +C ---------------------------------------------------- +C + 320 CONTINUE +C + ZGAP = PCGAZ(JL,JKM1) + ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE + ZWW = PPIZAZ(JL,JKM1) + ZTO = PTAUAZ(JL,JKM1) + ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE + S + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE + PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN + PTRA1(JL,JKM1) = 1. / ZDEN +c PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1) +C + ZMU1 = 0.5 + ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1 + ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1 + S + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1 + PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1 + PTRA2(JL,JKM1) = 1. / ZDEN1 +C +C +C ------------------------------------------------------------------ +C +C* 3.3 EFFECT OF CLOUD LAYER +C --------------------- +C + 330 CONTINUE +C + ZW(JL) = POMEGA(JL,KNU,JKM1) + ZTO1(JL) = PTAU(JL,KNU,JKM1)/ZW(JL) + S + PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1) + ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1) + ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL) + ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1) + S + (1. - ZR22(JL)) * PCGAZ(JL,JKM1) +C Modif PhD - JJM 19/03/96 pour erreurs arrondis +C machine +C PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL) + IF (ZW(JL).EQ.1. .AND. PPIZAZ(JL,JKM1).EQ.1.) THEN + ZW(JL)=1. + ELSE + ZW(JL) = ZR21(JL) / ZTO1(JL) + END IF + ZREF(JL) = PREFZ(JL,1,JKM1) + ZRMUZ(JL) = PRMUE(JL,JK) + 342 CONTINUE +C + CALL SWDE_LMDAR4(ZGG , ZREF , ZRMUZ , ZTO1 , ZW, + S ZRE1 , ZRE2 , ZTR1 , ZTR2) +C + DO 345 JL = 1, KDLON +C + PREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1) + S + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1) + S * PTRA2(JL,JKM1) + S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1))) + S + ZRNEB(JL) * ZRE2(JL) +C + ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1) + S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1))) + S * (1.-ZRNEB(JL)) +C + PREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1) + S + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1) + S * PTRA2(JL,JKM1) ) + S + ZRNEB(JL) * ZRE1(JL) +C + ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL) + S + PTRA1(JL,JKM1) * (1.-ZRNEB(JL)) +C + 345 CONTINUE + 346 CONTINUE + DO 347 JL = 1, KDLON + ZMUE = (1.-ZC1I(JL,1))*PSEC(JL)+ZC1I(JL,1)*1.66 + PRMUE(JL,1)=1./ZMUE + 347 CONTINUE +C +C +C ------------------------------------------------------------------ +C +C* 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL +C ------------------------------------------------- +C + 350 CONTINUE +C + IF (KNU.EQ.1) THEN + JAJ = 2 + DO 351 JL = 1, KDLON + PRJ(JL,JAJ,KFLEV+1) = 1. + PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1) + 351 CONTINUE +C + DO 353 JK = 1 , KFLEV + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 352 JL = 1, KDLON + ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL, 1,JKL) + PRJ(JL,JAJ,JKL) = ZRE11 + PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL, 1,JKL) + 352 CONTINUE + 353 CONTINUE + 354 CONTINUE +C + ELSE +C + DO 358 JAJ = 1 , 2 + DO 355 JL = 1, KDLON + PRJ(JL,JAJ,KFLEV+1) = 1. + PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1) + 355 CONTINUE +C + DO 357 JK = 1 , KFLEV + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 356 JL = 1, KDLON + ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL) + PRJ(JL,JAJ,JKL) = ZRE11 + PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL) + 356 CONTINUE + 357 CONTINUE + 358 CONTINUE +C + END IF +C +C ------------------------------------------------------------------ +C + RETURN + END + SUBROUTINE SWDE_LMDAR4 (PGG,PREF,PRMUZ,PTO1,PW, + S PRE1,PRE2,PTR1,PTR2) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +C +C ------------------------------------------------------------------ +C PURPOSE. +C -------- +C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY +C LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION. +C +C METHOD. +C ------- +C +C STANDARD DELTA-EDDINGTON LAYER CALCULATIONS. +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 88-12-15 +C ------------------------------------------------------------------ +C* ARGUMENTS: +C + REAL(KIND=8) PGG(KDLON) ! ASSYMETRY FACTOR + REAL(KIND=8) PREF(KDLON) ! REFLECTIVITY OF THE UNDERLYING LAYER + REAL(KIND=8) PRMUZ(KDLON) ! COSINE OF SOLAR ZENITH ANGLE + REAL(KIND=8) PTO1(KDLON) ! OPTICAL THICKNESS + REAL(KIND=8) PW(KDLON) ! SINGLE SCATTERING ALBEDO + REAL(KIND=8) PRE1(KDLON) ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION) + REAL(KIND=8) PRE2(KDLON) ! LAYER REFLECTIVITY + REAL(KIND=8) PTR1(KDLON) ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION) + REAL(KIND=8) PTR2(KDLON) ! LAYER TRANSMISSIVITY +C +C* LOCAL VARIABLES: +C + INTEGER jl + REAL(KIND=8) ZFF, ZGP, ZTOP, ZWCP, ZDT, ZX1, ZWM + REAL(KIND=8) ZRM2, ZRK, ZX2, ZRP, ZALPHA, ZBETA, ZARG + REAL(KIND=8) ZEXMU0, ZARG2, ZEXKP, ZEXKM, ZXP2P, ZXM2P, ZAP2B, + $ ZAM2B + REAL(KIND=8) ZA11, ZA12, ZA13, ZA21, ZA22, ZA23 + REAL(KIND=8) ZDENA, ZC1A, ZC2A, ZRI0A, ZRI1A + REAL(KIND=8) ZRI0B, ZRI1B + REAL(KIND=8) ZB21, ZB22, ZB23, ZDENB, ZC1B, ZC2B + REAL(KIND=8) ZRI0C, ZRI1C, ZRI0D, ZRI1D +C ------------------------------------------------------------------ +C +C* 1. DELTA-EDDINGTON CALCULATIONS +C + 100 CONTINUE +C + DO 131 JL = 1, KDLON +C +C* 1.1 SET UP THE DELTA-MODIFIED PARAMETERS +C + 110 CONTINUE +C + ZFF = PGG(JL)*PGG(JL) + ZGP = PGG(JL)/(1.+PGG(JL)) + ZTOP = (1.- PW(JL) * ZFF) * PTO1(JL) + ZWCP = (1-ZFF)* PW(JL) /(1.- PW(JL) * ZFF) + ZDT = 2./3. + ZX1 = 1.-ZWCP*ZGP + ZWM = 1.-ZWCP + ZRM2 = PRMUZ(JL) * PRMUZ(JL) + ZRK = SQRT(3.*ZWM*ZX1) + ZX2 = 4.*(1.-ZRK*ZRK*ZRM2) + ZRP=ZRK/ZX1 + ZALPHA = 3.*ZWCP*ZRM2*(1.+ZGP*ZWM)/ZX2 + ZBETA = 3.*ZWCP* PRMUZ(JL) *(1.+3.*ZGP*ZRM2*ZWM)/ZX2 + ZARG=MIN(ZTOP/PRMUZ(JL),200._8) + ZEXMU0=EXP(-ZARG) + ZARG2=MIN(ZRK*ZTOP,200._8) + ZEXKP=EXP(ZARG2) + ZEXKM = 1./ZEXKP + ZXP2P = 1.+ZDT*ZRP + ZXM2P = 1.-ZDT*ZRP + ZAP2B = ZALPHA+ZDT*ZBETA + ZAM2B = ZALPHA-ZDT*ZBETA +C +C* 1.2 WITHOUT REFLECTION FROM THE UNDERLYING LAYER +C + 120 CONTINUE +C + ZA11 = ZXP2P + ZA12 = ZXM2P + ZA13 = ZAP2B + ZA22 = ZXP2P*ZEXKP + ZA21 = ZXM2P*ZEXKM + ZA23 = ZAM2B*ZEXMU0 + ZDENA = ZA11 * ZA22 - ZA21 * ZA12 + ZC1A = (ZA22*ZA13-ZA12*ZA23)/ZDENA + ZC2A = (ZA11*ZA23-ZA21*ZA13)/ZDENA + ZRI0A = ZC1A+ZC2A-ZALPHA + ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA + PRE1(JL) = (ZRI0A-ZDT*ZRI1A)/ PRMUZ(JL) + ZRI0B = ZC1A*ZEXKM+ZC2A*ZEXKP-ZALPHA*ZEXMU0 + ZRI1B = ZRP*(ZC1A*ZEXKM-ZC2A*ZEXKP)-ZBETA*ZEXMU0 + PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)/ PRMUZ(JL) +C +C* 1.3 WITH REFLECTION FROM THE UNDERLYING LAYER +C + 130 CONTINUE +C + ZB21 = ZA21- PREF(JL) *ZXP2P*ZEXKM + ZB22 = ZA22- PREF(JL) *ZXM2P*ZEXKP + ZB23 = ZA23- PREF(JL) *ZEXMU0*(ZAP2B - PRMUZ(JL) ) + ZDENB = ZA11 * ZB22 - ZB21 * ZA12 + ZC1B = (ZB22*ZA13-ZA12*ZB23)/ZDENB + ZC2B = (ZA11*ZB23-ZB21*ZA13)/ZDENB + ZRI0C = ZC1B+ZC2B-ZALPHA + ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA + PRE2(JL) = (ZRI0C-ZDT*ZRI1C) / PRMUZ(JL) + ZRI0D = ZC1B*ZEXKM + ZC2B*ZEXKP - ZALPHA*ZEXMU0 + ZRI1D = ZRP * (ZC1B*ZEXKM - ZC2B*ZEXKP) - ZBETA*ZEXMU0 + PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) / PRMUZ(JL) +C + 131 CONTINUE + RETURN + END + SUBROUTINE SWTT_LMDAR4 (KNU,KA,PU,PTR) + USE dimphy + USE radiation_AR4_param, only : APAD, BPAD, D + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +C +C----------------------------------------------------------------------- +C PURPOSE. +C -------- +C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE +C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL +C INTERVALS. +C +C METHOD. +C ------- +C +C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS +C AND HORNER'S ALGORITHM. +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 88-12-15 +C----------------------------------------------------------------------- +C +C* ARGUMENTS +C + INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL + INTEGER KA ! INDEX OF THE ABSORBER + REAL(KIND=8) PU(KDLON) ! ABSORBER AMOUNT +C + REAL(KIND=8) PTR(KDLON) ! TRANSMISSION FUNCTION +C +C* LOCAL VARIABLES: +C + REAL(KIND=8) ZR1(KDLON), ZR2(KDLON) + INTEGER jl, i,j +C + +C +C----------------------------------------------------------------------- +C +C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION +C + 100 CONTINUE +C + DO 201 JL = 1, KDLON + ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL) + S * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL) + S * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL) + S * ( APAD(KNU,KA,7) )))))) +C + ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL) + S * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL) + S * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL) + S * ( BPAD(KNU,KA,7) )))))) +C +C +C* 2. ADD THE BACKGROUND TRANSMISSION +C + 200 CONTINUE +C +C + PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA) + 201 CONTINUE +C + RETURN + END + SUBROUTINE SWTT1_LMDAR4(KNU,KABS,KIND, PU, PTR) + USE dimphy + USE radiation_AR4_param, only : APAD, BPAD, D + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +C +C----------------------------------------------------------------------- +C PURPOSE. +C -------- +C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE +C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL +C INTERVALS. +C +C METHOD. +C ------- +C +C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS +C AND HORNER'S ALGORITHM. +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 95-01-20 +C----------------------------------------------------------------------- +C* ARGUMENTS: +C + INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL + INTEGER KABS ! NUMBER OF ABSORBERS + INTEGER KIND(KABS) ! INDICES OF THE ABSORBERS + REAL(KIND=8) PU(KDLON,KABS) ! ABSORBER AMOUNT +C + REAL(KIND=8) PTR(KDLON,KABS) ! TRANSMISSION FUNCTION +C +C* LOCAL VARIABLES: +C + REAL(KIND=8) ZR1(KDLON) + REAL(KIND=8) ZR2(KDLON) + REAL(KIND=8) ZU(KDLON) + INTEGER jl, ja, i, j, ia +C + +C----------------------------------------------------------------------- +C +C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION +C + 100 CONTINUE +C + DO 202 JA = 1,KABS + IA=KIND(JA) + DO 201 JL = 1, KDLON + ZU(JL) = PU(JL,JA) + ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL) + S * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL) + S * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL) + S * ( APAD(KNU,IA,7) )))))) +C + ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL) + S * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL) + S * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL) + S * ( BPAD(KNU,IA,7) )))))) +C +C +C* 2. ADD THE BACKGROUND TRANSMISSION +C + 200 CONTINUE +C + PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA) + 201 CONTINUE + 202 CONTINUE +C + RETURN + END +cIM ctes ds clesphys.h SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12, + SUBROUTINE LW_LMDAR4( + . PPMB, PDP, + . PPSOL,PDT0,PEMIS, + . PTL, PTAVE, PWV, POZON, PAER, + . PCLDLD,PCLDLU, + . PVIEW, + . PCOLR, PCOLR0, + . PTOPLW,PSOLLW,PTOPLW0,PSOLLW0, + . psollwdown, +cIM . psollwdown,psollwdownclr, +cIM . ptoplwdown,ptoplwdownclr) + . plwup, plwdn, plwup0, plwdn0) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +#include "YOMCST.h" +C +C----------------------------------------------------------------------- +C METHOD. +C ------- +C +C 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF +C ABSORBERS. +C 2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE +C GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS. +C 3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON- +C TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE +C BOUNDARIES. +C 4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES. +C 5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES. +C +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C----------------------------------------------------------------------- +cIM ctes ds clesphys.h +c REAL(KIND=8) RCO2 ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97) +c REAL(KIND=8) RCH4 ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97) +c REAL(KIND=8) RN2O ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97) +c REAL(KIND=8) RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12* 137.3686/28.97) +c REAL(KIND=8) RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12* 120.9140/28.97) +#include "clesphys.h" + REAL(KIND=8) PCLDLD(KDLON,KFLEV) ! DOWNWARD EFFECTIVE CLOUD COVER + REAL(KIND=8) PCLDLU(KDLON,KFLEV) ! UPWARD EFFECTIVE CLOUD COVER + REAL(KIND=8) PDP(KDLON,KFLEV) ! LAYER PRESSURE THICKNESS (Pa) + REAL(KIND=8) PDT0(KDLON) ! SURFACE TEMPERATURE DISCONTINUITY (K) + REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY + REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF LEVEL PRESSURE (mb) + REAL(KIND=8) PPSOL(KDLON) ! SURFACE PRESSURE (Pa) + REAL(KIND=8) POZON(KDLON,KFLEV) ! O3 mass fraction + REAL(KIND=8) PTL(KDLON,KFLEV+1) ! HALF LEVEL TEMPERATURE (K) + REAL(KIND=8) PAER(KDLON,KFLEV,5) ! OPTICAL THICKNESS OF THE AEROSOLS + REAL(KIND=8) PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K) + REAL(KIND=8) PVIEW(KDLON) ! COSECANT OF VIEWING ANGLE + REAL(KIND=8) PWV(KDLON,KFLEV) ! SPECIFIC HUMIDITY (kg/kg) +C + REAL(KIND=8) PCOLR(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day) + REAL(KIND=8) PCOLR0(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day) clear-sky + REAL(KIND=8) PTOPLW(KDLON) ! LONGWAVE FLUX AT T.O.A. + REAL(KIND=8) PSOLLW(KDLON) ! LONGWAVE FLUX AT SURFACE + REAL(KIND=8) PTOPLW0(KDLON) ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY) + REAL(KIND=8) PSOLLW0(KDLON) ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY) +c Rajout LF + real(kind=8) psollwdown(kdlon) ! LONGWAVE downwards flux at surface +c Rajout IM +cIM real(kind=8) psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at surface +cIM real(kind=8) ptoplwdown(kdlon) ! LONGWAVE downwards flux at T.O.A. +cIM real(kind=8) ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at T.O.A. +cIM + REAL(KIND=8) plwup(KDLON,KFLEV+1) ! LW up total sky + REAL(KIND=8) plwup0(KDLON,KFLEV+1) ! LW up clear sky + REAL(KIND=8) plwdn(KDLON,KFLEV+1) ! LW down total sky + REAL(KIND=8) plwdn0(KDLON,KFLEV+1) ! LW down clear sky +C------------------------------------------------------------------------- + REAL(KIND=8) ZABCU(KDLON,NUA,3*KFLEV+1) + + REAL(KIND=8) ZOZ(KDLON,KFLEV) +! equivalent pressure of ozone in a layer, in Pa + +cym REAL(KIND=8) ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2:down) +cym REAL(KIND=8) ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES +cym REAL(KIND=8) ZBINT(KDLON,KFLEV+1) ! Intermediate variable +cym REAL(KIND=8) ZBSUI(KDLON) ! Intermediate variable +cym REAL(KIND=8) ZCTS(KDLON,KFLEV) ! Intermediate variable +cym REAL(KIND=8) ZCNTRB(KDLON,KFLEV+1,KFLEV+1) ! Intermediate variable +cym SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB + REAL(KIND=8),allocatable,save :: ZFLUX(:,:,:) ! RADIATIVE FLUXES (1:up; 2:down) + REAL(KIND=8),allocatable,save :: ZFLUC(:,:,:) ! CLEAR-SKY RADIATIVE FLUXES + REAL(KIND=8),allocatable,save :: ZBINT(:,:) ! Intermediate variable + REAL(KIND=8),allocatable,save :: ZBSUI(:) ! Intermediate variable + REAL(KIND=8),allocatable,save :: ZCTS(:,:) ! Intermediate variable + REAL(KIND=8),allocatable,save :: ZCNTRB(:,:,:) ! Intermediate variable +c$OMP THREADPRIVATE(ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB) +c + INTEGER ilim, i, k, kpl1 +C + INTEGER lw0pas ! Every lw0pas steps, clear-sky is done + PARAMETER (lw0pas=1) + INTEGER lwpas ! Every lwpas steps, cloudy-sky is done + PARAMETER (lwpas=1) +c + INTEGER itaplw0, itaplw + LOGICAL appel1er + SAVE appel1er, itaplw0, itaplw +c$OMP THREADPRIVATE(appel1er, itaplw0, itaplw) + DATA appel1er /.TRUE./ + DATA itaplw0,itaplw /0,0/ + +C ------------------------------------------------------------------ + IF (appel1er) THEN + PRINT*, "LW clear-sky calling frequency: ", lw0pas + PRINT*, "LW cloudy-sky calling frequency: ", lwpas + PRINT*, " In general, they should be 1" +cym + allocate(ZFLUX(KDLON,2,KFLEV+1) ) + allocate(ZFLUC(KDLON,2,KFLEV+1) ) + allocate(ZBINT(KDLON,KFLEV+1)) + allocate(ZBSUI(KDLON)) + allocate(ZCTS(KDLON,KFLEV)) + allocate(ZCNTRB(KDLON,KFLEV+1,KFLEV+1)) + appel1er=.FALSE. + ENDIF +C + IF (MOD(itaplw0,lw0pas).EQ.0) THEN +c Compute equivalent pressure of ozone from mass fraction: + DO k = 1, KFLEV + DO i = 1, KDLON + ZOZ(i,k) = POZON(i,k)*PDP(i,k) + ENDDO + ENDDO +cIM ctes ds clesphys.h CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12, + CALL LWU_LMDAR4( + S PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU) + CALL LWBV_LMDAR4(ILIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,ZABCU, + S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB) + itaplw0 = 0 + ENDIF + itaplw0 = itaplw0 + 1 +C + IF (MOD(itaplw,lwpas).EQ.0) THEN + CALL LWC_LMDAR4(ILIM,PCLDLD,PCLDLU,PEMIS, + S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB, + S ZFLUX) + itaplw = 0 + ENDIF + itaplw = itaplw + 1 +C + DO k = 1, KFLEV + kpl1 = k+1 + DO i = 1, KDLON + PCOLR(i,k) = ZFLUX(i,1,kpl1)+ZFLUX(i,2,kpl1) + . - ZFLUX(i,1,k)- ZFLUX(i,2,k) + PCOLR(i,k) = PCOLR(i,k) * RDAY*RG/RCPD / PDP(i,k) + PCOLR0(i,k) = ZFLUC(i,1,kpl1)+ZFLUC(i,2,kpl1) + . - ZFLUC(i,1,k)- ZFLUC(i,2,k) + PCOLR0(i,k) = PCOLR0(i,k) * RDAY*RG/RCPD / PDP(i,k) + ENDDO + ENDDO + DO i = 1, KDLON + PSOLLW(i) = -ZFLUX(i,1,1)-ZFLUX(i,2,1) + PTOPLW(i) = ZFLUX(i,1,KFLEV+1) + ZFLUX(i,2,KFLEV+1) +c + PSOLLW0(i) = -ZFLUC(i,1,1)-ZFLUC(i,2,1) + PTOPLW0(i) = ZFLUC(i,1,KFLEV+1) + ZFLUC(i,2,KFLEV+1) + psollwdown(i) = -ZFLUX(i,2,1) +c +cIM attention aux signes !; LWtop >0, LWdn < 0 + DO k = 1, KFLEV+1 + plwup(i,k) = ZFLUX(i,1,k) + plwup0(i,k) = ZFLUC(i,1,k) + plwdn(i,k) = ZFLUX(i,2,k) + plwdn0(i,k) = ZFLUC(i,2,k) + ENDDO + ENDDO +C ------------------------------------------------------------------ + RETURN + END +cIM ctes ds clesphys.h SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12, + SUBROUTINE LWU_LMDAR4( + S PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV, + S PABCU) + USE dimphy + USE radiation_AR4_param, only : TREF, RT1, RAER, AT, BT, OCT + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +#include "YOMCST.h" +#include "radepsi.h" +#include "radopt.h" +C +C PURPOSE. +C -------- +C COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND +C TEMPERATURE EFFECTS +C +C METHOD. +C ------- +C +C 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF +C ABSORBERS. +C +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C Voigt lines (loop 404 modified) - JJM & PhD - 01/96 +C----------------------------------------------------------------------- +C* ARGUMENTS: +cIM ctes ds clesphys.h +c REAL(KIND=8) RCO2 +c REAL(KIND=8) RCH4, RN2O, RCFC11, RCFC12 +#include "clesphys.h" + REAL(KIND=8) PAER(KDLON,KFLEV,5) + REAL(KIND=8) PDP(KDLON,KFLEV) + REAL(KIND=8) PPMB(KDLON,KFLEV+1) + REAL(KIND=8) PPSOL(KDLON) + REAL(KIND=8) POZ(KDLON,KFLEV) + REAL(KIND=8) PTAVE(KDLON,KFLEV) + REAL(KIND=8) PVIEW(KDLON) + REAL(KIND=8) PWV(KDLON,KFLEV) +C + REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS +C +C----------------------------------------------------------------------- +C* LOCAL VARIABLES: + REAL(KIND=8) ZABLY(KDLON,NUA,3*KFLEV+1) + REAL(KIND=8) ZDUC(KDLON,3*KFLEV+1) + REAL(KIND=8) ZPHIO(KDLON) + REAL(KIND=8) ZPSC2(KDLON) + REAL(KIND=8) ZPSC3(KDLON) + REAL(KIND=8) ZPSH1(KDLON) + REAL(KIND=8) ZPSH2(KDLON) + REAL(KIND=8) ZPSH3(KDLON) + REAL(KIND=8) ZPSH4(KDLON) + REAL(KIND=8) ZPSH5(KDLON) + REAL(KIND=8) ZPSH6(KDLON) + REAL(KIND=8) ZPSIO(KDLON) + REAL(KIND=8) ZTCON(KDLON) + REAL(KIND=8) ZPHM6(KDLON) + REAL(KIND=8) ZPSM6(KDLON) + REAL(KIND=8) ZPHN6(KDLON) + REAL(KIND=8) ZPSN6(KDLON) + REAL(KIND=8) ZSSIG(KDLON,3*KFLEV+1) + REAL(KIND=8) ZTAVI(KDLON) + REAL(KIND=8) ZUAER(KDLON,Ninter) + REAL(KIND=8) ZXOZ(KDLON) + REAL(KIND=8) ZXWV(KDLON) +C + INTEGER jl, jk, jkj, jkjr, jkjp, ig1 + INTEGER jki, jkip1, ja, jj + INTEGER jkl, jkp1, jkk, jkjpn + INTEGER jae1, jae2, jae3, jae, jjpn + INTEGER ir, jc, jcp1 + REAL(KIND=8) zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup + REAL(KIND=8) zfppw, ztx, ztx2, zzably + REAL(KIND=8) zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3 + REAL(KIND=8) zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6 + REAL(KIND=8) zcac8, zcbc8 + REAL(KIND=8) zalup, zdiff +c + REAL(KIND=8) PVGCO2, PVGH2O, PVGO3 +C + REAL(KIND=8) R10E ! DECIMAL/NATURAL LOG.FACTOR + PARAMETER (R10E=0.4342945) + +C----------------------------------------------------------------------- +c + IF (LEVOIGT) THEN + PVGCO2= 60. + PVGH2O= 30. + PVGO3 =400. + ELSE + PVGCO2= 0. + PVGH2O= 0. + PVGO3 = 0. + ENDIF +C +C +C* 2. PRESSURE OVER GAUSS SUB-LEVELS +C ------------------------------ +C + 200 CONTINUE +C + DO 201 JL = 1, KDLON + ZSSIG(JL, 1 ) = PPMB(JL,1) * 100. + 201 CONTINUE +C + DO 206 JK = 1 , KFLEV + JKJ=(JK-1)*NG1P1+1 + JKJR = JKJ + JKJP = JKJ + NG1P1 + DO 203 JL = 1, KDLON + ZSSIG(JL,JKJP)=PPMB(JL,JK+1)* 100. + 203 CONTINUE + DO 205 IG1=1,NG1 + JKJ=JKJ+1 + DO 204 JL = 1, KDLON + ZSSIG(JL,JKJ)= (ZSSIG(JL,JKJR)+ZSSIG(JL,JKJP))*0.5 + S + RT1(IG1) * (ZSSIG(JL,JKJP) - ZSSIG(JL,JKJR)) * 0.5 + 204 CONTINUE + 205 CONTINUE + 206 CONTINUE +C +C----------------------------------------------------------------------- +C +C +C* 4. PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS +C -------------------------------------------------- +C + 400 CONTINUE +C + DO 402 JKI=1,3*KFLEV + JKIP1=JKI+1 + DO 401 JL = 1, KDLON + ZABLY(JL,5,JKI)=(ZSSIG(JL,JKI)+ZSSIG(JL,JKIP1))*0.5 + ZABLY(JL,3,JKI)=(ZSSIG(JL,JKI)-ZSSIG(JL,JKIP1)) + S /(10.*RG) + 401 CONTINUE + 402 CONTINUE +C + DO 406 JK = 1 , KFLEV + JKP1=JK+1 + JKL = KFLEV+1 - JK + DO 403 JL = 1, KDLON + ZXWV(JL) = MAX (PWV(JL,JK) , ZEPSCQ ) + ZXOZ(JL) = MAX (POZ(JL,JK) / PDP(JL,JK) , ZEPSCO ) + 403 CONTINUE + JKJ=(JK-1)*NG1P1+1 + JKJPN=JKJ+NG1 + DO 405 JKK=JKJ,JKJPN + DO 404 JL = 1, KDLON + ZDPM = ZABLY(JL,3,JKK) + ZUPM = ZABLY(JL,5,JKK) * ZDPM / 101325. + ZUPMCO2 = ( ZABLY(JL,5,JKK) + PVGCO2 ) * ZDPM / 101325. + ZUPMH2O = ( ZABLY(JL,5,JKK) + PVGH2O ) * ZDPM / 101325. + ZUPMO3 = ( ZABLY(JL,5,JKK) + PVGO3 ) * ZDPM / 101325. + ZDUC(JL,JKK) = ZDPM + ZABLY(JL,12,JKK) = ZXOZ(JL) * ZDPM + ZABLY(JL,13,JKK) = ZXOZ(JL) * ZUPMO3 + ZU6 = ZXWV(JL) * ZUPM + ZFPPW = 1.6078 * ZXWV(JL) / (1.+0.608*ZXWV(JL)) + ZABLY(JL,6,JKK) = ZXWV(JL) * ZUPMH2O + ZABLY(JL,11,JKK) = ZU6 * ZFPPW + ZABLY(JL,10,JKK) = ZU6 * (1.-ZFPPW) + ZABLY(JL,9,JKK) = RCO2 * ZUPMCO2 + ZABLY(JL,8,JKK) = RCO2 * ZDPM + 404 CONTINUE + 405 CONTINUE + 406 CONTINUE +C +C----------------------------------------------------------------------- +C +C +C* 5. CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE +C -------------------------------------------------- +C + 500 CONTINUE +C + DO 502 JA = 1, NUA + DO 501 JL = 1, KDLON + PABCU(JL,JA,3*KFLEV+1) = 0. + 501 CONTINUE + 502 CONTINUE +C + DO 529 JK = 1 , KFLEV + JJ=(JK-1)*NG1P1+1 + JJPN=JJ+NG1 + JKL=KFLEV+1-JK +C +C +C* 5.1 CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE +C -------------------------------------------------- +C + 510 CONTINUE +C + JAE1=3*KFLEV+1-JJ + JAE2=3*KFLEV+1-(JJ+1) + JAE3=3*KFLEV+1-JJPN + DO 512 JAE=1,5 + DO 511 JL = 1, KDLON + ZUAER(JL,JAE) = (RAER(JAE,1)*PAER(JL,JKL,1) + S +RAER(JAE,2)*PAER(JL,JKL,2)+RAER(JAE,3)*PAER(JL,JKL,3) + S +RAER(JAE,4)*PAER(JL,JKL,4)+RAER(JAE,5)*PAER(JL,JKL,5)) + S /(ZDUC(JL,JAE1)+ZDUC(JL,JAE2)+ZDUC(JL,JAE3)) + 511 CONTINUE + 512 CONTINUE +C +C +C +C* 5.2 INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS +C -------------------------------------------------- +C + 520 CONTINUE +C + DO 521 JL = 1, KDLON + ZTAVI(JL)=PTAVE(JL,JKL) + ZTCON(JL)=EXP(6.08*(296./ZTAVI(JL)-1.)) + ZTX=ZTAVI(JL)-TREF + ZTX2=ZTX*ZTX + ZZABLY = ZABLY(JL,6,JAE1)+ZABLY(JL,6,JAE2)+ZABLY(JL,6,JAE3) + ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0._8), 6._8) + ZCAH1=AT(1,1)+ZUP*(AT(1,2)+ZUP*(AT(1,3))) + ZCBH1=BT(1,1)+ZUP*(BT(1,2)+ZUP*(BT(1,3))) + ZPSH1(JL)=EXP( ZCAH1 * ZTX + ZCBH1 * ZTX2 ) + ZCAH2=AT(2,1)+ZUP*(AT(2,2)+ZUP*(AT(2,3))) + ZCBH2=BT(2,1)+ZUP*(BT(2,2)+ZUP*(BT(2,3))) + ZPSH2(JL)=EXP( ZCAH2 * ZTX + ZCBH2 * ZTX2 ) + ZCAH3=AT(3,1)+ZUP*(AT(3,2)+ZUP*(AT(3,3))) + ZCBH3=BT(3,1)+ZUP*(BT(3,2)+ZUP*(BT(3,3))) + ZPSH3(JL)=EXP( ZCAH3 * ZTX + ZCBH3 * ZTX2 ) + ZCAH4=AT(4,1)+ZUP*(AT(4,2)+ZUP*(AT(4,3))) + ZCBH4=BT(4,1)+ZUP*(BT(4,2)+ZUP*(BT(4,3))) + ZPSH4(JL)=EXP( ZCAH4 * ZTX + ZCBH4 * ZTX2 ) + ZCAH5=AT(5,1)+ZUP*(AT(5,2)+ZUP*(AT(5,3))) + ZCBH5=BT(5,1)+ZUP*(BT(5,2)+ZUP*(BT(5,3))) + ZPSH5(JL)=EXP( ZCAH5 * ZTX + ZCBH5 * ZTX2 ) + ZCAH6=AT(6,1)+ZUP*(AT(6,2)+ZUP*(AT(6,3))) + ZCBH6=BT(6,1)+ZUP*(BT(6,2)+ZUP*(BT(6,3))) + ZPSH6(JL)=EXP( ZCAH6 * ZTX + ZCBH6 * ZTX2 ) + ZPHM6(JL)=EXP(-5.81E-4 * ZTX - 1.13E-6 * ZTX2 ) + ZPSM6(JL)=EXP(-5.57E-4 * ZTX - 3.30E-6 * ZTX2 ) + ZPHN6(JL)=EXP(-3.46E-5 * ZTX + 2.05E-7 * ZTX2 ) + ZPSN6(JL)=EXP( 3.70E-3 * ZTX - 2.30E-6 * ZTX2 ) + 521 CONTINUE +C + DO 522 JL = 1, KDLON + ZTAVI(JL)=PTAVE(JL,JKL) + ZTX=ZTAVI(JL)-TREF + ZTX2=ZTX*ZTX + ZZABLY = ZABLY(JL,9,JAE1)+ZABLY(JL,9,JAE2)+ZABLY(JL,9,JAE3) + ZALUP = R10E * LOG ( ZZABLY ) + ZUP = MAX( 0._8, 5.0 + 0.5 * ZALUP ) + ZPSC2(JL) = (ZTAVI(JL)/TREF) ** ZUP + ZCAC8=AT(8,1)+ZUP*(AT(8,2)+ZUP*(AT(8,3))) + ZCBC8=BT(8,1)+ZUP*(BT(8,2)+ZUP*(BT(8,3))) + ZPSC3(JL)=EXP( ZCAC8 * ZTX + ZCBC8 * ZTX2 ) + ZPHIO(JL) = EXP( OCT(1) * ZTX + OCT(2) * ZTX2) + ZPSIO(JL) = EXP( 2.* (OCT(3)*ZTX+OCT(4)*ZTX2)) + 522 CONTINUE +C + DO 524 JKK=JJ,JJPN + JC=3*KFLEV+1-JKK + JCP1=JC+1 + DO 523 JL = 1, KDLON + ZDIFF = PVIEW(JL) + PABCU(JL,10,JC)=PABCU(JL,10,JCP1) + S +ZABLY(JL,10,JC) *ZDIFF + PABCU(JL,11,JC)=PABCU(JL,11,JCP1) + S +ZABLY(JL,11,JC)*ZTCON(JL)*ZDIFF +C + PABCU(JL,12,JC)=PABCU(JL,12,JCP1) + S +ZABLY(JL,12,JC)*ZPHIO(JL)*ZDIFF + PABCU(JL,13,JC)=PABCU(JL,13,JCP1) + S +ZABLY(JL,13,JC)*ZPSIO(JL)*ZDIFF +C + PABCU(JL,7,JC)=PABCU(JL,7,JCP1) + S +ZABLY(JL,9,JC)*ZPSC2(JL)*ZDIFF + PABCU(JL,8,JC)=PABCU(JL,8,JCP1) + S +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF + PABCU(JL,9,JC)=PABCU(JL,9,JCP1) + S +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF +C + PABCU(JL,1,JC)=PABCU(JL,1,JCP1) + S +ZABLY(JL,6,JC)*ZPSH1(JL)*ZDIFF + PABCU(JL,2,JC)=PABCU(JL,2,JCP1) + S +ZABLY(JL,6,JC)*ZPSH2(JL)*ZDIFF + PABCU(JL,3,JC)=PABCU(JL,3,JCP1) + S +ZABLY(JL,6,JC)*ZPSH5(JL)*ZDIFF + PABCU(JL,4,JC)=PABCU(JL,4,JCP1) + S +ZABLY(JL,6,JC)*ZPSH3(JL)*ZDIFF + PABCU(JL,5,JC)=PABCU(JL,5,JCP1) + S +ZABLY(JL,6,JC)*ZPSH4(JL)*ZDIFF + PABCU(JL,6,JC)=PABCU(JL,6,JCP1) + S +ZABLY(JL,6,JC)*ZPSH6(JL)*ZDIFF +C + PABCU(JL,14,JC)=PABCU(JL,14,JCP1) + S +ZUAER(JL,1) *ZDUC(JL,JC)*ZDIFF + PABCU(JL,15,JC)=PABCU(JL,15,JCP1) + S +ZUAER(JL,2) *ZDUC(JL,JC)*ZDIFF + PABCU(JL,16,JC)=PABCU(JL,16,JCP1) + S +ZUAER(JL,3) *ZDUC(JL,JC)*ZDIFF + PABCU(JL,17,JC)=PABCU(JL,17,JCP1) + S +ZUAER(JL,4) *ZDUC(JL,JC)*ZDIFF + PABCU(JL,18,JC)=PABCU(JL,18,JCP1) + S +ZUAER(JL,5) *ZDUC(JL,JC)*ZDIFF +C + PABCU(JL,19,JC)=PABCU(JL,19,JCP1) + S +ZABLY(JL,8,JC)*RCH4/RCO2*ZPHM6(JL)*ZDIFF + PABCU(JL,20,JC)=PABCU(JL,20,JCP1) + S +ZABLY(JL,9,JC)*RCH4/RCO2*ZPSM6(JL)*ZDIFF + PABCU(JL,21,JC)=PABCU(JL,21,JCP1) + S +ZABLY(JL,8,JC)*RN2O/RCO2*ZPHN6(JL)*ZDIFF + PABCU(JL,22,JC)=PABCU(JL,22,JCP1) + S +ZABLY(JL,9,JC)*RN2O/RCO2*ZPSN6(JL)*ZDIFF +C + PABCU(JL,23,JC)=PABCU(JL,23,JCP1) + S +ZABLY(JL,8,JC)*RCFC11/RCO2 *ZDIFF + PABCU(JL,24,JC)=PABCU(JL,24,JCP1) + S +ZABLY(JL,8,JC)*RCFC12/RCO2 *ZDIFF + 523 CONTINUE + 524 CONTINUE +C + 529 CONTINUE +C +C + RETURN + END + SUBROUTINE LWBV_LMDAR4(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU, + S PFLUC,PBINT,PBSUI,PCTS,PCNTRB) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +#include "YOMCST.h" +C +C PURPOSE. +C -------- +C TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE +C VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY +C SAVING +C +C METHOD. +C ------- +C +C 1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE +C GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS. +C 2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON- +C TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE +C BOUNDARIES. +C 3. COMPUTES THE CLEAR-SKY COOLING RATES. +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE +C MEMORY) +C----------------------------------------------------------------------- +C* ARGUMENTS: + INTEGER KLIM +C + REAL(KIND=8) PDP(KDLON,KFLEV) + REAL(KIND=8) PDT0(KDLON) + REAL(KIND=8) PEMIS(KDLON) + REAL(KIND=8) PPMB(KDLON,KFLEV+1) + REAL(KIND=8) PTL(KDLON,KFLEV+1) + REAL(KIND=8) PTAVE(KDLON,KFLEV) +C + REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) +C + REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) + REAL(KIND=8) PBINT(KDLON,KFLEV+1) + REAL(KIND=8) PBSUI(KDLON) + REAL(KIND=8) PCTS(KDLON,KFLEV) + REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) +C +C------------------------------------------------------------------------- +C +C* LOCAL VARIABLES: + REAL(KIND=8) ZB(KDLON,Ninter,KFLEV+1) + REAL(KIND=8) ZBSUR(KDLON,Ninter) + REAL(KIND=8) ZBTOP(KDLON,Ninter) + REAL(KIND=8) ZDBSL(KDLON,Ninter,KFLEV*2) + REAL(KIND=8) ZGA(KDLON,8,2,KFLEV) + REAL(KIND=8) ZGB(KDLON,8,2,KFLEV) + REAL(KIND=8) ZGASUR(KDLON,8,2) + REAL(KIND=8) ZGBSUR(KDLON,8,2) + REAL(KIND=8) ZGATOP(KDLON,8,2) + REAL(KIND=8) ZGBTOP(KDLON,8,2) +C + INTEGER nuaer, ntraer +C ------------------------------------------------------------------ +C* COMPUTES PLANCK FUNCTIONS: + CALL LWB_LMDAR4(PDT0,PTAVE,PTL, + S ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL, + S ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP) +C ------------------------------------------------------------------ +C* PERFORMS THE VERTICAL INTEGRATION: + NUAER = NUA + NTRAER = NTRA + CALL LWV_LMDAR4(NUAER,NTRAER, KLIM + R , PABCU,ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,PEMIS,PPMB,PTAVE + R , ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP + S , PCNTRB,PCTS,PFLUC) +C ------------------------------------------------------------------ + RETURN + END + SUBROUTINE LWC_LMDAR4(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC, + R PBINT,PBSUIN,PCTS,PCNTRB, + S PFLUX) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "radepsi.h" +#include "radopt.h" +C +C PURPOSE. +C -------- +C INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR +C RADIANCES +C +C EXPLICIT ARGUMENTS : +C -------------------- +C ==== INPUTS === +C PBINT : (KDLON,0:KFLEV) ; HALF LEVEL PLANCK FUNCTION +C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION +C PCLDLD : (KDLON,KFLEV) ; DOWNWARD EFFECTIVE CLOUD FRACTION +C PCLDLU : (KDLON,KFLEV) ; UPWARD EFFECTIVE CLOUD FRACTION +C PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE +C PCTS : (KDLON,KFLEV) ; CLEAR-SKY LAYER COOLING-TO-SPACE +C PEMIS : (KDLON) ; SURFACE EMISSIVITY +C PFLUC +C ==== OUTPUTS === +C PFLUX(KDLON,2,KFLEV) ; RADIATIVE FLUXES : +C 1 ==> UPWARD FLUX TOTAL +C 2 ==> DOWNWARD FLUX TOTAL +C +C METHOD. +C ------- +C +C 1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES +C 2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER +C 3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED +C CLOUDS +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C Voigt lines (loop 231 to 233) - JJM & PhD - 01/96 +C----------------------------------------------------------------------- +C* ARGUMENTS: + INTEGER klim + REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES + REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION + REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION + REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE + REAL(KIND=8) PCTS(KDLON,KFLEV) ! CLEAR-SKY LAYER COOLING-TO-SPACE +c + REAL(KIND=8) PCLDLD(KDLON,KFLEV) + REAL(KIND=8) PCLDLU(KDLON,KFLEV) + REAL(KIND=8) PEMIS(KDLON) +C + REAL(KIND=8) PFLUX(KDLON,2,KFLEV+1) +C----------------------------------------------------------------------- +C* LOCAL VARIABLES: + INTEGER IMX(KDLON), IMXP(KDLON) +C + REAL(KIND=8) ZCLEAR(KDLON),ZCLOUD(KDLON), + $ ZDNF(KDLON,KFLEV+1,KFLEV+1) + S , ZFD(KDLON), ZFN10(KDLON), ZFU(KDLON) + S , ZUPF(KDLON,KFLEV+1,KFLEV+1) + REAL(KIND=8) ZCLM(KDLON,KFLEV+1,KFLEV+1) +C + INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1 + INTEGER jk1, jk2, jkc, jkcp1, jcloud + INTEGER imxm1, imxp1 + REAL(KIND=8) zcfrac +C ------------------------------------------------------------------ +C +C* 1. INITIALIZATION +C -------------- +C + 100 CONTINUE +C + IMAXC = 0 +C + DO 101 JL = 1, KDLON + IMX(JL)=0 + IMXP(JL)=0 + ZCLOUD(JL) = 0. + 101 CONTINUE +C +C* 1.1 SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD +C ------------------------------------------- +C + 110 CONTINUE +C + DO 112 JK = 1 , KFLEV + DO 111 JL = 1, KDLON + IMX1=IMX(JL) + IMX2=JK + IF (PCLDLU(JL,JK).GT.ZEPSC) THEN + IMXP(JL)=IMX2 + ELSE + IMXP(JL)=IMX1 + END IF + IMAXC=MAX(IMXP(JL),IMAXC) + IMX(JL)=IMXP(JL) + 111 CONTINUE + 112 CONTINUE +CGM******* + IMAXC=KFLEV +CGM******* +C + DO 114 JK = 1 , KFLEV+1 + DO 113 JL = 1, KDLON + PFLUX(JL,1,JK) = PFLUC(JL,1,JK) + PFLUX(JL,2,JK) = PFLUC(JL,2,JK) + 113 CONTINUE + 114 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 2. EFFECT OF CLOUDINESS ON LONGWAVE FLUXES +C --------------------------------------- +C + IF (IMAXC.GT.0) THEN +C + IMXP1 = IMAXC + 1 + IMXM1 = IMAXC - 1 +C +C* 2.0 INITIALIZE TO CLEAR-SKY FLUXES +C ------------------------------ +C + 200 CONTINUE +C + DO 203 JK1=1,KFLEV+1 + DO 202 JK2=1,KFLEV+1 + DO 201 JL = 1, KDLON + ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1) + ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1) + 201 CONTINUE + 202 CONTINUE + 203 CONTINUE +C +C* 2.1 FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD +C ---------------------------------------------- +C + 210 CONTINUE +C + DO 213 JKC = 1 , IMAXC + JCLOUD=JKC + JKCP1=JCLOUD+1 +C +C* 2.1.1 ABOVE THE CLOUD +C --------------- +C + 2110 CONTINUE +C + DO 2115 JK=JKCP1,KFLEV+1 + JKM1=JK-1 + DO 2111 JL = 1, KDLON + ZFU(JL)=0. + 2111 CONTINUE + IF (JK .GT. JKCP1) THEN + DO 2113 JKJ=JKCP1,JKM1 + DO 2112 JL = 1, KDLON + ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ) + 2112 CONTINUE + 2113 CONTINUE + END IF +C + DO 2114 JL = 1, KDLON + ZUPF(JL,JKCP1,JK)=PBINT(JL,JK)-ZFU(JL) + 2114 CONTINUE + 2115 CONTINUE +C +C* 2.1.2 BELOW THE CLOUD +C --------------- +C + 2120 CONTINUE +C + DO 2125 JK=1,JCLOUD + JKP1=JK+1 + DO 2121 JL = 1, KDLON + ZFD(JL)=0. + 2121 CONTINUE +C + IF (JK .LT. JCLOUD) THEN + DO 2123 JKJ=JKP1,JCLOUD + DO 2122 JL = 1, KDLON + ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ) + 2122 CONTINUE + 2123 CONTINUE + END IF + DO 2124 JL = 1, KDLON + ZDNF(JL,JKCP1,JK)=-PBINT(JL,JK)-ZFD(JL) + 2124 CONTINUE + 2125 CONTINUE +C + 213 CONTINUE +C +C +C* 2.2 CLOUD COVER MATRIX +C ------------------ +C +C* ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN +C HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1 +C + 220 CONTINUE +C + DO 223 JK1 = 1 , KFLEV+1 + DO 222 JK2 = 1 , KFLEV+1 + DO 221 JL = 1, KDLON + ZCLM(JL,JK1,JK2) = 0. + 221 CONTINUE + 222 CONTINUE + 223 CONTINUE +C +C +C +C* 2.4 CLOUD COVER BELOW THE LEVEL OF CALCULATION +C ------------------------------------------ +C + 240 CONTINUE +C + DO 244 JK1 = 2 , KFLEV+1 + DO 241 JL = 1, KDLON + ZCLEAR(JL)=1. + ZCLOUD(JL)=0. + 241 CONTINUE + DO 243 JK = JK1 - 1 , 1 , -1 + DO 242 JL = 1, KDLON + IF (NOVLP.EQ.1) THEN +c* maximum-random + ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLU(JL,JK),ZCLOUD(JL))) + * /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC)) + ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL) + ZCLOUD(JL) = PCLDLU(JL,JK) + ELSE IF (NOVLP.EQ.2) THEN +c* maximum + ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK)) + ZCLM(JL,JK1,JK) = ZCLOUD(JL) + ELSE IF (NOVLP.EQ.3) THEN +c* random + ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLU(JL,JK)) + ZCLOUD(JL) = 1.0 - ZCLEAR(JL) + ZCLM(JL,JK1,JK) = ZCLOUD(JL) + END IF + 242 CONTINUE + 243 CONTINUE + 244 CONTINUE +C +C +C* 2.5 CLOUD COVER ABOVE THE LEVEL OF CALCULATION +C ------------------------------------------ +C + 250 CONTINUE +C + DO 254 JK1 = 1 , KFLEV + DO 251 JL = 1, KDLON + ZCLEAR(JL)=1. + ZCLOUD(JL)=0. + 251 CONTINUE + DO 253 JK = JK1 , KFLEV + DO 252 JL = 1, KDLON + IF (NOVLP.EQ.1) THEN +c* maximum-random + ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLD(JL,JK),ZCLOUD(JL))) + * /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC)) + ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL) + ZCLOUD(JL) = PCLDLD(JL,JK) + ELSE IF (NOVLP.EQ.2) THEN +c* maximum + ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK)) + ZCLM(JL,JK1,JK) = ZCLOUD(JL) + ELSE IF (NOVLP.EQ.3) THEN +c* random + ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLD(JL,JK)) + ZCLOUD(JL) = 1.0 - ZCLEAR(JL) + ZCLM(JL,JK1,JK) = ZCLOUD(JL) + END IF + 252 CONTINUE + 253 CONTINUE + 254 CONTINUE +C +C +C +C* 3. FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS +C ---------------------------------------------- +C + 300 CONTINUE +C +C* 3.1 DOWNWARD FLUXES +C --------------- +C + 310 CONTINUE +C + DO 311 JL = 1, KDLON + PFLUX(JL,2,KFLEV+1) = 0. + 311 CONTINUE +C + DO 317 JK1 = KFLEV , 1 , -1 +C +C* CONTRIBUTION FROM CLEAR-SKY FRACTION +C + DO 312 JL = 1, KDLON + ZFD (JL) = (1. - ZCLM(JL,JK1,KFLEV)) * ZDNF(JL,1,JK1) + 312 CONTINUE +C +C* CONTRIBUTION FROM ADJACENT CLOUD +C + DO 313 JL = 1, KDLON + ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1) + 313 CONTINUE +C +C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS +C + DO 315 JK = KFLEV-1 , JK1 , -1 + DO 314 JL = 1, KDLON + ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK) + ZFD(JL) = ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1) + 314 CONTINUE + 315 CONTINUE +C + DO 316 JL = 1, KDLON + PFLUX(JL,2,JK1) = ZFD (JL) + 316 CONTINUE +C + 317 CONTINUE +C +C +C +C +C* 3.2 UPWARD FLUX AT THE SURFACE +C -------------------------- +C + 320 CONTINUE +C + DO 321 JL = 1, KDLON + PFLUX(JL,1,1) = PEMIS(JL)*PBSUIN(JL)-(1.-PEMIS(JL))*PFLUX(JL,2,1) + 321 CONTINUE +C +C +C +C* 3.3 UPWARD FLUXES +C ------------- +C + 330 CONTINUE +C + DO 337 JK1 = 2 , KFLEV+1 +C +C* CONTRIBUTION FROM CLEAR-SKY FRACTION +C + DO 332 JL = 1, KDLON + ZFU (JL) = (1. - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1) + 332 CONTINUE +C +C* CONTRIBUTION FROM ADJACENT CLOUD +C + DO 333 JL = 1, KDLON + ZFU(JL) = ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1) + 333 CONTINUE +C +C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS +C + DO 335 JK = 2 , JK1-1 + DO 334 JL = 1, KDLON + ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK) + ZFU(JL) = ZFU(JL) + ZCFRAC * ZUPF(JL,JK ,JK1) + 334 CONTINUE + 335 CONTINUE +C + DO 336 JL = 1, KDLON + PFLUX(JL,1,JK1) = ZFU (JL) + 336 CONTINUE +C + 337 CONTINUE +C +C + END IF +C +C +C* 2.3 END OF CLOUD EFFECT COMPUTATIONS +C + 230 CONTINUE +C + IF (.NOT.LEVOIGT) THEN + DO 231 JL = 1, KDLON + ZFN10(JL) = PFLUX(JL,1,KLIM) + PFLUX(JL,2,KLIM) + 231 CONTINUE + DO 233 JK = KLIM+1 , KFLEV+1 + DO 232 JL = 1, KDLON + ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1) + PFLUX(JL,1,JK) = ZFN10(JL) + PFLUX(JL,2,JK) = 0.0 + 232 CONTINUE + 233 CONTINUE + ENDIF +C + RETURN + END + SUBROUTINE LWB_LMDAR4(PDT0,PTAVE,PTL + S , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL + S , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP) + USE dimphy + USE radiation_AR4_param, only : TINTP, XP, GA, GB + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +C +C----------------------------------------------------------------------- +C PURPOSE. +C -------- +C COMPUTES PLANCK FUNCTIONS +C +C EXPLICIT ARGUMENTS : +C -------------------- +C ==== INPUTS === +C PDT0 : (KDLON) ; SURFACE TEMPERATURE DISCONTINUITY +C PTAVE : (KDLON,KFLEV) ; TEMPERATURE +C PTL : (KDLON,0:KFLEV) ; HALF LEVEL TEMPERATURE +C ==== OUTPUTS === +C PB : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION +C PBINT : (KDLON,KFLEV+1) ; HALF LEVEL PLANCK FUNCTION +C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION +C PBSUR : (KDLON,Ninter) ; SURFACE SPECTRAL PLANCK FUNCTION +C PBTOP : (KDLON,Ninter) ; TOP SPECTRAL PLANCK FUNCTION +C PDBSL : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT +C PGA : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS +C PGB : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS +C PGASUR, PGBSUR (KDLON,8,2) ; SURFACE PADE APPROXIMANTS +C PGATOP, PGBTOP (KDLON,8,2) ; T.O.A. PADE APPROXIMANTS +C +C IMPLICIT ARGUMENTS : NONE +C -------------------- +C +C METHOD. +C ------- +C +C 1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS +C FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS " +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C +C----------------------------------------------------------------------- +C +C ARGUMENTS: +C + REAL(KIND=8) PDT0(KDLON) + REAL(KIND=8) PTAVE(KDLON,KFLEV) + REAL(KIND=8) PTL(KDLON,KFLEV+1) +C + REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION + REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION + REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION + REAL(KIND=8) PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION + REAL(KIND=8) PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION + REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT + REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS + REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS + REAL(KIND=8) PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS + REAL(KIND=8) PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS + REAL(KIND=8) PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS + REAL(KIND=8) PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS +C +C------------------------------------------------------------------------- +C* LOCAL VARIABLES: + INTEGER INDB(KDLON),INDS(KDLON) + REAL(KIND=8) ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1) + REAL(KIND=8) ZRES(KDLON),ZRES2(KDLON),ZTI(KDLON),ZTI2(KDLON) +c + INTEGER jk, jl, ic, jnu, jf, jg + INTEGER jk1, jk2 + INTEGER k, j, ixtox, indto, ixtx, indt + INTEGER indsu, indtp + REAL(KIND=8) zdsto1, zdstox, zdst1, zdstx +c +C* Quelques parametres: + REAL(KIND=8) TSTAND + PARAMETER (TSTAND=250.0) + REAL(KIND=8) TSTP + PARAMETER (TSTP=12.5) + INTEGER MXIXT + PARAMETER (MXIXT=10) +C +C* Used Data Block: +c REAL*8 TINTP(11) +c SAVE TINTP +cc$OMP THREADPRIVATE(TINTP) +c REAL*8 GA(11,16,3), GB(11,16,3) +c SAVE GA, GB +cc$OMP THREADPRIVATE(GA, GB) +c REAL*8 XP(6,6) +c SAVE XP +cc$OMP THREADPRIVATE(XP) +c +c DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250., +c S 262.5, 275., 287.5, 300., 312.5 / +C----------------------------------------------------------------------- +C-- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ---------------- +C +C +C +C +C-- R.D. -- G = - 0.2 SLA +C +C +C----- INTERVAL = 1 ----- T = 187.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 1, 1,IC),IC=1,3) / +C S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/ +C DATA (GB( 1, 1,IC),IC=1,3) / +C S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/ +C DATA (GA( 1, 2,IC),IC=1,3) / +C S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/ +C DATA (GB( 1, 2,IC),IC=1,3) / +C S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 200.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 2, 1,IC),IC=1,3) / +C S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/ +C DATA (GB( 2, 1,IC),IC=1,3) / +C S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/ +C DATA (GA( 2, 2,IC),IC=1,3) / +C S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/ +C DATA (GB( 2, 2,IC),IC=1,3) / +C S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 212.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 3, 1,IC),IC=1,3) / +C S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/ +C DATA (GB( 3, 1,IC),IC=1,3) / +C S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/ +C DATA (GA( 3, 2,IC),IC=1,3) / +C S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/ +C DATA (GB( 3, 2,IC),IC=1,3) / +C S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 225.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 4, 1,IC),IC=1,3) / +C S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/ +C DATA (GB( 4, 1,IC),IC=1,3) / +C S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/ +C DATA (GA( 4, 2,IC),IC=1,3) / +C S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/ +C DATA (GB( 4, 2,IC),IC=1,3) / +C S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 237.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 5, 1,IC),IC=1,3) / +C S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/ +C DATA (GB( 5, 1,IC),IC=1,3) / +C S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/ +C DATA (GA( 5, 2,IC),IC=1,3) / +C S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/ +C DATA (GB( 5, 2,IC),IC=1,3) / +C S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 250.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 6, 1,IC),IC=1,3) / +C S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/ +C DATA (GB( 6, 1,IC),IC=1,3) / +C S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/ +C DATA (GA( 6, 2,IC),IC=1,3) / +C S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/ +C DATA (GB( 6, 2,IC),IC=1,3) / +C S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 262.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 7, 1,IC),IC=1,3) / +C S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/ +C DATA (GB( 7, 1,IC),IC=1,3) / +C S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/ +C DATA (GA( 7, 2,IC),IC=1,3) / +C S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/ +C DATA (GB( 7, 2,IC),IC=1,3) / +C S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 275.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 8, 1,IC),IC=1,3) / +C S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/ +C DATA (GB( 8, 1,IC),IC=1,3) / +C S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/ +C DATA (GA( 8, 2,IC),IC=1,3) / +C S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/ +C DATA (GB( 8, 2,IC),IC=1,3) / +C S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 287.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 9, 1,IC),IC=1,3) / +C S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/ +C DATA (GB( 9, 1,IC),IC=1,3) / +C S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/ +C DATA (GA( 9, 2,IC),IC=1,3) / +C S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/ +C DATA (GB( 9, 2,IC),IC=1,3) / +C S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 300.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA(10, 1,IC),IC=1,3) / +C S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/ +C DATA (GB(10, 1,IC),IC=1,3) / +C S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/ +C DATA (GA(10, 2,IC),IC=1,3) / +C S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/ +C DATA (GB(10, 2,IC),IC=1,3) / +C S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 312.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA(11, 1,IC),IC=1,3) / +C S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/ +C DATA (GB(11, 1,IC),IC=1,3) / +C S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/ +C DATA (GA(11, 2,IC),IC=1,3) / +C S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/ +C DATA (GB(11, 2,IC),IC=1,3) / +C S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/ +C +C +C +C--- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 --------- +C +C +C +C +C--- R.D. --- G = 0.02 + 0.50 / ( 1 + 4.5 U ) +C +C +C----- INTERVAL = 2 ----- T = 187.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 1, 3,IC),IC=1,3) / +C S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/ +C DATA (GB( 1, 3,IC),IC=1,3) / +C S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/ +C DATA (GA( 1, 4,IC),IC=1,3) / +C S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/ +C DATA (GB( 1, 4,IC),IC=1,3) / +C S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 200.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 2, 3,IC),IC=1,3) / +C S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/ +C DATA (GB( 2, 3,IC),IC=1,3) / +C S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/ +C DATA (GA( 2, 4,IC),IC=1,3) / +C S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/ +C DATA (GB( 2, 4,IC),IC=1,3) / +C S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 212.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 3, 3,IC),IC=1,3) / +C S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/ +C DATA (GB( 3, 3,IC),IC=1,3) / +C S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/ +C DATA (GA( 3, 4,IC),IC=1,3) / +C S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/ +C DATA (GB( 3, 4,IC),IC=1,3) / +C S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 225.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 4, 3,IC),IC=1,3) / +C S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/ +C DATA (GB( 4, 3,IC),IC=1,3) / +C S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/ +C DATA (GA( 4, 4,IC),IC=1,3) / +C S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/ +C DATA (GB( 4, 4,IC),IC=1,3) / +C S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 237.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 5, 3,IC),IC=1,3) / +C S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/ +C DATA (GB( 5, 3,IC),IC=1,3) / +C S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/ +C DATA (GA( 5, 4,IC),IC=1,3) / +C S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/ +C DATA (GB( 5, 4,IC),IC=1,3) / +C S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 250.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 6, 3,IC),IC=1,3) / +C S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/ +C DATA (GB( 6, 3,IC),IC=1,3) / +C S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/ +C DATA (GA( 6, 4,IC),IC=1,3) / +C S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/ +C DATA (GB( 6, 4,IC),IC=1,3) / +C S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 262.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 7, 3,IC),IC=1,3) / +C S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/ +C DATA (GB( 7, 3,IC),IC=1,3) / +C S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/ +C DATA (GA( 7, 4,IC),IC=1,3) / +C S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/ +C DATA (GB( 7, 4,IC),IC=1,3) / +C S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 275.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 8, 3,IC),IC=1,3) / +C S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/ +C DATA (GB( 8, 3,IC),IC=1,3) / +C S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/ +C DATA (GA( 8, 4,IC),IC=1,3) / +C S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/ +C DATA (GB( 8, 4,IC),IC=1,3) / +C S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 287.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 9, 3,IC),IC=1,3) / +C S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/ +C DATA (GB( 9, 3,IC),IC=1,3) / +C S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/ +C DATA (GA( 9, 4,IC),IC=1,3) / +C S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/ +C DATA (GB( 9, 4,IC),IC=1,3) / +C S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 300.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA(10, 3,IC),IC=1,3) / +C S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/ +C DATA (GB(10, 3,IC),IC=1,3) / +C S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/ +C DATA (GA(10, 4,IC),IC=1,3) / +C S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/ +C DATA (GB(10, 4,IC),IC=1,3) / +C S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 312.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA(11, 3,IC),IC=1,3) / +C S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/ +C DATA (GB(11, 3,IC),IC=1,3) / +C S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/ +C DATA (GA(11, 4,IC),IC=1,3) / +C S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/ +C DATA (GB(11, 4,IC),IC=1,3) / +C S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/ +C +C +C +C +C +C +C- WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS - +C +C +C-- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1) +C +C +C +C--- G = 3.875E-03 --------------- +C +C----- INTERVAL = 3 ----- T = 187.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 1, 7,IC),IC=1,3) / +C S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/ +C DATA (GB( 1, 7,IC),IC=1,3) / +C S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/ +C DATA (GA( 1, 8,IC),IC=1,3) / +C S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/ +C DATA (GB( 1, 8,IC),IC=1,3) / +C S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 200.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 2, 7,IC),IC=1,3) / +C S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/ +C DATA (GB( 2, 7,IC),IC=1,3) / +C S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/ +C DATA (GA( 2, 8,IC),IC=1,3) / +C S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/ +C DATA (GB( 2, 8,IC),IC=1,3) / +C S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 212.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 3, 7,IC),IC=1,3) / +C S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/ +C DATA (GB( 3, 7,IC),IC=1,3) / +C S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/ +C DATA (GA( 3, 8,IC),IC=1,3) / +C S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/ +C DATA (GB( 3, 8,IC),IC=1,3) / +C S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 225.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 4, 7,IC),IC=1,3) / +C S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/ +C DATA (GB( 4, 7,IC),IC=1,3) / +C S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/ +C DATA (GA( 4, 8,IC),IC=1,3) / +C S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/ +C DATA (GB( 4, 8,IC),IC=1,3) / +C S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 237.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 5, 7,IC),IC=1,3) / +C S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/ +C DATA (GB( 5, 7,IC),IC=1,3) / +C S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/ +C DATA (GA( 5, 8,IC),IC=1,3) / +C S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/ +C DATA (GB( 5, 8,IC),IC=1,3) / +C S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 250.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 6, 7,IC),IC=1,3) / +C S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/ +C DATA (GB( 6, 7,IC),IC=1,3) / +C S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/ +C DATA (GA( 6, 8,IC),IC=1,3) / +C S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/ +C DATA (GB( 6, 8,IC),IC=1,3) / +C S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 262.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 7, 7,IC),IC=1,3) / +C S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/ +C DATA (GB( 7, 7,IC),IC=1,3) / +C S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/ +C DATA (GA( 7, 8,IC),IC=1,3) / +C S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/ +C DATA (GB( 7, 8,IC),IC=1,3) / +C S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 275.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 8, 7,IC),IC=1,3) / +C S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/ +C DATA (GB( 8, 7,IC),IC=1,3) / +C S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/ +C DATA (GA( 8, 8,IC),IC=1,3) / +C S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/ +C DATA (GB( 8, 8,IC),IC=1,3) / +C S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 287.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 9, 7,IC),IC=1,3) / +C S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/ +C DATA (GB( 9, 7,IC),IC=1,3) / +C S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/ +C DATA (GA( 9, 8,IC),IC=1,3) / +C S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/ +C DATA (GB( 9, 8,IC),IC=1,3) / +C S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 300.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA(10, 7,IC),IC=1,3) / +C S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/ +C DATA (GB(10, 7,IC),IC=1,3) / +C S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/ +C DATA (GA(10, 8,IC),IC=1,3) / +C S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/ +C DATA (GB(10, 8,IC),IC=1,3) / +C S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 312.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA(11, 7,IC),IC=1,3) / +C S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/ +C DATA (GB(11, 7,IC),IC=1,3) / +C S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/ +C DATA (GA(11, 8,IC),IC=1,3) / +C S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/ +C DATA (GB(11, 8,IC),IC=1,3) / +C S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/ +C +C +C-- WATER VAPOR -- 970-1110 CM-1 ---------------------------------------- +C +C-- G = 3.6E-03 +C +C----- INTERVAL = 4 ----- T = 187.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 1, 9,IC),IC=1,3) / +C S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/ +C DATA (GB( 1, 9,IC),IC=1,3) / +C S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/ +C DATA (GA( 1,10,IC),IC=1,3) / +C S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/ +C DATA (GB( 1,10,IC),IC=1,3) / +C S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 200.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 2, 9,IC),IC=1,3) / +C S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/ +C DATA (GB( 2, 9,IC),IC=1,3) / +C S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/ +C DATA (GA( 2,10,IC),IC=1,3) / +C S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/ +C DATA (GB( 2,10,IC),IC=1,3) / +C S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 212.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 3, 9,IC),IC=1,3) / +C S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/ +C DATA (GB( 3, 9,IC),IC=1,3) / +C S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/ +C DATA (GA( 3,10,IC),IC=1,3) / +C S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/ +C DATA (GB( 3,10,IC),IC=1,3) / +C S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 225.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 4, 9,IC),IC=1,3) / +C S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/ +C DATA (GB( 4, 9,IC),IC=1,3) / +C S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/ +C DATA (GA( 4,10,IC),IC=1,3) / +C S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/ +C DATA (GB( 4,10,IC),IC=1,3) / +C S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 237.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 5, 9,IC),IC=1,3) / +C S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/ +C DATA (GB( 5, 9,IC),IC=1,3) / +C S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/ +C DATA (GA( 5,10,IC),IC=1,3) / +C S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/ +C DATA (GB( 5,10,IC),IC=1,3) / +C S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 250.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 6, 9,IC),IC=1,3) / +C S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/ +C DATA (GB( 6, 9,IC),IC=1,3) / +C S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/ +C DATA (GA( 6,10,IC),IC=1,3) / +C S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/ +C DATA (GB( 6,10,IC),IC=1,3) / +C S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 262.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 7, 9,IC),IC=1,3) / +C S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/ +C DATA (GB( 7, 9,IC),IC=1,3) / +C S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/ +C DATA (GA( 7,10,IC),IC=1,3) / +C S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/ +C DATA (GB( 7,10,IC),IC=1,3) / +C S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 275.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 8, 9,IC),IC=1,3) / +C S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/ +C DATA (GB( 8, 9,IC),IC=1,3) / +C S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/ +C DATA (GA( 8,10,IC),IC=1,3) / +C S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/ +C DATA (GB( 8,10,IC),IC=1,3) / +C S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 287.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 9, 9,IC),IC=1,3) / +C S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/ +C DATA (GB( 9, 9,IC),IC=1,3) / +C S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/ +C DATA (GA( 9,10,IC),IC=1,3) / +C S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/ +C DATA (GB( 9,10,IC),IC=1,3) / +C S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 300.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA(10, 9,IC),IC=1,3) / +C S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/ +C DATA (GB(10, 9,IC),IC=1,3) / +C S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/ +C DATA (GA(10,10,IC),IC=1,3) / +C S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/ +C DATA (GB(10,10,IC),IC=1,3) / +C S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 312.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA(11, 9,IC),IC=1,3) / +C S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/ +C DATA (GB(11, 9,IC),IC=1,3) / +C S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/ +C DATA (GA(11,10,IC),IC=1,3) / +C S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/ +C DATA (GB(11,10,IC),IC=1,3) / +C S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/ +C +C +C +C-- H2O -- WEAKER PARTS OF THE STRONG BANDS -- FROM ABS225 ---- +C +C-- WATER VAPOR --- 350 - 500 CM-1 +C +C-- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U) +C +C----- INTERVAL = 5 ----- T = 187.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 1, 5,IC),IC=1,3) / +C S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/ +C DATA (GB( 1, 5,IC),IC=1,3) / +C S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/ +C DATA (GA( 1, 6,IC),IC=1,3) / +C S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/ +C DATA (GB( 1, 6,IC),IC=1,3) / +C S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 200.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 2, 5,IC),IC=1,3) / +C S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/ +C DATA (GB( 2, 5,IC),IC=1,3) / +C S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/ +C DATA (GA( 2, 6,IC),IC=1,3) / +C S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/ +C DATA (GB( 2, 6,IC),IC=1,3) / +C S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 212.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 3, 5,IC),IC=1,3) / +C S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/ +C DATA (GB( 3, 5,IC),IC=1,3) / +C S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/ +C DATA (GA( 3, 6,IC),IC=1,3) / +C S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/ +C DATA (GB( 3, 6,IC),IC=1,3) / +C S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 225.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 4, 5,IC),IC=1,3) / +C S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/ +C DATA (GB( 4, 5,IC),IC=1,3) / +C S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/ +C DATA (GA( 4, 6,IC),IC=1,3) / +C S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/ +C DATA (GB( 4, 6,IC),IC=1,3) / +C S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 237.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 5, 5,IC),IC=1,3) / +C S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/ +C DATA (GB( 5, 5,IC),IC=1,3) / +C S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/ +C DATA (GA( 5, 6,IC),IC=1,3) / +C S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/ +C DATA (GB( 5, 6,IC),IC=1,3) / +C S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 250.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 6, 5,IC),IC=1,3) / +C S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/ +C DATA (GB( 6, 5,IC),IC=1,3) / +C S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/ +C DATA (GA( 6, 6,IC),IC=1,3) / +C S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/ +C DATA (GB( 6, 6,IC),IC=1,3) / +C S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 262.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 7, 5,IC),IC=1,3) / +C S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/ +C DATA (GB( 7, 5,IC),IC=1,3) / +C S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/ +C DATA (GA( 7, 6,IC),IC=1,3) / +C S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/ +C DATA (GB( 7, 6,IC),IC=1,3) / +C S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 275.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 8, 5,IC),IC=1,3) / +C S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/ +C DATA (GB( 8, 5,IC),IC=1,3) / +C S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/ +C DATA (GA( 8, 6,IC),IC=1,3) / +C S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/ +C DATA (GB( 8, 6,IC),IC=1,3) / +C S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 287.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 9, 5,IC),IC=1,3) / +C S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/ +C DATA (GB( 9, 5,IC),IC=1,3) / +C S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/ +C DATA (GA( 9, 6,IC),IC=1,3) / +C S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/ +C DATA (GB( 9, 6,IC),IC=1,3) / +C S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 300.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA(10, 5,IC),IC=1,3) / +C S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/ +C DATA (GB(10, 5,IC),IC=1,3) / +C S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/ +C DATA (GA(10, 6,IC),IC=1,3) / +C S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/ +C DATA (GB(10, 6,IC),IC=1,3) / +C S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 312.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA(11, 5,IC),IC=1,3) / +C S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/ +C DATA (GB(11, 5,IC),IC=1,3) / +C S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/ +C DATA (GA(11, 6,IC),IC=1,3) / +C S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/ +C DATA (GB(11, 6,IC),IC=1,3) / +C S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/ +C +C +C +C +C- WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 - +C--- G = 0.0 +C +C +C----- INTERVAL = 6 ----- T = 187.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 1,11,IC),IC=1,3) / +C S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/ +C DATA (GB( 1,11,IC),IC=1,3) / +C S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/ +C DATA (GA( 1,12,IC),IC=1,3) / +C S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/ +C DATA (GB( 1,12,IC),IC=1,3) / +C S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 200.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 2,11,IC),IC=1,3) / +C S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/ +C DATA (GB( 2,11,IC),IC=1,3) / +C S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/ +C DATA (GA( 2,12,IC),IC=1,3) / +C S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/ +C DATA (GB( 2,12,IC),IC=1,3) / +C S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 212.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 3,11,IC),IC=1,3) / +C S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/ +C DATA (GB( 3,11,IC),IC=1,3) / +C S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/ +C DATA (GA( 3,12,IC),IC=1,3) / +C S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/ +C DATA (GB( 3,12,IC),IC=1,3) / +C S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 225.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 4,11,IC),IC=1,3) / +C S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/ +C DATA (GB( 4,11,IC),IC=1,3) / +C S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/ +C DATA (GA( 4,12,IC),IC=1,3) / +C S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/ +C DATA (GB( 4,12,IC),IC=1,3) / +C S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 237.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 5,11,IC),IC=1,3) / +C S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/ +C DATA (GB( 5,11,IC),IC=1,3) / +C S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/ +C DATA (GA( 5,12,IC),IC=1,3) / +C S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/ +C DATA (GB( 5,12,IC),IC=1,3) / +C S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 250.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 6,11,IC),IC=1,3) / +C S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/ +C DATA (GB( 6,11,IC),IC=1,3) / +C S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/ +C DATA (GA( 6,12,IC),IC=1,3) / +C S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/ +C DATA (GB( 6,12,IC),IC=1,3) / +C S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 262.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 7,11,IC),IC=1,3) / +C S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/ +C DATA (GB( 7,11,IC),IC=1,3) / +C S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/ +C DATA (GA( 7,12,IC),IC=1,3) / +C S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/ +C DATA (GB( 7,12,IC),IC=1,3) / +C S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 275.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 8,11,IC),IC=1,3) / +C S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/ +C DATA (GB( 8,11,IC),IC=1,3) / +C S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/ +C DATA (GA( 8,12,IC),IC=1,3) / +C S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/ +C DATA (GB( 8,12,IC),IC=1,3) / +C S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 287.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 9,11,IC),IC=1,3) / +C S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/ +C DATA (GB( 9,11,IC),IC=1,3) / +C S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/ +C DATA (GA( 9,12,IC),IC=1,3) / +C S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/ +C DATA (GB( 9,12,IC),IC=1,3) / +C S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 300.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA(10,11,IC),IC=1,3) / +C S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/ +C DATA (GB(10,11,IC),IC=1,3) / +C S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/ +C DATA (GA(10,12,IC),IC=1,3) / +C S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/ +C DATA (GB(10,12,IC),IC=1,3) / +C S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 312.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA(11,11,IC),IC=1,3) / +C S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/ +C DATA (GB(11,11,IC),IC=1,3) / +C S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/ +C DATA (GA(11,12,IC),IC=1,3) / +C S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/ +C DATA (GB(11,12,IC),IC=1,3) / +C S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/ +C +C +C +C +C +C-- END WATER VAPOR +C +C +C-- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ---------------------- +C +C +C +C-- FIU = 0.8 + MAX(0.35,(7-IU)*0.9) , X/T, 9 +C +C----- INTERVAL = 2 ----- T = 187.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 1,13,IC),IC=1,3) / +C S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/ +C DATA (GB( 1,13,IC),IC=1,3) / +C S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/ +C DATA (GA( 1,14,IC),IC=1,3) / +C S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/ +C DATA (GB( 1,14,IC),IC=1,3) / +C S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 200.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 2,13,IC),IC=1,3) / +C S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/ +C DATA (GB( 2,13,IC),IC=1,3) / +C S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/ +C DATA (GA( 2,14,IC),IC=1,3) / +C S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/ +C DATA (GB( 2,14,IC),IC=1,3) / +C S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 212.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 3,13,IC),IC=1,3) / +C S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/ +C DATA (GB( 3,13,IC),IC=1,3) / +C S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/ +C DATA (GA( 3,14,IC),IC=1,3) / +C S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/ +C DATA (GB( 3,14,IC),IC=1,3) / +C S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 225.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 4,13,IC),IC=1,3) / +C S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/ +C DATA (GB( 4,13,IC),IC=1,3) / +C S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/ +C DATA (GA( 4,14,IC),IC=1,3) / +C S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/ +C DATA (GB( 4,14,IC),IC=1,3) / +C S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 237.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 5,13,IC),IC=1,3) / +C S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/ +C DATA (GB( 5,13,IC),IC=1,3) / +C S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/ +C DATA (GA( 5,14,IC),IC=1,3) / +C S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/ +C DATA (GB( 5,14,IC),IC=1,3) / +C S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 250.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 6,13,IC),IC=1,3) / +C S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/ +C DATA (GB( 6,13,IC),IC=1,3) / +C S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/ +C DATA (GA( 6,14,IC),IC=1,3) / +C S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/ +C DATA (GB( 6,14,IC),IC=1,3) / +C S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 262.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 7,13,IC),IC=1,3) / +C S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/ +C DATA (GB( 7,13,IC),IC=1,3) / +C S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/ +C DATA (GA( 7,14,IC),IC=1,3) / +C S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/ +C DATA (GB( 7,14,IC),IC=1,3) / +C S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 275.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 8,13,IC),IC=1,3) / +C S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/ +C DATA (GB( 8,13,IC),IC=1,3) / +C S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/ +C DATA (GA( 8,14,IC),IC=1,3) / +C S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/ +C DATA (GB( 8,14,IC),IC=1,3) / +C S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 287.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 9,13,IC),IC=1,3) / +C S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/ +C DATA (GB( 9,13,IC),IC=1,3) / +C S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/ +C DATA (GA( 9,14,IC),IC=1,3) / +C S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/ +C DATA (GB( 9,14,IC),IC=1,3) / +C S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 300.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA(10,13,IC),IC=1,3) / +C S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/ +C DATA (GB(10,13,IC),IC=1,3) / +C S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/ +C DATA (GA(10,14,IC),IC=1,3) / +C S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/ +C DATA (GB(10,14,IC),IC=1,3) / +C S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 312.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA(11,13,IC),IC=1,3) / +C S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/ +C DATA (GB(11,13,IC),IC=1,3) / +C S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/ +C DATA (GA(11,14,IC),IC=1,3) / +C S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/ +C DATA (GB(11,14,IC),IC=1,3) / +C S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/ +C +C +C +C +C +C +C +C +C +C +C-- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1) +C +C +C-- G = 0.0 +C +C +C----- INTERVAL = 4 ----- T = 187.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 1,15,IC),IC=1,3) / +C S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/ +C DATA (GB( 1,15,IC),IC=1,3) / +C S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/ +C DATA (GA( 1,16,IC),IC=1,3) / +C S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/ +C DATA (GB( 1,16,IC),IC=1,3) / +C S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 200.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 2,15,IC),IC=1,3) / +C S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/ +C DATA (GB( 2,15,IC),IC=1,3) / +C S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/ +C DATA (GA( 2,16,IC),IC=1,3) / +C S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/ +C DATA (GB( 2,16,IC),IC=1,3) / +C S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 212.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 3,15,IC),IC=1,3) / +C S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/ +C DATA (GB( 3,15,IC),IC=1,3) / +C S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/ +C DATA (GA( 3,16,IC),IC=1,3) / +C S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/ +C DATA (GB( 3,16,IC),IC=1,3) / +C S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 225.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 4,15,IC),IC=1,3) / +C S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/ +C DATA (GB( 4,15,IC),IC=1,3) / +C S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/ +C DATA (GA( 4,16,IC),IC=1,3) / +C S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/ +C DATA (GB( 4,16,IC),IC=1,3) / +C S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 237.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 5,15,IC),IC=1,3) / +C S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/ +C DATA (GB( 5,15,IC),IC=1,3) / +C S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/ +C DATA (GA( 5,16,IC),IC=1,3) / +C S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/ +C DATA (GB( 5,16,IC),IC=1,3) / +C S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 250.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 6,15,IC),IC=1,3) / +C S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/ +C DATA (GB( 6,15,IC),IC=1,3) / +C S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/ +C DATA (GA( 6,16,IC),IC=1,3) / +C S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/ +C DATA (GB( 6,16,IC),IC=1,3) / +C S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 262.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 7,15,IC),IC=1,3) / +C S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/ +C DATA (GB( 7,15,IC),IC=1,3) / +C S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/ +C DATA (GA( 7,16,IC),IC=1,3) / +C S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/ +C DATA (GB( 7,16,IC),IC=1,3) / +C S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 275.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 8,15,IC),IC=1,3) / +C S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/ +C DATA (GB( 8,15,IC),IC=1,3) / +C S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/ +C DATA (GA( 8,16,IC),IC=1,3) / +C S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/ +C DATA (GB( 8,16,IC),IC=1,3) / +C S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 287.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 9,15,IC),IC=1,3) / +C S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/ +C DATA (GB( 9,15,IC),IC=1,3) / +C S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/ +C DATA (GA( 9,16,IC),IC=1,3) / +C S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/ +C DATA (GB( 9,16,IC),IC=1,3) / +C S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 300.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA(10,15,IC),IC=1,3) / +C S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/ +C DATA (GB(10,15,IC),IC=1,3) / +C S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/ +C DATA (GA(10,16,IC),IC=1,3) / +C S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/ +C DATA (GB(10,16,IC),IC=1,3) / +C S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 312.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA(11,15,IC),IC=1,3) / +C S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/ +C DATA (GB(11,15,IC),IC=1,3) / +C S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/ +C DATA (GA(11,16,IC),IC=1,3) / +C S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/ +C DATA (GB(11,16,IC),IC=1,3) / +C S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/ +C +C ------------------------------------------------------------------ +C DATA (( XP( J,K),J=1,6), K=1,6) / +C S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03, +C S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03, +C S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03, +C S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02, +C S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03, +C S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02, +C S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03, +C S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02, +C S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02, +C S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01, +C S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03, +C S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 / + +C +C +C* 1.0 PLANCK FUNCTIONS AND GRADIENTS +C ------------------------------ +C + 100 CONTINUE +C +!cdir collapse + DO 102 JK = 1 , KFLEV+1 + DO 101 JL = 1, KDLON + PBINT(JL,JK) = 0. + 101 CONTINUE + 102 CONTINUE + DO 103 JL = 1, KDLON + PBSUIN(JL) = 0. + 103 CONTINUE +C + DO 141 JNU=1,Ninter +C +C +C* 1.1 LEVELS FROM SURFACE TO KFLEV +C ---------------------------- +C + 110 CONTINUE +C + DO 112 JK = 1 , KFLEV + DO 111 JL = 1, KDLON + ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND + ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU) + S +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU) + S ))))) + PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL) + PB(JL,JNU,JK)= ZRES(JL) + ZBLEV(JL,JK) = ZRES(JL) + ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND + ZRES2(JL)=XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU) + S +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU) + S ))))) + ZBLAY(JL,JK) = ZRES2(JL) + 111 CONTINUE + 112 CONTINUE +C +C +C* 1.2 TOP OF THE ATMOSPHERE AND SURFACE +C --------------------------------- +C + 120 CONTINUE +C + DO 121 JL = 1, KDLON + ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND + ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND + ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU) + S +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU) + S ))))) + ZRES2(JL) = XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU) + S +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU) + S ))))) + PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL) + PB(JL,JNU,KFLEV+1)= ZRES(JL) + ZBLEV(JL,KFLEV+1) = ZRES(JL) + PBTOP(JL,JNU) = ZRES(JL) + PBSUR(JL,JNU) = ZRES2(JL) + PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL) + 121 CONTINUE +C +C +C* 1.3 GRADIENTS IN SUB-LAYERS +C ----------------------- +C + 130 CONTINUE +C + DO 132 JK = 1 , KFLEV + JK2 = 2 * JK + JK1 = JK2 - 1 + DO 131 JL = 1, KDLON + PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK ) - ZBLEV(JL,JK) + PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK) + 131 CONTINUE + 132 CONTINUE +C + 141 CONTINUE +C +C* 2.0 CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS +C --------------------------------------------- +C + 200 CONTINUE +C +C + 210 CONTINUE +C + DO 211 JL=1, KDLON + ZDSTO1 = (PTL(JL,KFLEV+1)-TINTP(1)) / TSTP + IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1. ) ) ) + ZDSTOX = (PTL(JL,KFLEV+1)-TINTP(IXTOX))/TSTP + IF (ZDSTOX.LT.0.5) THEN + INDTO=IXTOX + ELSE + INDTO=IXTOX+1 + END IF + INDB(JL)=INDTO + ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP + IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) ) + ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP + IF (ZDSTX.LT.0.5) THEN + INDT=IXTX + ELSE + INDT=IXTX+1 + END IF + INDS(JL)=INDT + 211 CONTINUE +C + DO 214 JF=1,2 + DO 213 JG=1, 8 + DO 212 JL=1, KDLON + INDSU=INDS(JL) + PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF) + PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF) + INDTP=INDB(JL) + PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF) + PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF) + 212 CONTINUE + 213 CONTINUE + 214 CONTINUE +C + 220 CONTINUE +C + DO 225 JK=1,KFLEV + DO 221 JL=1, KDLON + ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP + IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) ) + ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP + IF (ZDSTX.LT.0.5) THEN + INDT=IXTX + ELSE + INDT=IXTX+1 + END IF + INDB(JL)=INDT + 221 CONTINUE +C + DO 224 JF=1,2 + DO 223 JG=1, 8 + DO 222 JL=1, KDLON + INDT=INDB(JL) + PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF) + PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF) + 222 CONTINUE + 223 CONTINUE + 224 CONTINUE + 225 CONTINUE +C +C ------------------------------------------------------------------ +C + RETURN + END + SUBROUTINE LWV_LMDAR4(KUAER,KTRAER, KLIM + R , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE + R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP + S , PCNTRB,PCTS,PFLUC) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +#include "YOMCST.h" +C +C----------------------------------------------------------------------- +C PURPOSE. +C -------- +C CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE +C FLUXES OR RADIANCES +C +C METHOD. +C ------- +C +C 1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN +C CONTRIBUTIONS BY - THE NEARBY LAYERS +C - THE DISTANT LAYERS +C - THE BOUNDARY TERMS +C 2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES. +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C----------------------------------------------------------------------- +C +C* ARGUMENTS: + INTEGER KUAER,KTRAER, KLIM +C + REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS + REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS + REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS + REAL(KIND=8) PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION + REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION + REAL(KIND=8) PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION + REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT + REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY + REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB) + REAL(KIND=8) PTAVE(KDLON,KFLEV) ! TEMPERATURE + REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL(KIND=8) PGASUR(KDLON,8,2) ! PADE APPROXIMANTS + REAL(KIND=8) PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS + REAL(KIND=8) PGATOP(KDLON,8,2) ! PADE APPROXIMANTS + REAL(KIND=8) PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS +C + REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX + REAL(KIND=8) PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM + REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES +C----------------------------------------------------------------------- +C LOCAL VARIABLES: + REAL(KIND=8) ZADJD(KDLON,KFLEV+1) + REAL(KIND=8) ZADJU(KDLON,KFLEV+1) + REAL(KIND=8) ZDBDT(KDLON,Ninter,KFLEV) + REAL(KIND=8) ZDISD(KDLON,KFLEV+1) + REAL(KIND=8) ZDISU(KDLON,KFLEV+1) +C + INTEGER jk, jl +C----------------------------------------------------------------------- +C + DO 112 JK=1,KFLEV+1 + DO 111 JL=1, KDLON + ZADJD(JL,JK)=0. + ZADJU(JL,JK)=0. + ZDISD(JL,JK)=0. + ZDISU(JL,JK)=0. + 111 CONTINUE + 112 CONTINUE +C + DO 114 JK=1,KFLEV + DO 113 JL=1, KDLON + PCTS(JL,JK)=0. + 113 CONTINUE + 114 CONTINUE +C +C* CONTRIBUTION FROM ADJACENT LAYERS +C + CALL LWVN_LMDAR4(KUAER,KTRAER + R , PABCU,PDBSL,PGA,PGB + S , ZADJD,ZADJU,PCNTRB,ZDBDT) +C* CONTRIBUTION FROM DISTANT LAYERS +C + CALL LWVD_LMDAR4(KUAER,KTRAER + R , PABCU,ZDBDT,PGA,PGB + S , PCNTRB,ZDISD,ZDISU) +C +C* EXCHANGE WITH THE BOUNDARIES +C + CALL LWVB_LMDAR4(KUAER,KTRAER, KLIM + R , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP + R , ZDISD,ZDISU,PEMIS,PPMB + R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP + S , PCTS,PFLUC) +C +C + RETURN + END + SUBROUTINE LWVB_LMDAR4(KUAER,KTRAER, KLIM + R , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP + R , PDISD,PDISU,PEMIS,PPMB + R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP + S , PCTS,PFLUC) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +#include "radopt.h" +C +C----------------------------------------------------------------------- +C PURPOSE. +C -------- +C INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL +C INTEGRATION +C +C METHOD. +C ------- +C +C 1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE +C ATMOSPHERE +C 2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND +C TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA +C 3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C Voigt lines (loop 2413 to 2427) - JJM & PhD - 01/96 +C----------------------------------------------------------------------- +C +C* 0.1 ARGUMENTS +C --------- +C + INTEGER KUAER,KTRAER, KLIM +C + REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS + REAL(KIND=8) PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS + REAL(KIND=8) PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS + REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS + REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS + REAL(KIND=8) PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION + REAL(KIND=8) PBSUI(KDLON) ! SURFACE PLANCK FUNCTION + REAL(KIND=8) PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION + REAL(KIND=8) PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS + REAL(KIND=8) PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS + REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY + REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! PRESSURE MB + REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL(KIND=8) PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS + REAL(KIND=8) PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS + REAL(KIND=8) PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS + REAL(KIND=8) PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS +C + REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES + REAL(KIND=8) PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM +C +C* LOCAL VARIABLES: +C + REAL(KIND=8) ZBGND(KDLON) + REAL(KIND=8) ZFD(KDLON) + REAL(KIND=8) ZFN10(KDLON) + REAL(KIND=8) ZFU(KDLON) + REAL(KIND=8) ZTT(KDLON,NTRA) + REAL(KIND=8) ZTT1(KDLON,NTRA) + REAL(KIND=8) ZTT2(KDLON,NTRA) + REAL(KIND=8) ZUU(KDLON,NUA) + REAL(KIND=8) ZCNSOL(KDLON) + REAL(KIND=8) ZCNTOP(KDLON) +C + INTEGER jk, jl, ja + INTEGER jstra, jstru + INTEGER ind1, ind2, ind3, ind4, in, jlim + REAL(KIND=8) zctstr +C----------------------------------------------------------------------- +C +C* 1. INITIALIZATION +C -------------- +C + 100 CONTINUE +C +C +C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS +C --------------------------------- +C + 120 CONTINUE +C + DO 122 JA=1,NTRA + DO 121 JL=1, KDLON + ZTT (JL,JA)=1.0 + ZTT1(JL,JA)=1.0 + ZTT2(JL,JA)=1.0 + 121 CONTINUE + 122 CONTINUE +C + DO 124 JA=1,NUA + DO 123 JL=1, KDLON + ZUU(JL,JA)=1.0 + 123 CONTINUE + 124 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 2. VERTICAL INTEGRATION +C -------------------- +C + 200 CONTINUE +C + IND1=0 + IND3=0 + IND4=1 + IND2=1 +C +C +C* 2.3 EXCHANGE WITH TOP OF THE ATMOSPHERE +C ----------------------------------- +C + 230 CONTINUE +C + DO 235 JK = 1 , KFLEV + IN=(JK-1)*NG1P1+1 +C + DO 232 JA=1,KUAER + DO 231 JL=1, KDLON + ZUU(JL,JA)=PABCU(JL,JA,IN) + 231 CONTINUE + 232 CONTINUE +C +C + CALL LWTT_LMDAR4(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT) +C + DO 234 JL = 1, KDLON + ZCNTOP(JL)=PBTOP(JL,1)*ZTT(JL,1) *ZTT(JL,10) + 2 +PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) + 3 +PBTOP(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) + 4 +PBTOP(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) + 5 +PBTOP(JL,5)*ZTT(JL,3) *ZTT(JL,14) + 6 +PBTOP(JL,6)*ZTT(JL,6) *ZTT(JL,15) + ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK) + PFLUC(JL,2,JK)=ZFD(JL) + 234 CONTINUE +C + 235 CONTINUE +C + JK = KFLEV+1 + IN=(JK-1)*NG1P1+1 +C + DO 236 JL = 1, KDLON + ZCNTOP(JL)= PBTOP(JL,1) + 1 + PBTOP(JL,2) + 2 + PBTOP(JL,3) + 3 + PBTOP(JL,4) + 4 + PBTOP(JL,5) + 5 + PBTOP(JL,6) + ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK) + PFLUC(JL,2,JK)=ZFD(JL) + 236 CONTINUE +C +C* 2.4 COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA +C --------------------------------------- +C + 240 CONTINUE +C +C +C* 2.4.1 INITIALIZATION +C -------------- +C + 2410 CONTINUE +C + JLIM = KFLEV +C + IF (.NOT.LEVOIGT) THEN + DO 2412 JK = KFLEV,1,-1 + IF(PPMB(1,JK).LT.10.0) THEN + JLIM=JK + ENDIF + 2412 CONTINUE + ENDIF + KLIM=JLIM +C + IF (.NOT.LEVOIGT) THEN + DO 2414 JA=1,KTRAER + DO 2413 JL=1, KDLON + ZTT1(JL,JA)=1.0 + 2413 CONTINUE + 2414 CONTINUE +C +C* 2.4.2 LOOP OVER LAYERS ABOVE 10 HPA +C ----------------------------- +C + 2420 CONTINUE +C + DO 2427 JSTRA = KFLEV,JLIM,-1 + JSTRU=(JSTRA-1)*NG1P1+1 +C + DO 2423 JA=1,KUAER + DO 2422 JL=1, KDLON + ZUU(JL,JA)=PABCU(JL,JA,JSTRU) + 2422 CONTINUE + 2423 CONTINUE +C +C + CALL LWTT_LMDAR4(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT) +C + DO 2424 JL = 1, KDLON + ZCTSTR = + 1 (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1)) + 1 *(ZTT1(JL,1) *ZTT1(JL,10) + 1 - ZTT (JL,1) *ZTT (JL,10)) + 2 +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1)) + 2 *(ZTT1(JL,2)*ZTT1(JL,7)*ZTT1(JL,11) + 2 - ZTT (JL,2)*ZTT (JL,7)*ZTT (JL,11)) + 3 +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1)) + 3 *(ZTT1(JL,4)*ZTT1(JL,8)*ZTT1(JL,12) + 3 - ZTT (JL,4)*ZTT (JL,8)*ZTT (JL,12)) + 4 +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1)) + 4 *(ZTT1(JL,5)*ZTT1(JL,9)*ZTT1(JL,13) + 4 - ZTT (JL,5)*ZTT (JL,9)*ZTT (JL,13)) + 5 +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1)) + 5 *(ZTT1(JL,3) *ZTT1(JL,14) + 5 - ZTT (JL,3) *ZTT (JL,14)) + 6 +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1)) + 6 *(ZTT1(JL,6) *ZTT1(JL,15) + 6 - ZTT (JL,6) *ZTT (JL,15)) + PCTS(JL,JSTRA)=ZCTSTR*0.5 + 2424 CONTINUE + DO 2426 JA=1,KTRAER + DO 2425 JL=1, KDLON + ZTT1(JL,JA)=ZTT(JL,JA) + 2425 CONTINUE + 2426 CONTINUE + 2427 CONTINUE + ENDIF +C Mise a zero de securite pour PCTS en cas de LEVOIGT + IF(LEVOIGT)THEN + DO 2429 JSTRA = 1,KFLEV + DO 2428 JL = 1, KDLON + PCTS(JL,JSTRA)=0. + 2428 CONTINUE + 2429 CONTINUE + ENDIF +C +C +C* 2.5 EXCHANGE WITH LOWER LIMIT +C ------------------------- +C + 250 CONTINUE +C + DO 251 JL = 1, KDLON + ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL)) + S *PFLUC(JL,2,1)-PBINT(JL,1) + 251 CONTINUE +C + JK = 1 + IN=(JK-1)*NG1P1+1 +C + DO 252 JL = 1, KDLON + ZCNSOL(JL)=PBSUR(JL,1) + 1 +PBSUR(JL,2) + 2 +PBSUR(JL,3) + 3 +PBSUR(JL,4) + 4 +PBSUR(JL,5) + 5 +PBSUR(JL,6) + ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL) + ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK) + PFLUC(JL,1,JK)=ZFU(JL) + 252 CONTINUE +C + DO 257 JK = 2 , KFLEV+1 + IN=(JK-1)*NG1P1+1 +C +C + DO 255 JA=1,KUAER + DO 254 JL=1, KDLON + ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN) + 254 CONTINUE + 255 CONTINUE +C +C + CALL LWTT_LMDAR4(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT) +C + DO 256 JL = 1, KDLON + ZCNSOL(JL)=PBSUR(JL,1)*ZTT(JL,1) *ZTT(JL,10) + 2 +PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) + 3 +PBSUR(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) + 4 +PBSUR(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) + 5 +PBSUR(JL,5)*ZTT(JL,3) *ZTT(JL,14) + 6 +PBSUR(JL,6)*ZTT(JL,6) *ZTT(JL,15) + ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL) + ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK) + PFLUC(JL,1,JK)=ZFU(JL) + 256 CONTINUE +C +C + 257 CONTINUE +C +C +C +C* 2.7 CLEAR-SKY FLUXES +C ---------------- +C + 270 CONTINUE +C + IF (.NOT.LEVOIGT) THEN + DO 271 JL = 1, KDLON + ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM) + 271 CONTINUE + DO 273 JK = JLIM+1,KFLEV+1 + DO 272 JL = 1, KDLON + ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1) + PFLUC(JL,1,JK) = ZFN10(JL) + PFLUC(JL,2,JK) = 0. + 272 CONTINUE + 273 CONTINUE + ENDIF +C +C ------------------------------------------------------------------ +C + RETURN + END + SUBROUTINE LWVD_LMDAR4(KUAER,KTRAER + S , PABCU,PDBDT + R , PGA,PGB + S , PCNTRB,PDISD,PDISU) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +C +C----------------------------------------------------------------------- +C PURPOSE. +C -------- +C CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS +C +C METHOD. +C ------- +C +C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE +C CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C----------------------------------------------------------------------- +C* ARGUMENTS: +C + INTEGER KUAER,KTRAER +C + REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS + REAL(KIND=8) PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT + REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS +C + REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX + REAL(KIND=8) PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS + REAL(KIND=8) PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS +C +C* LOCAL VARIABLES: +C + REAL(KIND=8) ZGLAYD(KDLON) + REAL(KIND=8) ZGLAYU(KDLON) + REAL(KIND=8) ZTT(KDLON,NTRA) + REAL(KIND=8) ZTT1(KDLON,NTRA) + REAL(KIND=8) ZTT2(KDLON,NTRA) +C + INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2 + INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2 + INTEGER ind1, ind2, ind3, ind4, itt + REAL(KIND=8) zww, zdzxdg, zdzxmg +C +C* 1. INITIALIZATION +C -------------- +C + 100 CONTINUE +C +C* 1.1 INITIALIZE LAYER CONTRIBUTIONS +C ------------------------------ +C + 110 CONTINUE +C + DO 112 JK = 1, KFLEV+1 + DO 111 JL = 1, KDLON + PDISD(JL,JK) = 0. + PDISU(JL,JK) = 0. + 111 CONTINUE + 112 CONTINUE +C +C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS +C --------------------------------- +C + 120 CONTINUE +C +C + DO 122 JA = 1, NTRA + DO 121 JL = 1, KDLON + ZTT (JL,JA) = 1.0 + ZTT1(JL,JA) = 1.0 + ZTT2(JL,JA) = 1.0 + 121 CONTINUE + 122 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 2. VERTICAL INTEGRATION +C -------------------- +C + 200 CONTINUE +C + IND1=0 + IND3=0 + IND4=1 + IND2=1 +C +C +C* 2.2 CONTRIBUTION FROM DISTANT LAYERS +C --------------------------------- +C + 220 CONTINUE +C +C +C* 2.2.1 DISTANT AND ABOVE LAYERS +C ------------------------ +C + 2210 CONTINUE +C +C +C +C* 2.2.2 FIRST UPPER LEVEL +C ----------------- +C + 2220 CONTINUE +C + DO 225 JK = 1 , KFLEV-1 + IKP1=JK+1 + IKN=(JK-1)*NG1P1+1 + IKD1= JK *NG1P1+1 +C + CALL LWTTM_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK) + 2 , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1) +C +C +C +C* 2.2.3 HIGHER UP +C --------- +C + 2230 CONTINUE +C + ITT=1 + DO 224 JKJ=IKP1,KFLEV + IF(ITT.EQ.1) THEN + ITT=2 + ELSE + ITT=1 + ENDIF + IKJP1=JKJ+1 + IKD2= JKJ *NG1P1+1 +C + IF(ITT.EQ.1) THEN + CALL LWTTM_LMDAR4(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ) + 2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1) + ELSE + CALL LWTTM_LMDAR4(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ) + 2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2) + ENDIF +C + DO 2235 JA = 1, KTRAER + DO 2234 JL = 1, KDLON + ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5 + 2234 CONTINUE + 2235 CONTINUE +C + DO 2236 JL = 1, KDLON + ZWW=PDBDT(JL,1,JKJ)*ZTT(JL,1) *ZTT(JL,10) + S +PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) + S +PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) + S +PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) + S +PDBDT(JL,5,JKJ)*ZTT(JL,3) *ZTT(JL,14) + S +PDBDT(JL,6,JKJ)*ZTT(JL,6) *ZTT(JL,15) + ZGLAYD(JL)=ZWW + ZDZXDG=ZGLAYD(JL) + PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG + PCNTRB(JL,JK,IKJP1)=ZDZXDG + 2236 CONTINUE +C +C + 224 CONTINUE + 225 CONTINUE +C +C +C* 2.2.4 DISTANT AND BELOW LAYERS +C ------------------------ +C + 2240 CONTINUE +C +C +C +C* 2.2.5 FIRST LOWER LEVEL +C ----------------- +C + 2250 CONTINUE +C + DO 228 JK=3,KFLEV+1 + IKN=(JK-1)*NG1P1+1 + IKM1=JK-1 + IKJ=JK-2 + IKU1= IKJ *NG1P1+1 +C +C + CALL LWTTM_LMDAR4(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ) + 2 , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1) +C +C +C +C* 2.2.6 DOWN BELOW +C ---------- +C + 2260 CONTINUE +C + ITT=1 + DO 227 JLK=1,IKJ + IF(ITT.EQ.1) THEN + ITT=2 + ELSE + ITT=1 + ENDIF + IJKL=IKM1-JLK + IKU2=(IJKL-1)*NG1P1+1 +C +C + IF(ITT.EQ.1) THEN + CALL LWTTM_LMDAR4(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL) + 2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1) + ELSE + CALL LWTTM_LMDAR4(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL) + 2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2) + ENDIF +C + DO 2265 JA = 1, KTRAER + DO 2264 JL = 1, KDLON + ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5 + 2264 CONTINUE + 2265 CONTINUE +C + DO 2266 JL = 1, KDLON + ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1) *ZTT(JL,10) + S +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) + S +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) + S +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) + S +PDBDT(JL,5,IJKL)*ZTT(JL,3) *ZTT(JL,14) + S +PDBDT(JL,6,IJKL)*ZTT(JL,6) *ZTT(JL,15) + ZGLAYU(JL)=ZWW + ZDZXMG=ZGLAYU(JL) + PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG + PCNTRB(JL,JK,IJKL)=ZDZXMG + 2266 CONTINUE +C +C + 227 CONTINUE + 228 CONTINUE +C + RETURN + END + SUBROUTINE LWVN_LMDAR4(KUAER,KTRAER + R , PABCU,PDBSL,PGA,PGB + S , PADJD,PADJU,PCNTRB,PDBDT) + USE dimphy + USE radiation_AR4_param, only : WG1 + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +C +C----------------------------------------------------------------------- +C PURPOSE. +C -------- +C CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS +C TO GIVE LONGWAVE FLUXES OR RADIANCES +C +C METHOD. +C ------- +C +C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE +C CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C----------------------------------------------------------------------- +C +C* ARGUMENTS: +C + INTEGER KUAER,KTRAER +C + REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS + REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT + REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS +C + REAL(KIND=8) PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS + REAL(KIND=8) PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS + REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX + REAL(KIND=8) PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT +C +C* LOCAL ARRAYS: +C + REAL(KIND=8) ZGLAYD(KDLON) + REAL(KIND=8) ZGLAYU(KDLON) + REAL(KIND=8) ZTT(KDLON,NTRA) + REAL(KIND=8) ZTT1(KDLON,NTRA) + REAL(KIND=8) ZTT2(KDLON,NTRA) + REAL(KIND=8) ZUU(KDLON,NUA) +C + INTEGER jk, jl, ja, im12, ind, inu, ixu, jg + INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu + REAL(KIND=8) zwtr +c + +C----------------------------------------------------------------------- +C +C* 1. INITIALIZATION +C -------------- +C + 100 CONTINUE +C +C* 1.1 INITIALIZE LAYER CONTRIBUTIONS +C ------------------------------ +C + 110 CONTINUE +C + DO 112 JK = 1 , KFLEV+1 + DO 111 JL = 1, KDLON + PADJD(JL,JK) = 0. + PADJU(JL,JK) = 0. + 111 CONTINUE + 112 CONTINUE +C +C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS +C --------------------------------- +C + 120 CONTINUE +C + DO 122 JA = 1 , NTRA + DO 121 JL = 1, KDLON + ZTT (JL,JA) = 1.0 + ZTT1(JL,JA) = 1.0 + ZTT2(JL,JA) = 1.0 + 121 CONTINUE + 122 CONTINUE +C + DO 124 JA = 1 , NUA + DO 123 JL = 1, KDLON + ZUU(JL,JA) = 0. + 123 CONTINUE + 124 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 2. VERTICAL INTEGRATION +C -------------------- +C + 200 CONTINUE +C +C +C* 2.1 CONTRIBUTION FROM ADJACENT LAYERS +C --------------------------------- +C + 210 CONTINUE +C + DO 215 JK = 1 , KFLEV +C +C* 2.1.1 DOWNWARD LAYERS +C --------------- +C + 2110 CONTINUE +C + IM12 = 2 * (JK - 1) + IND = (JK - 1) * NG1P1 + 1 + IXD = IND + INU = JK * NG1P1 + 1 + IXU = IND +C + DO 2111 JL = 1, KDLON + ZGLAYD(JL) = 0. + ZGLAYU(JL) = 0. + 2111 CONTINUE +C + DO 213 JG = 1 , NG1 + IBS = IM12 + JG + IDD = IXD + JG + DO 2113 JA = 1 , KUAER + DO 2112 JL = 1, KDLON + ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD) + 2112 CONTINUE + 2113 CONTINUE +C +C + CALL LWTT_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT) +C + DO 2114 JL = 1, KDLON + ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1) *ZTT(JL,10) + S +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) + S +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) + S +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) + S +PDBSL(JL,5,IBS)*ZTT(JL,3) *ZTT(JL,14) + S +PDBSL(JL,6,IBS)*ZTT(JL,6) *ZTT(JL,15) + ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG) + 2114 CONTINUE +C +C* 2.1.2 DOWNWARD LAYERS +C --------------- +C + 2120 CONTINUE +C + IMU = IXU + JG + DO 2122 JA = 1 , KUAER + DO 2121 JL = 1, KDLON + ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU) + 2121 CONTINUE + 2122 CONTINUE +C +C + CALL LWTT_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT) +C + DO 2123 JL = 1, KDLON + ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1) *ZTT(JL,10) + S +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) + S +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) + S +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) + S +PDBSL(JL,5,IBS)*ZTT(JL,3) *ZTT(JL,14) + S +PDBSL(JL,6,IBS)*ZTT(JL,6) *ZTT(JL,15) + ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG) + 2123 CONTINUE +C + 213 CONTINUE +C + DO 214 JL = 1, KDLON + PADJD(JL,JK) = ZGLAYD(JL) + PCNTRB(JL,JK,JK+1) = ZGLAYD(JL) + PADJU(JL,JK+1) = ZGLAYU(JL) + PCNTRB(JL,JK+1,JK) = ZGLAYU(JL) + PCNTRB(JL,JK ,JK) = 0.0 + 214 CONTINUE +C + 215 CONTINUE +C + DO 218 JK = 1 , KFLEV + JK2 = 2 * JK + JK1 = JK2 - 1 + DO 217 JNU = 1 , Ninter + DO 216 JL = 1, KDLON + PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2) + 216 CONTINUE + 217 CONTINUE + 218 CONTINUE +C + RETURN +C + END + SUBROUTINE LWTT_LMDAR4(PGA,PGB,PUU, PTT) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +C +C----------------------------------------------------------------------- +C PURPOSE. +C -------- +C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE +C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL +C INTERVALS. +C +C METHOD. +C ------- +C +C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE +C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM. +C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL. +C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN +C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT. +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 88-12-15 +C +C----------------------------------------------------------------------- + REAL(KIND=8) O1H, O2H + PARAMETER (O1H=2230.) + PARAMETER (O2H=100.) + REAL(KIND=8) RPIALF0 + PARAMETER (RPIALF0=2.0) +C +C* ARGUMENTS: +C + REAL(KIND=8) PUU(KDLON,NUA) + REAL(KIND=8) PTT(KDLON,NTRA) + REAL(KIND=8) PGA(KDLON,8,2) + REAL(KIND=8) PGB(KDLON,8,2) +C +C* LOCAL VARIABLES: +C + REAL(KIND=8) zz, zxd, zxn + REAL(KIND=8) zpu, zpu10, zpu11, zpu12, zpu13 + REAL(KIND=8) zeu, zeu10, zeu11, zeu12, zeu13 + REAL(KIND=8) zx, zy, zsq1, zsq2, zvxy, zuxy + REAL(KIND=8) zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o + REAL(KIND=8) zsqn21, zodn21, zsqh42, zodh42 + REAL(KIND=8) zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12 + REAL(KIND=8) zuu11, zuu12, za11, za12 + INTEGER jl, ja +C ------------------------------------------------------------------ +C +C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION +C ----------------------------------------------- +C + 100 CONTINUE +C +C +!cdir collapse + DO 130 JA = 1 , 8 + DO 120 JL = 1, KDLON + ZZ =SQRT(PUU(JL,JA)) +c ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1)) +c ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) ) +c PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1) + ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ ) + ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) ) + PTT(JL,JA)=ZXN /ZXD + 120 CONTINUE + 130 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS +C --------------------------------------------------- +C + 200 CONTINUE +C + DO 201 JL = 1, KDLON + PTT(JL, 9) = PTT(JL, 8) +C +C- CONTINUUM ABSORPTION: E- AND P-TYPE +C + ZPU = 0.002 * PUU(JL,10) + ZPU10 = 112. * ZPU + ZPU11 = 6.25 * ZPU + ZPU12 = 5.00 * ZPU + ZPU13 = 80.0 * ZPU + ZEU = PUU(JL,11) + ZEU10 = 12. * ZEU + ZEU11 = 6.25 * ZEU + ZEU12 = 5.00 * ZEU + ZEU13 = 80.0 * ZEU +C +C- OZONE ABSORPTION +C + ZX = PUU(JL,12) + ZY = PUU(JL,13) + ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY) + ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1. + ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1. + ZVXY = RPIALF0 * ZY / (2. * ZX) + ZAERCN = PUU(JL,17) + ZEU12 + ZPU12 + ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN ) + ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN ) +C +C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12) +C +C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1 +C +c NEXOTIC=1 +c IF (NEXOTIC.EQ.1) THEN + ZXCH4 = PUU(JL,19) + ZYCH4 = PUU(JL,20) + ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4) + ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1. + ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4) + ZODH41 = ZVXY * ZSQH41 +C +C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1 +C + ZXN2O = PUU(JL,21) + ZYN2O = PUU(JL,22) + ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O) + ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1. + ZVXY = 0.416 * ZYN2O / (2. * ZXN2O) + ZODN21 = ZVXY * ZSQN21 +C +C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1 +C + ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4) + ZSQH42 = SQRT(1. + 400. * ZUXY) - 1. + ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4) + ZODH42 = ZVXY * ZSQH42 +C +C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1 +C + ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O) + ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1. + ZVXY = 0.197 * ZYN2O / (2. * ZXN2O) + ZODN22 = ZVXY * ZSQN22 +C +C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1 +C + ZA11 = 2. * PUU(JL,23) * 4.404E+05 + ZTTF11 = 1. - ZA11 * 0.003225 +C +C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1 +C + ZA12 = 2. * PUU(JL,24) * 6.7435E+05 + ZTTF12 = 1. - ZA12 * 0.003225 +C + ZUU11 = - PUU(JL,15) - ZEU10 - ZPU10 + ZUU12 = - PUU(JL,16) - ZEU11 - ZPU11 - ZODH41 - ZODN21 + PTT(JL,10) = EXP( - PUU(JL,14) ) + PTT(JL,11) = EXP( ZUU11 ) + PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12 + PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2 + PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 ) + PTT(JL,15) = EXP ( - PUU(JL,14) - ZODH42 - ZODN22 ) + 201 CONTINUE +C + RETURN + END + SUBROUTINE LWTTM_LMDAR4(PGA,PGB,PUU1,PUU2, PTT) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +C +C ------------------------------------------------------------------ +C PURPOSE. +C -------- +C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE +C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL +C INTERVALS. +C +C METHOD. +C ------- +C +C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE +C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM. +C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL. +C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN +C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT. +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 88-12-15 +C +C----------------------------------------------------------------------- + REAL(KIND=8) O1H, O2H + PARAMETER (O1H=2230.) + PARAMETER (O2H=100.) + REAL(KIND=8) RPIALF0 + PARAMETER (RPIALF0=2.0) +C +C* ARGUMENTS: +C + REAL(KIND=8) PGA(KDLON,8,2) ! PADE APPROXIMANTS + REAL(KIND=8) PGB(KDLON,8,2) ! PADE APPROXIMANTS + REAL(KIND=8) PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1 + REAL(KIND=8) PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2 + REAL(KIND=8) PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS +C +C* LOCAL VARIABLES: +C + INTEGER ja, jl + REAL(KIND=8) zz, zxd, zxn + REAL(KIND=8) zpu, zpu10, zpu11, zpu12, zpu13 + REAL(KIND=8) zeu, zeu10, zeu11, zeu12, zeu13 + REAL(KIND=8) zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2 + REAL(KIND=8) zxch4, zych4, zsqh41, zodh41 + REAL(KIND=8) zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42 + REAL(KIND=8) zsqn22, zodn22, za11, zttf11, za12, zttf12 + REAL(KIND=8) zuu11, zuu12 +C ------------------------------------------------------------------ +C +C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION +C ----------------------------------------------- +C + 100 CONTINUE +C +C + +!CDIR ON_ADB(PUU1) +!CDIR ON_ADB(PUU2) +!CDIR COLLAPSE + DO 130 JA = 1 , 8 + DO 120 JL = 1, KDLON + ZZ =SQRT(PUU1(JL,JA) - PUU2(JL,JA)) + ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ ) + ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) ) + PTT(JL,JA)=ZXN /ZXD + 120 CONTINUE + 130 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS +C --------------------------------------------------- +C + 200 CONTINUE +C + DO 201 JL = 1, KDLON + PTT(JL, 9) = PTT(JL, 8) +C +C- CONTINUUM ABSORPTION: E- AND P-TYPE +C + ZPU = 0.002 * (PUU1(JL,10) - PUU2(JL,10)) + ZPU10 = 112. * ZPU + ZPU11 = 6.25 * ZPU + ZPU12 = 5.00 * ZPU + ZPU13 = 80.0 * ZPU + ZEU = (PUU1(JL,11) - PUU2(JL,11)) + ZEU10 = 12. * ZEU + ZEU11 = 6.25 * ZEU + ZEU12 = 5.00 * ZEU + ZEU13 = 80.0 * ZEU +C +C- OZONE ABSORPTION +C + ZX = (PUU1(JL,12) - PUU2(JL,12)) + ZY = (PUU1(JL,13) - PUU2(JL,13)) + ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY) + ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1. + ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1. + ZVXY = RPIALF0 * ZY / (2. * ZX) + ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12 + ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN ) + ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN ) +C +C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12) +C +C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1 +C + ZXCH4 = (PUU1(JL,19) - PUU2(JL,19)) + ZYCH4 = (PUU1(JL,20) - PUU2(JL,20)) + ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4) + ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1. + ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4) + ZODH41 = ZVXY * ZSQH41 +C +C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1 +C + ZXN2O = (PUU1(JL,21) - PUU2(JL,21)) + ZYN2O = (PUU1(JL,22) - PUU2(JL,22)) + ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O) + ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1. + ZVXY = 0.416 * ZYN2O / (2. * ZXN2O) + ZODN21 = ZVXY * ZSQN21 +C +C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1 +C + ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4) + ZSQH42 = SQRT(1. + 400. * ZUXY) - 1. + ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4) + ZODH42 = ZVXY * ZSQH42 +C +C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1 +C + ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O) + ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1. + ZVXY = 0.197 * ZYN2O / (2. * ZXN2O) + ZODN22 = ZVXY * ZSQN22 +C +C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1 +C + ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05 + ZTTF11 = 1. - ZA11 * 0.003225 +C +C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1 +C + ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05 + ZTTF12 = 1. - ZA12 * 0.003225 +C + ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10 + ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 - + S ZODH41 - ZODN21 + PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) ) + PTT(JL,11) = EXP( ZUU11 ) + PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12 + PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2 + PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 ) + PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 ) + 201 CONTINUE +C + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radiation_AR4_param.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radiation_AR4_param.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radiation_AR4_param.F90 (revision 1280) @@ -0,0 +1,240 @@ +MODULE radiation_AR4_param + + REAL*8, parameter :: ZPDH2O = 0.8 + REAL*8, parameter :: ZPDUMG = 0.75 + REAL*8, parameter :: ZPRH2O = 30000.0 + REAL*8, parameter :: ZPRUMG = 30000.0 + REAL*8, parameter :: RTDH2O = 0.40 + REAL*8, parameter :: RTDUMG = 0.375 + REAL*8, parameter :: RTH2O = 240.0 + REAL*8, parameter :: RTUMG = 240.0 + + REAL*8, dimension(2), parameter :: WG1 = (/1.0, 1.0/) + REAL*8, dimension(11), parameter :: TINTP = (/ 187.5, 200., 212.5, 225., 237.5, 250., 262.5, 275., 287.5, 300., 312.5 /) + + real*8, dimension(11,16,3), parameter :: GA = reshape ( (/ & + 0.63499072E-02, 0.65566348E-02, 0.67849730E-02, 0.70481947E-02, 0.73585943E-02, 0.77242818E-02, 0.81472693E-02, 0.86227527E-02,& + 0.91396814E-02, 0.96825438E-02, 0.10233955E-01, 0.77266491E-02, 0.81323287E-02, 0.86507620E-02, 0.92776391E-02, 0.99806312E-02,& + 0.10709803E-01, 0.11414739E-01, 0.12058772E-01, 0.12623992E-01, 0.13108146E-01, 0.13518390E-01, 0.11644593E+01, 0.11747203E+01,& + 0.11837872E+01, 0.11918561E+01, 0.11990757E+01, 0.12055643E+01, 0.12114186E+01, 0.12167192E+01, 0.12215344E+01, 0.12259226E+01,& + 0.12299344E+01, 0.12006968E+01, 0.12108196E+01, 0.12196717E+01, 0.12274493E+01, 0.12343189E+01, 0.12404147E+01, 0.12458431E+01,& + 0.12506907E+01, 0.12550299E+01, 0.12589256E+01, 0.12624402E+01, 0.15750172E+00, 0.16174076E+00, 0.16548628E+00, 0.16881124E+00,& + 0.17177839E+00, 0.17443933E+00, 0.17683622E+00, 0.17900375E+00, 0.18097099E+00, 0.18276283E+00, 0.18440117E+00, 0.17770551E+00,& + 0.18176757E+00, 0.18527967E+00, 0.18833348E+00, 0.19100108E+00, 0.19334122E+00, 0.19540288E+00, 0.19722732E+00, 0.19884918E+00,& + 0.20029696E+00, 0.20159300E+00, 0.10192131E+02, 0.97258602E+01, 0.92992890E+01, 0.89154021E+01, 0.85730084E+01, 0.82685838E+01,& + 0.79978921E+01, 0.77568055E+01, 0.75416266E+01, 0.73491694E+01, 0.71767400E+01, 0.92439050E+01, 0.87567422E+01, 0.83270144E+01,& + 0.79528337E+01, 0.76286839E+01, 0.73477879E+01, 0.71035818E+01, 0.68903312E+01, 0.67032875E+01, 0.65386461E+01, 0.63934377E+01,& + 0.24870635E+02, 0.24725591E+02, 0.24600320E+02, 0.24487300E+02, 0.24384935E+02, 0.24292341E+02, 0.24208572E+02, 0.24132642E+02,& + 0.24063614E+02, 0.24000649E+02, 0.23943021E+02, 0.24586283E+02, 0.24441465E+02, 0.24311657E+02, 0.24196167E+02, 0.24093406E+02,& + 0.24001597E+02, 0.23919098E+02, 0.23844511E+02, 0.23776708E+02, 0.23714816E+02, 0.23658197E+02, 0.11990218E+02, 0.10904073E+02,& + 0.89126838E+01, 0.85622405E+01, 0.94892164E+01, 0.13580937E+02,-0.32050918E+03,-0.37133165E+01, 0.18890836E+00, 0.14209226E+01,& + 0.19817679E+01, 0.79709806E+01, 0.75400737E+01, 0.81804377E+01, 0.10564339E+02, 0.46896789E+02,-0.30926524E+01, 0.85742941E+00,& + 0.19164038E+01, 0.23513199E+01, 0.25566644E+01, 0.26555181E+01, 0.87668459E-01, 0.83754276E-01, 0.80460283E-01, 0.77659686E-01,& + 0.75257056E-01, 0.73179175E-01, 0.71369063E-01, 0.69781812E-01, 0.68381606E-01, 0.67139539E-01, 0.66032012E-01, 0.74878820E-01,& + 0.71650966E-01, 0.68979615E-01, 0.66745345E-01, 0.64857571E-01, 0.63248495E-01, 0.61866970E-01, 0.60673632E-01, 0.59637277E-01,& + 0.58732178E-01, 0.57936092E-01, 0.13230067E+02, 0.13213564E+02, 0.13209140E+02, 0.13213894E+02, 0.13225963E+02, 0.13243806E+02,& + 0.13266104E+02, 0.13291782E+02, 0.13319961E+02, 0.13349927E+02, 0.13381108E+02, 0.13183816E+02, 0.13189991E+02, 0.13209485E+02,& + 0.13238789E+02, 0.13275017E+02, 0.13316096E+02, 0.13360555E+02, 0.13407324E+02, 0.13455544E+02, 0.13504450E+02, 0.13553282E+02,& +-0.99506586E-03,-0.10184169E-02,-0.10404730E-02,-0.10621792E-02,-0.10847662E-02,-0.11094726E-02,-0.11372949E-02,-0.11687683E-02,& +-0.12038314E-02,-0.12418367E-02,-0.12817135E-02,-0.11661515E-02,-0.11886130E-02,-0.12139929E-02,-0.12445811E-02,-0.12807672E-02,& +-0.13208251E-02,-0.13619034E-02,-0.14014165E-02,-0.14378639E-02,-0.14708488E-02,-0.15006791E-02, 0.41243390E+00, 0.43407282E+00,& + 0.45331413E+00, 0.47048604E+00, 0.48586286E+00, 0.49968044E+00, 0.51214132E+00, 0.52341830E+00, 0.53365803E+00, 0.54298448E+00,& + 0.55150227E+00, 0.48318936E+00, 0.50501827E+00, 0.52409502E+00, 0.54085277E+00, 0.55565422E+00, 0.56878618E+00, 0.58047395E+00,& + 0.59089894E+00, 0.60021475E+00, 0.60856112E+00, 0.61607594E+00,-0.22159303E-01,-0.22748917E-01,-0.23269898E-01,-0.23732392E-01,& +-0.24145123E-01,-0.24515269E-01,-0.24848690E-01,-0.25150210E-01,-0.25423873E-01,-0.25673139E-01,-0.25901055E-01,-0.24972399E-01,& +-0.25537247E-01,-0.26025624E-01,-0.26450280E-01,-0.26821236E-01,-0.27146657E-01,-0.27433354E-01,-0.27687065E-01,-0.27912608E-01,& +-0.28113944E-01,-0.28294180E-01, 0.80737799E+01, 0.79171158E+01, 0.77609605E+01, 0.76087371E+01, 0.74627112E+01, 0.73239981E+01,& + 0.71929934E+01, 0.70697065E+01, 0.69539626E+01, 0.68455144E+01, 0.67441020E+01, 0.77425778E+01, 0.75443460E+01, 0.73526151E+01,& + 0.71711188E+01, 0.70015571E+01, 0.68442532E+01, 0.66987996E+01, 0.65644820E+01, 0.64405267E+01, 0.63262376E+01, 0.62210701E+01,& + 0.10542131E+02, 0.10515895E+02, 0.10492949E+02, 0.10472049E+02, 0.10452961E+02, 0.10435562E+02, 0.10419710E+02, 0.10405247E+02,& + 0.10392022E+02, 0.10379892E+02, 0.10368736E+02, 0.10490353E+02, 0.10463512E+02, 0.10439183E+02, 0.10417324E+02, 0.10397704E+02,& + 0.10380038E+02, 0.10364052E+02, 0.10349509E+02, 0.10336215E+02, 0.10324018E+02, 0.10312808E+02,-0.12823142E+01,-0.10571588E+01,& +-0.74864953E+00,-0.58705980E+00,-0.49305772E+00,-0.51461431E+00, 0.12373350E+02, 0.44809588E+00, 0.46548918E+00, 0.59121475E+00,& + 0.74676119E+00,-0.74805226E+00,-0.56252739E+00,-0.46188072E+00,-0.40712065E+00,-0.15295996E+01, 0.43555255E+00, 0.50380874E+00,& + 0.68537352E+00, 0.89437630E+00, 0.11127003E+01, 0.13329782E+01, 0.13845511E+01, 0.13187042E+01, 0.12644396E+01, 0.12191543E+01,& + 0.11809511E+01, 0.11484154E+01, 0.11204723E+01, 0.10962918E+01, 0.10752229E+01, 0.10567474E+01, 0.10404465E+01, 0.11718758E+01,& + 0.11216131E+01, 0.10809473E+01, 0.10476396E+01, 0.10200373E+01, 0.99692726E+00, 0.97740923E+00, 0.96080188E+00, 0.94657562E+00,& + 0.93430511E+00, 0.92363528E+00, 0.22042132E+02, 0.22107298E+02, 0.22180915E+02, 0.22259478E+02, 0.22341039E+02, 0.22424247E+02,& + 0.22508089E+02, 0.22591771E+02, 0.22674661E+02, 0.22756246E+02, 0.22836093E+02, 0.22169501E+02, 0.22270075E+02, 0.22379193E+02,& + 0.22492992E+02, 0.22608508E+02, 0.22723843E+02, 0.22837837E+02, 0.22949751E+02, 0.23059032E+02, 0.23165146E+02, 0.23267456E+02,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00 /) & + , (/ 11,16,3 /) ) + + real*8, dimension(11,16,3), parameter :: GB = reshape ( (/ & + 0.63499072E-02, 0.65566348E-02, 0.67849730E-02, 0.70481947E-02, 0.73585943E-02, 0.77242818E-02, 0.81472693E-02, 0.86227527E-02,& + 0.91396814E-02, 0.96825438E-02, 0.10233955E-01, 0.77266491E-02, 0.81323287E-02, 0.86507620E-02, 0.92776391E-02, 0.99806312E-02,& + 0.10709803E-01, 0.11414739E-01, 0.12058772E-01, 0.12623992E-01, 0.13108146E-01, 0.13518390E-01, 0.11644593E+01, 0.11747203E+01,& + 0.11837872E+01, 0.11918561E+01, 0.11990757E+01, 0.12055643E+01, 0.12114186E+01, 0.12167192E+01, 0.12215344E+01, 0.12259226E+01,& + 0.12299344E+01, 0.12006968E+01, 0.12108196E+01, 0.12196717E+01, 0.12274493E+01, 0.12343189E+01, 0.12404147E+01, 0.12458431E+01,& + 0.12506907E+01, 0.12550299E+01, 0.12589256E+01, 0.12624402E+01, 0.15750172E+00, 0.16174076E+00, 0.16548628E+00, 0.16881124E+00,& + 0.17177839E+00, 0.17443933E+00, 0.17683622E+00, 0.17900375E+00, 0.18097099E+00, 0.18276283E+00, 0.18440117E+00, 0.17770551E+00,& + 0.18176757E+00, 0.18527967E+00, 0.18833348E+00, 0.19100108E+00, 0.19334122E+00, 0.19540288E+00, 0.19722732E+00, 0.19884918E+00,& + 0.20029696E+00, 0.20159300E+00, 0.10192131E+02, 0.97258602E+01, 0.92992890E+01, 0.89154021E+01, 0.85730084E+01, 0.82685838E+01,& + 0.79978921E+01, 0.77568055E+01, 0.75416266E+01, 0.73491694E+01, 0.71767400E+01, 0.92439050E+01, 0.87567422E+01, 0.83270144E+01,& + 0.79528337E+01, 0.76286839E+01, 0.73477879E+01, 0.71035818E+01, 0.68903312E+01, 0.67032875E+01, 0.65386461E+01, 0.63934377E+01,& + 0.24870635E+02, 0.24725591E+02, 0.24600320E+02, 0.24487300E+02, 0.24384935E+02, 0.24292341E+02, 0.24208572E+02, 0.24132642E+02,& + 0.24063614E+02, 0.24000649E+02, 0.23943021E+02, 0.24586283E+02, 0.24441465E+02, 0.24311657E+02, 0.24196167E+02, 0.24093406E+02,& + 0.24001597E+02, 0.23919098E+02, 0.23844511E+02, 0.23776708E+02, 0.23714816E+02, 0.23658197E+02, 0.11990218E+02, 0.10904073E+02,& + 0.89126838E+01, 0.85622405E+01, 0.94892164E+01, 0.13580937E+02,-0.32050918E+03,-0.37133165E+01, 0.18890836E+00, 0.14209226E+01,& + 0.19817679E+01, 0.79709806E+01, 0.75400737E+01, 0.81804377E+01, 0.10564339E+02, 0.46896789E+02,-0.30926524E+01, 0.85742941E+00,& + 0.19164038E+01, 0.23513199E+01, 0.25566644E+01, 0.26555181E+01, 0.87668459E-01, 0.83754276E-01, 0.80460283E-01, 0.77659686E-01,& + 0.75257056E-01, 0.73179175E-01, 0.71369063E-01, 0.69781812E-01, 0.68381606E-01, 0.67139539E-01, 0.66032012E-01, 0.74878820E-01,& + 0.71650966E-01, 0.68979615E-01, 0.66745345E-01, 0.64857571E-01, 0.63248495E-01, 0.61866970E-01, 0.60673632E-01, 0.59637277E-01,& + 0.58732178E-01, 0.57936092E-01, 0.13230067E+02, 0.13213564E+02, 0.13209140E+02, 0.13213894E+02, 0.13225963E+02, 0.13243806E+02,& + 0.13266104E+02, 0.13291782E+02, 0.13319961E+02, 0.13349927E+02, 0.13381108E+02, 0.13183816E+02, 0.13189991E+02, 0.13209485E+02,& + 0.13238789E+02, 0.13275017E+02, 0.13316096E+02, 0.13360555E+02, 0.13407324E+02, 0.13455544E+02, 0.13504450E+02, 0.13553282E+02,& + 0.97222852E-01, 0.98862238E-01, 0.10061504E+00, 0.10256222E+00, 0.10475952E+00, 0.10720986E+00, 0.10985370E+00, 0.11257633E+00,& + 0.11522980E+00, 0.11766343E+00, 0.11975320E+00, 0.10681591E+00, 0.10921298E+00, 0.11198225E+00, 0.11487826E+00, 0.11751113E+00,& + 0.11951535E+00, 0.12069945E+00, 0.12108524E+00, 0.12084229E+00, 0.12019005E+00, 0.11932684E+00, 0.10346097E+01, 0.10433655E+01,& + 0.10511933E+01, 0.10582150E+01, 0.10645317E+01, 0.10702313E+01, 0.10753907E+01, 0.10800762E+01, 0.10843446E+01, 0.10882439E+01,& + 0.10918144E+01, 0.10626130E+01, 0.10716026E+01, 0.10795108E+01, 0.10865006E+01, 0.10927103E+01, 0.10982489E+01, 0.11032019E+01,& + 0.11076379E+01, 0.11116160E+01, 0.11151910E+01, 0.11184188E+01, 0.38103212E+00, 0.38913800E+00, 0.39613651E+00, 0.40222421E+00,& + 0.40756010E+00, 0.41226954E+00, 0.41645142E+00, 0.42018474E+00, 0.42353379E+00, 0.42655211E+00, 0.42928533E+00, 0.41646579E+00,& + 0.42345095E+00, 0.42937476E+00, 0.43444062E+00, 0.43880316E+00, 0.44258354E+00, 0.44587882E+00, 0.44876776E+00, 0.45131451E+00,& + 0.45357095E+00, 0.45557797E+00, 0.82623280E+01, 0.81072291E+01, 0.79523834E+01, 0.78012527E+01, 0.76561458E+01, 0.75182174E+01,& + 0.73878952E+01, 0.72652133E+01, 0.71500151E+01, 0.70420667E+01, 0.69411177E+01, 0.79342219E+01, 0.77373458E+01, 0.75467334E+01,& + 0.73661786E+01, 0.71974319E+01, 0.70408543E+01, 0.68960649E+01, 0.67623672E+01, 0.66389989E+01, 0.65252707E+01, 0.64206412E+01,& + 0.10656640E+02, 0.10630910E+02, 0.10608399E+02, 0.10587891E+02, 0.10569156E+02, 0.10552075E+02, 0.10536510E+02, 0.10522307E+02,& + 0.10509317E+02, 0.10497402E+02, 0.10486443E+02, 0.10605856E+02, 0.10579514E+02, 0.10555632E+02, 0.10534169E+02, 0.10514900E+02,& + 0.10497547E+02, 0.10481842E+02, 0.10467553E+02, 0.10454488E+02, 0.10442501E+02, 0.10431483E+02, 0.26681588E+02, 0.24728346E+02,& + 0.20551342E+02, 0.19955244E+02, 0.22227100E+02, 0.31770288E+02,-0.74061287E+03,-0.81329826E+01, 0.90279822E+00, 0.37532746E+01,& + 0.50437916E+01, 0.18377807E+02, 0.17643148E+02, 0.19296161E+02, 0.24951120E+02, 0.10957372E+03,-0.67432659E+01, 0.24550746E+01,& + 0.49089917E+01, 0.59008712E+01, 0.63532616E+01, 0.65558627E+01, 0.23203798E+01, 0.22288925E+01, 0.21515593E+01, 0.20855896E+01,& + 0.20288489E+01, 0.19796791E+01, 0.19367778E+01, 0.18991112E+01, 0.18658501E+01, 0.18363226E+01, 0.18099779E+01, 0.20206726E+01,& + 0.19441824E+01, 0.18807257E+01, 0.18275618E+01, 0.17825910E+01, 0.17442308E+01, 0.17112809E+01, 0.16828137E+01, 0.16580908E+01,& + 0.16365014E+01, 0.16175164E+01, 0.22051750E+02, 0.22116850E+02, 0.22190410E+02, 0.22268925E+02, 0.22350445E+02, 0.22433617E+02,& + 0.22517429E+02, 0.22601086E+02, 0.22683956E+02, 0.22765522E+02, 0.22845354E+02, 0.22178972E+02, 0.22279484E+02, 0.22388551E+02,& + 0.22502309E+02, 0.22617792E+02, 0.22733099E+02, 0.22847071E+02, 0.22958967E+02, 0.23068234E+02, 0.23174336E+02, 0.23276638E+02,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01 /) & + , (/ 11,16,3 /) ) + + real*8, dimension(6,6), parameter :: XP = reshape ( (/ & + 0.46430621E+02, 0.12928299E+03, 0.20732648E+03, 0.31398411E+03, 0.18373177E+03, -0.11412303E+03, & + 0.73604774E+02, 0.27887914E+03, 0.27076947E+03, -0.57322111E+02, -0.64742459E+02, 0.87238280E+02, & + 0.37050866E+02, 0.20498759E+03, 0.37558029E+03, 0.17401171E+03, -0.13350302E+03, -0.37651795E+02, & + 0.14930141E+02, 0.89161160E+02, 0.17793062E+03, 0.93433860E+02, -0.70646020E+02, -0.26373150E+02, & + 0.40386780E+02, 0.10855270E+03, 0.50755010E+02, -0.31496190E+02, 0.12791300E+00, 0.18017770E+01, & + 0.90811926E+01, 0.75073923E+02, 0.24654438E+03, 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /) , (/ 6,6 /) ) + + REAL*8, dimension(2), parameter :: RSUN = (/ 0.441676 , 0.558324 /) + REAL*8, dimension(2,6), parameter :: RRAY = reshape ( & + (/ .428937E-01, .697200E-02,& + .890743E+00, .173297E-01,& + -.288555E+01,-.850903E-01,& + .522744E+01, .248261E+00,& + -.469173E+01,-.302031E+00,& + .161645E+01, .129662E+00 /) , (/2,6/) ) + + REAL*8, dimension(2,5), parameter :: TAUA = reshape ( & + (/ 0.730719, 0.730719, 0.912819, 0.912819, 0.725059, & + 0.725059, 0.745405, 0.745405, 0.682188, 0.682188 /),(/2,5/) ) + REAL*8, dimension(2,5), parameter :: RPIZA = reshape ( & + (/ 0.872212, 0.872212, 0.982545, 0.982545, 0.623143, & + 0.623143, 0.944887, 0.944887, 0.997975, 0.997975 /),(/2,5/) ) + REAL*8, dimension(2,5), parameter :: RCGA = reshape ( & + (/ 0.647596, 0.647596, 0.739002, 0.739002, 0.580845, & + 0.580845, 0.662657, 0.662657, 0.624246, 0.624246 /),(/2,5/) ) + + REAL*8, dimension(2,3,7), parameter :: APAD = reshape ( & + (/ 0.912418292E+05, 0.376655383E-08, 0.000000000E-00,& + 0.739646016E-08, 0.925887084E-04, 0.410177786E+03,& + 0.723613782E+05, 0.978576773E-04, 0.000000000E-00,& + 0.131849595E-03, 0.129353723E-01, 0.672595424E+02,& + 0.596037057E+04, 0.387714006E+00, 0.000000000E-00,& + 0.437772681E+00, 0.800821928E+00, 0.000000000E-00,& + 0.000000000E-00, 0.118461660E+03, 0.000000000E-00,& + 0.151345118E+03, 0.242715973E+02, 0.000000000E-00,& + 0.000000000E-00, 0.119079797E+04, 0.000000000E-00,& + 0.233628890E+04, 0.878331486E+02, 0.000000000E-00,& + 0.000000000E-00, 0.293353397E+03, 0.000000000E-00,& + 0.797219934E+03, 0.191559725E+02, 0.000000000E-00,& + 0.000000000E-00, 0.000000000E+00, 0.000000000E-00,& + 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /) , (/2,3,7/) ) + REAL*8, dimension(2,3,7), parameter :: BPAD = reshape ( & + (/ 0.912418292E+05, 0.376655383E-08, 0.000000000E-00,& + 0.739646016E-08, 0.925887084E-04, 0.410177786E+03,& + 0.724555318E+05, 0.979023421E-04, 0.000000000E-00,& + 0.131861712E-03, 0.131812683E-01, 0.731185438E+02,& + 0.602593328E+04, 0.388611139E+00, 0.000000000E-00,& + 0.437949001E+00, 0.812706117E+00, 0.100000000E+01,& + 0.100000000E+01, 0.120291383E+03, 0.000000000E-00,& + 0.151692730E+03, 0.249863591E+02, 0.000000000E+00,& + 0.000000000E-00, 0.130531005E+04, 0.000000000E-00,& + 0.237071130E+04, 0.931071925E+02, 0.000000000E+00,& + 0.000000000E-00, 0.415049409E+03, 0.000000000E-00,& + 0.867914360E+03, 0.252233437E+02, 0.000000000E+00,& + 0.000000000E-00, 0.100000000E+01, 0.000000000E-00,& + 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /) , (/2,3,7/) ) + REAL*8, dimension(2,3), parameter :: D = reshape ( & + (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.8 /) , (/2,3/) ) + + REAL*8, parameter :: TREF = 250.0 + REAL*8, dimension(2), parameter :: RT1 = (/ -0.577350269, +0.577350269 /) + REAL*8, dimension(5,5), parameter :: RAER= reshape ( & + (/ .038520, .037196, .040532, .054934, .038520 & + , .12613 , .18313 , .10357 , .064106, .126130 & + , .012579, .013649, .018652, .025181, .012579 & + , .011890, .016142, .021105, .028908, .011890 & + , .013792, .026810, .052203, .066338, .013792 /) , (/5,5/) ) + + REAL*8, dimension(8,3), parameter :: AT= reshape ( & + (/ 0.298199E-02,0.143676E-01,0.197861E-01,0.289560E-01,& + 0.103800E-01,0.868859E-02,0.250073E-03,0.307423E-01,& + -.394023E-03,0.366501E-02,0.315541E-02,-.208807E-02,& + 0.436296E-02,-.972752E-03,0.455875E-03,0.110879E-02,& + 0.319566E-04,-.160822E-02,-.174547E-02,-.121943E-02,& + -.161431E-02,0.000000E-00,0.109242E-03,-.322172E-03 /) , (/8,3/) ) + + REAL*8, dimension(8,3), parameter :: BT= reshape ( & + (/ -0.106432E-04,-0.553979E-04,-0.877012E-04,-0.165960E-03,& + -0.276744E-04,-0.278412E-04, 0.199846E-05,-0.108482E-03,& + 0.660324E-06,-0.101701E-04, 0.513302E-04, 0.157704E-03,& + -0.327381E-04,-0.713940E-06,-0.216313E-05, 0.258096E-05,& + 0.174356E-06, 0.920868E-05, 0.523138E-06,-0.146427E-04,& + 0.127646E-04 ,0.117469E-05, 0.175991E-06,-0.814575E-06 /) , (/8,3/) ) + + REAL*8, dimension(4), parameter :: OCT = (/ -.326E-03, -.102E-05, .137E-02, -.535E-05 /) + + end module radiation_AR4_param Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radio_decay.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radio_decay.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radio_decay.F90 (revision 1280) @@ -0,0 +1,61 @@ +! +! $Id $ +! +SUBROUTINE radio_decay(radio,rnpb,dtime,tautr,tr,d_tr) +! +! Caluclate radioactive decay for all tracers with radio(it)=true +! + USE dimphy + USE infotrac, ONLY : nbtr + IMPLICIT NONE +!----------------------------------------------------------------------- +! Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94 +! Objet: Calcul de la tendance radioactive des traceurs type radioelements +!CG240694 : Pour un traceur, le radon +!CG161294 : Plus un 2eme traceur, le 210Pb. Le radon decroit en plomb. +!----------------------------------------------------------------------- +! +! Entrees +! + LOGICAL,DIMENSION(nbtr),INTENT(IN) :: radio ! .true. = traceur radioactif + LOGICAL,INTENT(IN) :: rnpb ! .true. = decroissance RN = source PB + REAL,INTENT(IN) :: dtime ! Pas de temps physique (secondes) + REAL,DIMENSION(nbtr),INTENT(IN) :: tautr ! Constante de decroissance radioactive + REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr ! Concentrations traceurs U/kgA +! +! Sortie +! + REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: d_tr ! Tendance de decroissance radioactive +! +! Locales +! + INTEGER :: i,k,it + + + DO it = 1,nbtr + IF ( radio(it) ) THEN + IF (tautr(it) .GT. 0.) THEN + DO k = 1,klev + DO i = 1,klon + d_tr(i,k,it) = - tr(i,k,it) * dtime / tautr(it) + END DO + END DO + ELSE + d_tr(:,:,it) = 0. + END IF + ELSE + d_tr(:,:,it) = 0. + END IF + END DO +!------------------------------------------------------- +!CG161294 : Cas particulier radon [it=1] => plomb [it=2] +!------------------------------------------------------- + IF ( rnpb ) THEN + DO k = 1,klev + DO i = 1,klon + d_tr(i,k,2) = d_tr(i,k,2) - d_tr(i,k,1) + ENDDO + ENDDO + ENDIF + +END SUBROUTINE radio_decay Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radlwsw.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radlwsw.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radlwsw.F90 (revision 1280) @@ -0,0 +1,456 @@ +module radlwsw_m + + IMPLICIT NONE + +contains + +SUBROUTINE radlwsw( & + dist, rmu0, fract, & + paprs, pplay,tsol,alb1, alb2, & + t,q,wo,& + cldfra, cldemi, cldtaupd,& + ok_ade, ok_aie,& + tau_aero, piz_aero, cg_aero,& + cldtaupi, new_aod, & + qsat, flwc, fiwc, & + heat,heat0,cool,cool0,radsol,albpla,& + topsw,toplw,solsw,sollw,& + sollwdown,& + topsw0,toplw0,solsw0,sollw0,& + lwdn0, lwdn, lwup0, lwup,& + swdn0, swdn, swup0, swup,& + topswad_aero, solswad_aero,& + topswai_aero, solswai_aero, & + topswad0_aero, solswad0_aero,& + topsw_aero, topsw0_aero,& + solsw_aero, solsw0_aero, & + topswcf_aero, solswcf_aero) + + + + USE DIMPHY + use assert_m, only: assert + + !====================================================================== + ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19960719 + ! Objet: interface entre le modele et les rayonnements + ! Arguments: + ! dist-----input-R- distance astronomique terre-soleil + ! rmu0-----input-R- cosinus de l'angle zenithal + ! fract----input-R- duree d'ensoleillement normalisee + ! co2_ppm--input-R- concentration du gaz carbonique (en ppm) + ! paprs----input-R- pression a inter-couche (Pa) + ! pplay----input-R- pression au milieu de couche (Pa) + ! tsol-----input-R- temperature du sol (en K) + ! alb1-----input-R- albedo du sol(entre 0 et 1) dans l'interval visible + ! alb2-----input-R- albedo du sol(entre 0 et 1) dans l'interval proche infra-rouge + ! t--------input-R- temperature (K) + ! q--------input-R- vapeur d'eau (en kg/kg) + ! cldfra---input-R- fraction nuageuse (entre 0 et 1) + ! cldtaupd---input-R- epaisseur optique des nuages dans le visible (present-day value) + ! cldemi---input-R- emissivite des nuages dans l'IR (entre 0 et 1) + ! ok_ade---input-L- apply the Aerosol Direct Effect or not? + ! ok_aie---input-L- apply the Aerosol Indirect Effect or not? + ! tau_ae, piz_ae, cg_ae-input-R- aerosol optical properties (calculated in aeropt.F) + ! cldtaupi-input-R- epaisseur optique des nuages dans le visible + ! calculated for pre-industrial (pi) aerosol concentrations, i.e. with smaller + ! droplet concentration, thus larger droplets, thus generally cdltaupi cldtaupd + ! it is needed for the diagnostics of the aerosol indirect radiative forcing + ! + ! heat-----output-R- echauffement atmospherique (visible) (K/jour) + ! cool-----output-R- refroidissement dans l'IR (K/jour) + ! radsol---output-R- bilan radiatif net au sol (W/m**2) (+ vers le bas) + ! albpla---output-R- albedo planetaire (entre 0 et 1) + ! topsw----output-R- flux solaire net au sommet de l'atm. + ! toplw----output-R- ray. IR montant au sommet de l'atmosphere + ! solsw----output-R- flux solaire net a la surface + ! sollw----output-R- ray. IR montant a la surface + ! solswad---output-R- ray. solaire net absorbe a la surface (aerosol dir) + ! topswad---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol dir) + ! solswai---output-R- ray. solaire net absorbe a la surface (aerosol ind) + ! topswai---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol ind) + ! + ! ATTENTION: swai and swad have to be interpreted in the following manner: + ! --------- + ! ok_ade=F & ok_aie=F -both are zero + ! ok_ade=T & ok_aie=F -aerosol direct forcing is F_{AD} = topsw-topswad + ! indirect is zero + ! ok_ade=F & ok_aie=T -aerosol indirect forcing is F_{AI} = topsw-topswai + ! direct is zero + ! ok_ade=T & ok_aie=T -aerosol indirect forcing is F_{AI} = topsw-topswai + ! aerosol direct forcing is F_{AD} = topswai-topswad + ! + + !====================================================================== + + ! ==================================================================== + ! Adapte au modele de chimie INCA par Celine Deandreis & Anne Cozic -- 2009 + ! 1 = ZERO + ! 2 = AER total + ! 3 = NAT + ! 4 = BC + ! 5 = SO4 + ! 6 = POM + ! 7 = DUST + ! 8 = SS + ! 9 = NO3 + ! + ! ==================================================================== + include "YOETHF.h" + include "YOMCST.h" + include "clesphys.h" + include "iniprint.h" + +! Input arguments + REAL, INTENT(in) :: dist + REAL, INTENT(in) :: rmu0(KLON), fract(KLON) + REAL, INTENT(in) :: paprs(KLON,KLEV+1), pplay(KLON,KLEV) + REAL, INTENT(in) :: alb1(KLON), alb2(KLON), tsol(KLON) + REAL, INTENT(in) :: t(KLON,KLEV), q(KLON,KLEV) + + REAL, INTENT(in):: wo(:, :, :) ! dimension(KLON,KLEV, 1 or 2) + ! column-density of ozone in a layer, in kilo-Dobsons + ! "wo(:, :, 1)" is for the average day-night field, + ! "wo(:, :, 2)" is for daylight time. + + LOGICAL, INTENT(in) :: ok_ade, ok_aie ! switches whether to use aerosol direct (indirect) effects or not + REAL, INTENT(in) :: cldfra(KLON,KLEV), cldemi(KLON,KLEV), cldtaupd(KLON,KLEV) + REAL, INTENT(in) :: tau_aero(KLON,KLEV,9,2) ! aerosol optical properties (see aeropt.F) + REAL, INTENT(in) :: piz_aero(KLON,KLEV,9,2) ! aerosol optical properties (see aeropt.F) + REAL, INTENT(in) :: cg_aero(KLON,KLEV,9,2) ! aerosol optical properties (see aeropt.F) + REAL, INTENT(in) :: cldtaupi(KLON,KLEV) ! cloud optical thickness for pre-industrial aerosol concentrations + LOGICAL, INTENT(in) :: new_aod ! flag pour retrouver les resultats exacts de l'AR4 dans le cas ou l'on ne travaille qu'avec les sulfates + REAL, INTENT(in) :: qsat(klon,klev) ! Variable pour iflag_rrtm=1 + REAL, INTENT(in) :: flwc(klon,klev) ! Variable pour iflag_rrtm=1 + REAL, INTENT(in) :: fiwc(klon,klev) ! Variable pour iflag_rrtm=1 + +! Output arguments + REAL, INTENT(out) :: heat(KLON,KLEV), cool(KLON,KLEV) + REAL, INTENT(out) :: heat0(KLON,KLEV), cool0(KLON,KLEV) + REAL, INTENT(out) :: radsol(KLON), topsw(KLON), toplw(KLON) + REAL, INTENT(out) :: solsw(KLON), sollw(KLON), albpla(KLON) + REAL, INTENT(out) :: topsw0(KLON), toplw0(KLON), solsw0(KLON), sollw0(KLON) + REAL, INTENT(out) :: sollwdown(KLON) + REAL, INTENT(out) :: swdn(KLON,kflev+1),swdn0(KLON,kflev+1) + REAL, INTENT(out) :: swup(KLON,kflev+1),swup0(KLON,kflev+1) + REAL, INTENT(out) :: lwdn(KLON,kflev+1),lwdn0(KLON,kflev+1) + REAL, INTENT(out) :: lwup(KLON,kflev+1),lwup0(KLON,kflev+1) + REAL, INTENT(out) :: topswad_aero(KLON), solswad_aero(KLON) ! output: aerosol direct forcing at TOA and surface + REAL, INTENT(out) :: topswai_aero(KLON), solswai_aero(KLON) ! output: aerosol indirect forcing atTOA and surface + REAL, DIMENSION(klon), INTENT(out) :: topswad0_aero + REAL, DIMENSION(klon), INTENT(out) :: solswad0_aero + REAL, DIMENSION(kdlon,9), INTENT(out) :: topsw_aero + REAL, DIMENSION(kdlon,9), INTENT(out) :: topsw0_aero + REAL, DIMENSION(kdlon,9), INTENT(out) :: solsw_aero + REAL, DIMENSION(kdlon,9), INTENT(out) :: solsw0_aero + REAL, DIMENSION(kdlon,3), INTENT(out) :: topswcf_aero + REAL, DIMENSION(kdlon,3), INTENT(out) :: solswcf_aero + +! Local variables + REAL(KIND=8) ZFSUP(KDLON,KFLEV+1) + REAL(KIND=8) ZFSDN(KDLON,KFLEV+1) + REAL(KIND=8) ZFSUP0(KDLON,KFLEV+1) + REAL(KIND=8) ZFSDN0(KDLON,KFLEV+1) + REAL(KIND=8) ZFLUP(KDLON,KFLEV+1) + REAL(KIND=8) ZFLDN(KDLON,KFLEV+1) + REAL(KIND=8) ZFLUP0(KDLON,KFLEV+1) + REAL(KIND=8) ZFLDN0(KDLON,KFLEV+1) + REAL(KIND=8) zx_alpha1, zx_alpha2 + INTEGER k, kk, i, j, iof, nb_gr + REAL(KIND=8) PSCT + REAL(KIND=8) PALBD(kdlon,2), PALBP(kdlon,2) + REAL(KIND=8) PEMIS(kdlon), PDT0(kdlon), PVIEW(kdlon) + REAL(KIND=8) PPSOL(kdlon), PDP(kdlon,KLEV) + REAL(KIND=8) PTL(kdlon,kflev+1), PPMB(kdlon,kflev+1) + REAL(KIND=8) PTAVE(kdlon,kflev) + REAL(KIND=8) PWV(kdlon,kflev), PQS(kdlon,kflev) + + real(kind=8) POZON(kdlon, kflev, size(wo, 3)) ! mass fraction of ozone + ! "POZON(:, :, 1)" is for the average day-night field, + ! "POZON(:, :, 2)" is for daylight time. + + REAL(KIND=8) PAER(kdlon,kflev,5) + REAL(KIND=8) PCLDLD(kdlon,kflev) + REAL(KIND=8) PCLDLU(kdlon,kflev) + REAL(KIND=8) PCLDSW(kdlon,kflev) + REAL(KIND=8) PTAU(kdlon,2,kflev) + REAL(KIND=8) POMEGA(kdlon,2,kflev) + REAL(KIND=8) PCG(kdlon,2,kflev) + REAL(KIND=8) zfract(kdlon), zrmu0(kdlon), zdist + REAL(KIND=8) zheat(kdlon,kflev), zcool(kdlon,kflev) + REAL(KIND=8) zheat0(kdlon,kflev), zcool0(kdlon,kflev) + REAL(KIND=8) ztopsw(kdlon), ztoplw(kdlon) + REAL(KIND=8) zsolsw(kdlon), zsollw(kdlon), zalbpla(kdlon) + REAL(KIND=8) zsollwdown(kdlon) + REAL(KIND=8) ztopsw0(kdlon), ztoplw0(kdlon) + REAL(KIND=8) zsolsw0(kdlon), zsollw0(kdlon) + REAL(KIND=8) zznormcp + REAL(KIND=8) tauaero(kdlon,kflev,9,2) ! aer opt properties + REAL(KIND=8) pizaero(kdlon,kflev,9,2) + REAL(KIND=8) cgaero(kdlon,kflev,9,2) + REAL(KIND=8) PTAUA(kdlon,2,kflev) ! present-day value of cloud opt thickness (PTAU is pre-industrial value), local use + REAL(KIND=8) POMEGAA(kdlon,2,kflev) ! dito for single scatt albedo + REAL(KIND=8) ztopswadaero(kdlon), zsolswadaero(kdlon) ! Aerosol direct forcing at TOAand surface + REAL(KIND=8) ztopswad0aero(kdlon), zsolswad0aero(kdlon) ! Aerosol direct forcing at TOAand surface + REAL(KIND=8) ztopswaiaero(kdlon), zsolswaiaero(kdlon) ! dito, indirect + REAL(KIND=8) ztopsw_aero(kdlon,9), ztopsw0_aero(kdlon,9) + REAL(KIND=8) zsolsw_aero(kdlon,9), zsolsw0_aero(kdlon,9) + REAL(KIND=8) ztopswcf_aero(kdlon,3), zsolswcf_aero(kdlon,3) + real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2 + + call assert(size(wo, 1) == klon, size(wo, 2) == klev, "radlwsw wo") + ! initialisation + tauaero(:,:,:,:)=0. + pizaero(:,:,:,:)=0. + cgaero(:,:,:,:)=0. + + ! + !------------------------------------------- + nb_gr = KLON / kdlon + IF (nb_gr*kdlon .NE. KLON) THEN + PRINT*, "kdlon mauvais:", KLON, kdlon, nb_gr + CALL abort + ENDIF + IF (kflev .NE. KLEV) THEN + PRINT*, "kflev differe de KLEV, kflev, KLEV" + CALL abort + ENDIF + !------------------------------------------- + DO k = 1, KLEV + DO i = 1, KLON + heat(i,k)=0. + cool(i,k)=0. + heat0(i,k)=0. + cool0(i,k)=0. + ENDDO + ENDDO + ! + zdist = dist + ! + PSCT = solaire/zdist/zdist + DO j = 1, nb_gr + iof = kdlon*(j-1) + DO i = 1, kdlon + zfract(i) = fract(iof+i) + zrmu0(i) = rmu0(iof+i) + PALBD(i,1) = alb1(iof+i) + PALBD(i,2) = alb2(iof+i) + PALBP(i,1) = alb1(iof+i) + PALBP(i,2) = alb2(iof+i) + PEMIS(i) = 1.0 + PVIEW(i) = 1.66 + PPSOL(i) = paprs(iof+i,1) + zx_alpha1 = (paprs(iof+i,1)-pplay(iof+i,2))/(pplay(iof+i,1)-pplay(iof+i,2)) + zx_alpha2 = 1.0 - zx_alpha1 + PTL(i,1) = t(iof+i,1) * zx_alpha1 + t(iof+i,2) * zx_alpha2 + PTL(i,KLEV+1) = t(iof+i,KLEV) + PDT0(i) = tsol(iof+i) - PTL(i,1) + ENDDO + DO k = 2, kflev + DO i = 1, kdlon + PTL(i,k) = (t(iof+i,k)+t(iof+i,k-1))*0.5 + ENDDO + ENDDO + DO k = 1, kflev + DO i = 1, kdlon + PDP(i,k) = paprs(iof+i,k)-paprs(iof+i,k+1) + PTAVE(i,k) = t(iof+i,k) + PWV(i,k) = MAX (q(iof+i,k), 1.0e-12) + PQS(i,k) = PWV(i,k) + POZON(i,k, :) = wo(iof+i, k, :) * RG * dobson_u * 1e3 & + / (paprs(iof+i, k) - paprs(iof+i, k+1)) + PCLDLD(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k) + PCLDLU(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k) + PCLDSW(i,k) = cldfra(iof+i,k) + PTAU(i,1,k) = MAX(cldtaupi(iof+i,k), 1.0e-05)! 1e-12 serait instable + PTAU(i,2,k) = MAX(cldtaupi(iof+i,k), 1.0e-05)! pour 32-bit machines + POMEGA(i,1,k) = 0.9999 - 5.0e-04 * EXP(-0.5 * PTAU(i,1,k)) + POMEGA(i,2,k) = 0.9988 - 2.5e-03 * EXP(-0.05 * PTAU(i,2,k)) + PCG(i,1,k) = 0.865 + PCG(i,2,k) = 0.910 + !- + ! Introduced for aerosol indirect forcings. + ! The following values use the cloud optical thickness calculated from + ! present-day aerosol concentrations whereas the quantities without the + ! "A" at the end are for pre-industial (natural-only) aerosol concentrations + ! + PTAUA(i,1,k) = MAX(cldtaupd(iof+i,k), 1.0e-05)! 1e-12 serait instable + PTAUA(i,2,k) = MAX(cldtaupd(iof+i,k), 1.0e-05)! pour 32-bit machines + POMEGAA(i,1,k) = 0.9999 - 5.0e-04 * EXP(-0.5 * PTAUA(i,1,k)) + POMEGAA(i,2,k) = 0.9988 - 2.5e-03 * EXP(-0.05 * PTAUA(i,2,k)) + ENDDO + ENDDO + ! + DO k = 1, kflev+1 + DO i = 1, kdlon + PPMB(i,k) = paprs(iof+i,k)/100.0 + ENDDO + ENDDO + ! + DO kk = 1, 5 + DO k = 1, kflev + DO i = 1, kdlon + PAER(i,k,kk) = 1.0E-15 + ENDDO + ENDDO + ENDDO + DO k = 1, kflev + DO i = 1, kdlon + tauaero(i,k,:,1)=tau_aero(iof+i,k,:,1) + pizaero(i,k,:,1)=piz_aero(iof+i,k,:,1) + cgaero(i,k,:,1) =cg_aero(iof+i,k,:,1) + tauaero(i,k,:,2)=tau_aero(iof+i,k,:,2) + pizaero(i,k,:,2)=piz_aero(iof+i,k,:,2) + cgaero(i,k,:,2) =cg_aero(iof+i,k,:,2) + ENDDO + ENDDO + +! +!===== iflag_rrtm ================================================ +! + IF (iflag_rrtm == 0) THEN + ! Old radiation scheme, used for AR4 runs + ! average day-night ozone for longwave + CALL LW_LMDAR4(& + PPMB, PDP,& + PPSOL,PDT0,PEMIS,& + PTL, PTAVE, PWV, POZON(:, :, 1), PAER,& + PCLDLD,PCLDLU,& + PVIEW,& + zcool, zcool0,& + ztoplw,zsollw,ztoplw0,zsollw0,& + zsollwdown,& + ZFLUP, ZFLDN, ZFLUP0,ZFLDN0) + + ! daylight ozone, if we have it, for short wave + IF (.NOT. new_aod) THEN + ! use old version + CALL SW_LMDAR4(PSCT, zrmu0, zfract,& + PPMB, PDP, & + PPSOL, PALBD, PALBP,& + PTAVE, PWV, PQS, POZON(:, :, size(wo, 3)), PAER,& + PCLDSW, PTAU, POMEGA, PCG,& + zheat, zheat0,& + zalbpla,ztopsw,zsolsw,ztopsw0,zsolsw0,& + ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,& + tau_aero(:,:,5,:), piz_aero(:,:,5,:), cg_aero(:,:,5,:),& + PTAUA, POMEGAA,& + ztopswadaero,zsolswadaero,& + ztopswaiaero,zsolswaiaero,& + ok_ade, ok_aie) + + ELSE ! new_aod=T + CALL SW_AEROAR4(PSCT, zrmu0, zfract,& + PPMB, PDP,& + PPSOL, PALBD, PALBP,& + PTAVE, PWV, PQS, POZON(:, :, size(wo, 3)), PAER,& + PCLDSW, PTAU, POMEGA, PCG,& + zheat, zheat0,& + zalbpla,ztopsw,zsolsw,ztopsw0,zsolsw0,& + ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,& + tauaero, pizaero, cgaero, & + PTAUA, POMEGAA,& + ztopswadaero,zsolswadaero,& + ztopswad0aero,zsolswad0aero,& + ztopswaiaero,zsolswaiaero, & + ztopsw_aero,ztopsw0_aero,& + zsolsw_aero,zsolsw0_aero,& + ztopswcf_aero,zsolswcf_aero, & + ok_ade, ok_aie) + + ENDIF + + ELSE +!===== iflag_rrtm=1, on passe dans SW via RECMWFL =============== + WRITE(lunout,*) "Option iflag_rrtm=T ne fonctionne pas encore !!!" + CALL abort_gcm('radlwsw','iflag_rrtm=T not valid',1) + + ENDIF ! iflag_rrtm +!====================================================================== + + DO i = 1, kdlon + radsol(iof+i) = zsolsw(i) + zsollw(i) + topsw(iof+i) = ztopsw(i) + toplw(iof+i) = ztoplw(i) + solsw(iof+i) = zsolsw(i) + sollw(iof+i) = zsollw(i) + sollwdown(iof+i) = zsollwdown(i) + DO k = 1, kflev+1 + lwdn0 ( iof+i,k) = ZFLDN0 ( i,k) + lwdn ( iof+i,k) = ZFLDN ( i,k) + lwup0 ( iof+i,k) = ZFLUP0 ( i,k) + lwup ( iof+i,k) = ZFLUP ( i,k) + ENDDO + topsw0(iof+i) = ztopsw0(i) + toplw0(iof+i) = ztoplw0(i) + solsw0(iof+i) = zsolsw0(i) + sollw0(iof+i) = zsollw0(i) + albpla(iof+i) = zalbpla(i) + + DO k = 1, kflev+1 + swdn0 ( iof+i,k) = ZFSDN0 ( i,k) + swdn ( iof+i,k) = ZFSDN ( i,k) + swup0 ( iof+i,k) = ZFSUP0 ( i,k) + swup ( iof+i,k) = ZFSUP ( i,k) + ENDDO + ENDDO + !-transform the aerosol forcings, if they have + ! to be calculated + IF (ok_ade) THEN + DO i = 1, kdlon + topswad_aero(iof+i) = ztopswadaero(i) + topswad0_aero(iof+i) = ztopswad0aero(i) + solswad_aero(iof+i) = zsolswadaero(i) + solswad0_aero(iof+i) = zsolswad0aero(i) +! MS the following lines seem to be wrong, why is iof on right hand side??? +! topsw_aero(iof+i,:) = ztopsw_aero(iof+i,:) +! topsw0_aero(iof+i,:) = ztopsw0_aero(iof+i,:) +! solsw_aero(iof+i,:) = zsolsw_aero(iof+i,:) +! solsw0_aero(iof+i,:) = zsolsw0_aero(iof+i,:) + topsw_aero(iof+i,:) = ztopsw_aero(i,:) + topsw0_aero(iof+i,:) = ztopsw0_aero(i,:) + solsw_aero(iof+i,:) = zsolsw_aero(i,:) + solsw0_aero(iof+i,:) = zsolsw0_aero(i,:) + topswcf_aero(iof+i,:) = ztopswcf_aero(i,:) + solswcf_aero(iof+i,:) = zsolswcf_aero(i,:) + ENDDO + ELSE + DO i = 1, kdlon + topswad_aero(iof+i) = 0.0 + solswad_aero(iof+i) = 0.0 + topswad0_aero(iof+i) = 0.0 + solswad0_aero(iof+i) = 0.0 + topsw_aero(iof+i,:) = 0. + topsw0_aero(iof+i,:) =0. + solsw_aero(iof+i,:) = 0. + solsw0_aero(iof+i,:) = 0. + ENDDO + ENDIF + IF (ok_aie) THEN + DO i = 1, kdlon + topswai_aero(iof+i) = ztopswaiaero(i) + solswai_aero(iof+i) = zsolswaiaero(i) + ENDDO + ELSE + DO i = 1, kdlon + topswai_aero(iof+i) = 0.0 + solswai_aero(iof+i) = 0.0 + ENDDO + ENDIF + DO k = 1, kflev + DO i = 1, kdlon + ! scale factor to take into account the difference between + ! dry air and watter vapour scpecifi! heat capacity + zznormcp=1.0+RVTMP2*PWV(i,k) + heat(iof+i,k) = zheat(i,k)/zznormcp + cool(iof+i,k) = zcool(i,k)/zznormcp + heat0(iof+i,k) = zheat0(i,k)/zznormcp + cool0(iof+i,k) = zcool0(i,k)/zznormcp + ENDDO + ENDDO + + ENDDO ! j = 1, nb_gr + +END SUBROUTINE radlwsw + +end module radlwsw_m Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radopt.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radopt.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/radopt.h (revision 1280) @@ -0,0 +1,9 @@ +! +! $Header$ +! + LOGICAL LEVOIGT + PARAMETER (LEVOIGT=.FALSE.) + INTEGER NOVLP + PARAMETER (NOVLP=1) + INTEGER KAER + PARAMETER (KAER=0) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ran0_vec.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ran0_vec.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ran0_vec.F (revision 1280) @@ -0,0 +1,34 @@ +! +! $Header$ +! + subroutine ran0_vec(npoints,idum,ran0) + +! $Id$ +! Platform independent random number generator from +! Numerical Recipies +! Mark Webb July 1999 + + implicit none + + integer j,npoints,idum(npoints),IA,IM,IQ,IR,k(npoints) + real ran0(npoints),AM + + parameter (IA=16807, IM=2147483647, AM=1.0/IM, IQ=127773, IR=2836) + +c do j=1,npoints +c if (idum(j).eq.0) then +c write(6,*) 'idum=',idum +c write(6,*) 'ZERO seed not allowed' +c stop +c endif +c enddo + + do j=1,npoints + k(j)=idum(j)/IQ + idum(j)=IA*(idum(j)-k(j)*IQ)-IR*k(j) + if (idum(j).lt.0) idum(j)=idum(j)+IM + ran0(j)=AM*idum(j) + enddo + + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/read_map2D.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/read_map2D.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/read_map2D.F90 (revision 1280) @@ -0,0 +1,60 @@ +SUBROUTINE read_map2D(filename, varname, timestep, inverse, varout) +! Open file and read one variable for one timestep. +! Return variable for the given timestep. + USE dimphy + USE netcdf + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + + + IMPLICIT NONE + +! Input arguments + CHARACTER(len=20), INTENT(IN) :: filename ! name of file to read + CHARACTER(len=20), INTENT(IN) :: varname ! name of variable in file + INTEGER, INTENT(IN) :: timestep ! actual timestep + LOGICAL, INTENT(IN) :: inverse ! TRUE if latitude needs to be inversed +! Output argument + REAL, DIMENSION(klon), INTENT(OUT) :: varout ! The variable read from file for the given timestep + +! Local variables + INTEGER :: j + INTEGER :: nid, nvarid, ierr + INTEGER, DIMENSION(3) :: start, count + CHARACTER(len=20) :: modname='read_map2D' + + REAL, DIMENSION(nbp_lon,nbp_lat) :: var_glo2D ! 2D global + REAL, DIMENSION(nbp_lon,nbp_lat) :: var_glo2D_tmp ! 2D global + REAL, DIMENSION(klon_glo) :: var_glo1D ! 1D global + + +! Read variable from file. Done by master process MPI and master thread OpenMP + IF (is_mpi_root .AND. is_omp_root) THEN + ierr = NF90_OPEN (filename, NF90_NOWRITE, nid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Problem in opening file '//filename,1) + + ierr = NF90_INQ_VARID(nid, varname, nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname, 'The variable '//varname//' is absent in file',1) + + start=(/1,1,timestep/) + count=(/nbp_lon,nbp_lat,1/) + ierr = NF90_GET_VAR(nid, nvarid, var_glo2D,start,count) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname, 'Problem in reading varaiable '//varname,1) + + ! Inverse latitude order + IF (inverse) THEN + var_glo2D_tmp(:,:) = var_glo2D(:,:) + DO j=1, nbp_lat + var_glo2D(:,j) = var_glo2D_tmp(:,nbp_lat-j+1) + END DO + END IF + + ! Transform the global field from 2D to 1D + CALL grid2Dto1D_glo(var_glo2D,var_glo1D) + + ENDIF + +! Scatter gloabl 1D variable to all processes + CALL scatter(var_glo1D, varout) + +END SUBROUTINE read_map2D Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/read_pstoke.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/read_pstoke.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/read_pstoke.F (revision 1280) @@ -0,0 +1,487 @@ +! +! $Header$ +! +c +c + subroutine read_pstoke(irec, + . zrec,zklono,zklevo,airefi,phisfi, + . t,mfu,mfd,en_u,de_u,en_d,de_d,coefh, + . fm_therm,en_therm, + . frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf) + +C****************************************************************************** +C Frederic HOURDIN, Abderrahmane IDELKADI +C Lecture des parametres physique stockes online necessaires pour +C recalculer offline le transport de traceurs sur une grille 2x plus fine que +C celle online +C A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)! +C****************************************************************************** + + use netcdf + USE dimphy + IMPLICIT NONE + +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "indicesol.h" +#include "control.h" +cccc#include "dimphy.h" + + integer klono,klevo,imo,jmo + parameter (imo=iim/2,jmo=(jjm+1)/2) + parameter(klono=(jmo-1)*imo+2,klevo=llm) + REAL phisfi(klono) + REAL phisfi2(imo,jmo+1),airefi2(imo,jmo+1) + + REAL mfu(klono,klevo), mfd(klono,klevo) + REAL en_u(klono,klevo), de_u(klono,klevo) + REAL en_d(klono,klevo), de_d(klono,klevo) + REAL coefh(klono,klevo) + REAL fm_therm(klono,klevo),en_therm(klono,klevo) + + REAL mfu2(imo,jmo+1,klevo), mfd2(imo,jmo+1,klevo) + REAL en_u2(imo,jmo+1,klevo), de_u2(imo,jmo+1,klevo) + REAL en_d2(imo,jmo+1,klevo), de_d2(imo,jmo+1,klevo) + REAL coefh2(imo,jmo+1,klevo) + REAL fm_therm2(imo,jmo+1,klevo) + REAL en_therm2(imo,jmo+1,klevo) + + REAL pl(klevo) + integer irec + integer xid,yid,zid,tid + real zrec,zklono,zklevo,zim,zjm + integer ncrec,ncklono,ncklevo,ncim,ncjm + + real airefi(klono) + character*20 namedim + +c !! attention !! +c attention il y a aussi le pb de def klono +c dim de phis?? + + + REAL frac_impa(klono,klevo), frac_nucl(klono,klevo) + REAL frac_impa2(imo,jmo+1,klevo), + . frac_nucl2(imo,jmo+1,klevo) + REAL pyu1(klono), pyv1(klono) + REAL pyu12(imo,jmo+1), pyv12(imo,jmo+1) + REAL ftsol(klono,nbsrf) + REAL psrf(klono,nbsrf) + REAL ftsol1(klono),ftsol2(klono),ftsol3(klono),ftsol4(klono) + REAL psrf1(klono),psrf2(klono),psrf3(klono),psrf4(klono) + REAL ftsol12(imo,jmo+1),ftsol22(imo,jmo+1), + . ftsol32(imo,jmo+1), + . ftsol42(imo,jmo+1) + REAL psrf12(imo,jmo+1),psrf22(imo,jmo+1),psrf32(imo,jmo+1), + . psrf42(imo,jmo+1) + REAL t(klono,klevo) + REAL t2(imo,jmo+1,klevo) + integer ncidp + save ncidp + integer varidt + integer varidmfu, varidmfd, varidps, varidenu, variddeu + integer varidend,varidded,varidch,varidfi,varidfn + integer varidfmth,varidenth + integer varidyu1,varidyv1,varidpl,varidai,varididvt + integer varidfts1,varidfts2,varidfts3,varidfts4 + integer varidpsr1,varidpsr2,varidpsr3,varidpsr4 + save varidmfu, varidmfd, varidps, varidenu, variddeu + save varidend,varidded,varidch,varidfi,varidfn + save varidfmth,varidenth + save varidyu1,varidyv1,varidpl,varidai,varididvt + save varidfts1,varidfts2,varidfts3,varidfts4 + save varidpsr1,varidpsr2,varidpsr3,varidpsr4 + save varidt + + integer l, i + integer start(4),count(4),status + real rcode + logical first + save first + data first/.true./ + + + +c --------------------------------------------- +c Initialisation de la lecture des fichiers +c --------------------------------------------- + + if (irec .eq. 0) then + + rcode=nf90_open('phystoke.nc',nf90_nowrite,ncidp) + + rcode = nf90_inq_varid(ncidp, 'phis', varidps) + print*,'ncidp,varidps',ncidp,varidps + + rcode = nf90_inq_varid(ncidp, 'sig_s', varidpl) + print*,'ncidp,varidpl',ncidp,varidpl + + rcode = nf90_inq_varid(ncidp, 'aire', varidai) + print*,'ncidp,varidai',ncidp,varidai + +c A FAIRE: Es-il necessaire de stocke t? + rcode = nf90_inq_varid(ncidp, 't', varidt) + print*,'ncidp,varidt',ncidp,varidt + + rcode = nf90_inq_varid(ncidp, 'mfu', varidmfu) + print*,'ncidp,varidmfu',ncidp,varidmfu + + rcode = nf90_inq_varid(ncidp, 'mfd', varidmfd) + print*,'ncidp,varidmfd',ncidp,varidmfd + + rcode = nf90_inq_varid(ncidp, 'en_u', varidenu) + print*,'ncidp,varidenu',ncidp,varidenu + + rcode = nf90_inq_varid(ncidp, 'de_u', variddeu) + print*,'ncidp,variddeu',ncidp,variddeu + + rcode = nf90_inq_varid(ncidp, 'en_d', varidend) + print*,'ncidp,varidend',ncidp,varidend + + rcode = nf90_inq_varid(ncidp, 'de_d', varidded) + print*,'ncidp,varidded',ncidp,varidded + + rcode = nf90_inq_varid(ncidp, 'coefh', varidch) + print*,'ncidp,varidch',ncidp,varidch + +c abder (pour thermiques) + rcode = nf90_inq_varid(ncidp, 'fm_th', varidfmth) + print*,'ncidp,varidfmth',ncidp,varidfmth + + rcode = nf90_inq_varid(ncidp, 'en_th', varidenth) + print*,'ncidp,varidenth',ncidp,varidenth + + rcode = nf90_inq_varid(ncidp, 'frac_impa', varidfi) + print*,'ncidp,varidfi',ncidp,varidfi + + rcode = nf90_inq_varid(ncidp, 'frac_nucl', varidfn) + print*,'ncidp,varidfn',ncidp,varidfn + + rcode = nf90_inq_varid(ncidp, 'pyu1', varidyu1) + print*,'ncidp,varidyu1',ncidp,varidyu1 + + rcode = nf90_inq_varid(ncidp, 'pyv1', varidyv1) + print*,'ncidp,varidyv1',ncidp,varidyv1 + + rcode = nf90_inq_varid(ncidp, 'ftsol1', varidfts1) + print*,'ncidp,varidfts1',ncidp,varidfts1 + + rcode = nf90_inq_varid(ncidp, 'ftsol2', varidfts2) + print*,'ncidp,varidfts2',ncidp,varidfts2 + + rcode = nf90_inq_varid(ncidp, 'ftsol3', varidfts3) + print*,'ncidp,varidfts3',ncidp,varidfts3 + + rcode = nf90_inq_varid(ncidp, 'ftsol4', varidfts4) + print*,'ncidp,varidfts4',ncidp,varidfts4 + + rcode = nf90_inq_varid(ncidp, 'psrf1', varidpsr1) + print*,'ncidp,varidpsr1',ncidp,varidpsr1 + + rcode = nf90_inq_varid(ncidp, 'psrf2', varidpsr2) + print*,'ncidp,varidpsr2',ncidp,varidpsr2 + + rcode = nf90_inq_varid(ncidp, 'psrf3', varidpsr3) + print*,'ncidp,varidpsr3',ncidp,varidpsr3 + + rcode = nf90_inq_varid(ncidp, 'psrf4', varidpsr4) + print*,'ncidp,varidpsr4',ncidp,varidpsr4 + +c ID pour les dimensions + + status = nf_inq_dimid(ncidp,'y',yid) + status = nf_inq_dimid(ncidp,'x',xid) + status = nf_inq_dimid(ncidp,'sig_s',zid) + status = nf_inq_dimid(ncidp,'time_counter',tid) + +c lecture des dimensions + + status = nf_inq_dim(ncidp,yid,namedim,ncjm) + status = nf_inq_dim(ncidp,xid,namedim,ncim) + status = nf_inq_dim(ncidp,zid,namedim,ncklevo) + status = nf_inq_dim(ncidp,tid,namedim,ncrec) + + zrec=ncrec + zklevo=ncklevo + zim=ncim + zjm=ncjm + + zklono=zim*(zjm-2)+2 + + write(*,*) 'read_pstoke : zrec = ', zrec + write(*,*) 'read_pstoke : zklevo = ', zklevo + write(*,*) 'read_pstoke : zim = ', zim + write(*,*) 'read_pstoke : zjm = ', zjm + write(*,*) 'read_pstoke : zklono = ', zklono + +c niveaux de pression +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpl,1,zklevo,pl) +#else + status=NF_GET_VARA_REAL(ncidp,varidpl,1,zklevo,pl) +#endif + +c lecture de aire et phis + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=0 + + count(1)=zim + count(2)=zjm + count(3)=1 + count(4)=0 + +c phis +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidps,start,count,phisfi2) +#else + status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,phisfi2,phisfi) + +c aire +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidai,start,count,airefi2) +#else + status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,airefi2,airefi) + else + + print*,'ok1' + +c --------------------- +c lecture des champs +c --------------------- + + print*,'WARNING!!! Il n y a pas de test de coherence' + print*,'sur le nombre de niveaux verticaux dans le fichier nc' + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=irec + + count(1)=zim + count(2)=zjm + count(3)=zklevo + count(4)=1 + + +C *** Lessivage****************************************************** +c frac_impa +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfi,start,count,frac_impa2) +#else + status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_impa2,frac_impa) + +c frac_nucl +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfn,start,count,frac_nucl2) +#else + status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_nucl2,frac_nucl) + +C*** Temperature ****************************************************** +c abder t +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidt,start,count,t2) +#else + status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,t2,t) + +C*** Flux pour le calcul de la convection TIEDTK *********************** +c mfu +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidmfu,start,count,mfu2) +#else + status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfu2,mfu) + +c mfd +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidmfd,start,count,mfd2) +#else + status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfd2,mfd) + +c en_u +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidenu,start,count,en_u2) +#else + status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_u2,en_u) + +c de_u +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,variddeu,start,count,de_u2) +#else + status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_u2,de_u) + +c en_d +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidend,start,count,en_d2) +#else + status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_d2,en_d) + +c de_d +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidded,start,count,de_d2) +#else + status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_d2,de_d) + +C **** Coeffecient du mellange turbulent********************************** +c coefh +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidch,start,count,coefh2) +#else + status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,coefh2,coefh) + +C*** Flux ascendant et entrant pour les Thermiques************************ +cabder thermiques +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfmth,start,count,fm_therm2) +#else + status=NF_GET_VARA_REAL(ncidp,varidfmth,start,count,fm_therm2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,fm_therm2,fm_therm) + +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidenth,start,count,en_therm2) +#else + status=NF_GET_VARA_REAL(ncidp,varidenth,start,count,en_therm2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_therm2,en_therm) + +C*** Vitesses aux sol ****************************************************** + start(3)=irec + start(4)=0 + count(3)=1 + count(4)=0 +c pyu1 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidyu1,start,count,pyu12) +#else + status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,pyu12,pyu1) + +c pyv1 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidyv1,start,count,pyv12) +#else + status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,pyv12,pyv1) + +C*** Temperature au sol ******************************************** +c ftsol1 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfts1,start,count,ftsol12) +#else + status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol12,ftsol1) + +c ftsol2 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfts2,start,count,ftsol22) +#else + status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol22,ftsol2) + +c ftsol3 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfts3,start,count,ftsol32) +#else + status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol32,ftsol3) + +c ftsol4 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfts4,start,count,ftsol42) +#else + status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol42,ftsol4) + +C*** Nature du sol ************************************************** +c psrf1 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpsr1,start,count,psrf12) +#else + status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,psrf12,psrf1) + +c psrf2 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpsr2,start,count,psrf22) +#else + status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,psrf22,psrf2) + +c psrf3 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpsr3,start,count,psrf32) +#else + status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,psrf32,psrf3) + +c psrf4 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpsr4,start,count,psrf42) +#else + status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,psrf42,psrf4) + + do i = 1,klono + + psrf(i,1) = psrf1(i) + psrf(i,2) = psrf2(i) + psrf(i,3) = psrf3(i) + psrf(i,4) = psrf4(i) + + ftsol(i,1) = ftsol1(i) + ftsol(i,2) = ftsol2(i) + ftsol(i,3) = ftsol3(i) + ftsol(i,4) = ftsol4(i) + + enddo + + endif + + return + + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/read_pstoke0.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/read_pstoke0.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/read_pstoke0.F (revision 1280) @@ -0,0 +1,511 @@ +! +! $Header$ +! +c +c + subroutine read_pstoke0(irec, + . zrec,zkon,zkev,airefi,phisfi, + . t,mfu,mfd,en_u,de_u,en_d,de_d,coefh, + . fm_therm,en_therm, + . frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf) + +C****************************************************************************** +C Frederic HOURDIN, Abderrahmane IDELKADI +C Lecture des parametres physique stockes online necessaires pour +C recalculer offline le transport des traceurs sur la meme grille que online +C A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)! +C****************************************************************************** + + use netcdf + USE dimphy + IMPLICIT NONE + +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "indicesol.h" +#include "control.h" +cccc#include "dimphy.h" + + integer kon,kev,zkon,zkev + parameter(kon=iim*(jjm-1)+2,kev=llm) + REAL phisfi(kon) + REAL phisfi2(iim,jjm+1),airefi2(iim,jjm+1) + + REAL mfu(kon,kev), mfd(kon,kev) + REAL en_u(kon,kev), de_u(kon,kev) + REAL en_d(kon,kev), de_d(kon,kev) + REAL coefh(kon,kev) + +c abd 25 11 02 +c Thermiques + REAL fm_therm(kon,kev),en_therm(kon,kev) + REAL t(kon,kev) + + REAL mfu2(iim,jjm+1,kev), mfd2(iim,jjm+1,kev) + REAL en_u2(iim,jjm+1,kev), de_u2(iim,jjm+1,kev) + REAL en_d2(iim,jjm+1,kev), de_d2(iim,jjm+1,kev) + REAL coefh2(iim,jjm+1,kev) + REAL t2(iim,jjm+1,kev) +c Thermiques + REAL fm_therm2(iim,jjm+1,kev) + REAL en_therm2(iim,jjm+1,kev) + + REAL pl(kev) + integer irec + integer xid,yid,zid,tid + integer zrec,zim,zjm + integer ncrec,nckon,nckev,ncim,ncjm + + real airefi(kon) + character*20 namedim + +c !! attention !! +c attention il y a aussi le pb de def kon +c dim de phis?? + + REAL frac_impa(kon,kev), frac_nucl(kon,kev) + REAL frac_impa2(iim,jjm+1,kev), + . frac_nucl2(iim,jjm+1,kev) + REAL pyu1(kon), pyv1(kon) + REAL pyu12(iim,jjm+1), pyv12(iim,jjm+1) + REAL ftsol(kon,nbsrf) + REAL psrf(kon,nbsrf) + REAL ftsol1(kon),ftsol2(kon),ftsol3(kon),ftsol4(kon) + REAL psrf1(kon),psrf2(kon),psrf3(kon),psrf4(kon) + REAL ftsol12(iim,jjm+1),ftsol22(iim,jjm+1), + . ftsol32(iim,jjm+1), + . ftsol42(iim,jjm+1) + REAL psrf12(iim,jjm+1),psrf22(iim,jjm+1),psrf32(iim,jjm+1), + . psrf42(iim,jjm+1) + + integer ncidp + save ncidp + integer varidmfu, varidmfd, varidps, varidenu, variddeu + integer varidt + integer varidend,varidded,varidch,varidfi,varidfn +c therm + integer varidfmth,varidenth + integer varidyu1,varidyv1,varidpl,varidai,varididvt + integer varidfts1,varidfts2,varidfts3,varidfts4 + integer varidpsr1,varidpsr2,varidpsr3,varidpsr4 + save varidmfu, varidmfd, varidps, varidenu, variddeu + save varidt + save varidend,varidded,varidch,varidfi,varidfn +c therm + save varidfmth,varidenth + save varidyu1,varidyv1,varidpl,varidai,varididvt + save varidfts1,varidfts2,varidfts3,varidfts4 + save varidpsr1,varidpsr2,varidpsr3,varidpsr4 + + integer l, i + integer start(4),count(4),status + real rcode + logical first + save first + data first/.true./ + + + +c --------------------------------------------- +c Initialisation de la lecture des fichiers +c --------------------------------------------- + + if (irec .eq. 0) then + + rcode=nf90_open('phystoke.nc',nf90_nowrite,ncidp) + + rcode = nf90_inq_varid(ncidp, 'phis', varidps) + print*,'ncidp,varidps',ncidp,varidps + + rcode = nf90_inq_varid(ncidp, 'sig_s', varidpl) + print*,'ncidp,varidpl',ncidp,varidpl + + rcode = nf90_inq_varid(ncidp, 'aire', varidai) + print*,'ncidp,varidai',ncidp,varidai + + rcode = nf90_inq_varid(ncidp, 't', varidt) + print*,'ncidp,varidt',ncidp,varidt + + rcode = nf90_inq_varid(ncidp, 'mfu', varidmfu) + print*,'ncidp,varidmfu',ncidp,varidmfu + + rcode = nf90_inq_varid(ncidp, 'mfd', varidmfd) + print*,'ncidp,varidmfd',ncidp,varidmfd + + rcode = nf90_inq_varid(ncidp, 'en_u', varidenu) + print*,'ncidp,varidenu',ncidp,varidenu + + rcode = nf90_inq_varid(ncidp, 'de_u', variddeu) + print*,'ncidp,variddeu',ncidp,variddeu + + rcode = nf90_inq_varid(ncidp, 'en_d', varidend) + print*,'ncidp,varidend',ncidp,varidend + + rcode = nf90_inq_varid(ncidp, 'de_d', varidded) + print*,'ncidp,varidded',ncidp,varidded + + rcode = nf90_inq_varid(ncidp, 'coefh', varidch) + print*,'ncidp,varidch',ncidp,varidch + +c Thermiques + rcode = nf90_inq_varid(ncidp, 'fm_th', varidfmth) + print*,'ncidp,varidfmth',ncidp,varidfmth + + rcode = nf90_inq_varid(ncidp, 'en_th', varidenth) + print*,'ncidp,varidenth',ncidp,varidenth + + rcode = nf90_inq_varid(ncidp, 'frac_impa', varidfi) + print*,'ncidp,varidfi',ncidp,varidfi + + rcode = nf90_inq_varid(ncidp, 'frac_nucl', varidfn) + print*,'ncidp,varidfn',ncidp,varidfn + + rcode = nf90_inq_varid(ncidp, 'pyu1', varidyu1) + print*,'ncidp,varidyu1',ncidp,varidyu1 + + rcode = nf90_inq_varid(ncidp, 'pyv1', varidyv1) + print*,'ncidp,varidyv1',ncidp,varidyv1 + + rcode = nf90_inq_varid(ncidp, 'ftsol1', varidfts1) + print*,'ncidp,varidfts1',ncidp,varidfts1 + + rcode = nf90_inq_varid(ncidp, 'ftsol2', varidfts2) + print*,'ncidp,varidfts2',ncidp,varidfts2 + + rcode = nf90_inq_varid(ncidp, 'ftsol3', varidfts3) + print*,'ncidp,varidfts3',ncidp,varidfts3 + + rcode = nf90_inq_varid(ncidp, 'ftsol4', varidfts4) + print*,'ncidp,varidfts4',ncidp,varidfts4 + + rcode = nf90_inq_varid(ncidp, 'psrf1', varidpsr1) + print*,'ncidp,varidpsr1',ncidp,varidpsr1 + + rcode = nf90_inq_varid(ncidp, 'psrf2', varidpsr2) + print*,'ncidp,varidpsr2',ncidp,varidpsr2 + + rcode = nf90_inq_varid(ncidp, 'psrf3', varidpsr3) + print*,'ncidp,varidpsr3',ncidp,varidpsr3 + + rcode = nf90_inq_varid(ncidp, 'psrf4', varidpsr4) + print*,'ncidp,varidpsr4',ncidp,varidpsr4 + +c ID pour les dimensions + + status = nf_inq_dimid(ncidp,'y',yid) + status = nf_inq_dimid(ncidp,'x',xid) + status = nf_inq_dimid(ncidp,'sig_s',zid) + status = nf_inq_dimid(ncidp,'time_counter',tid) + +c lecture des dimensions + + status = nf_inq_dim(ncidp,yid,namedim,ncjm) + status = nf_inq_dim(ncidp,xid,namedim,ncim) + status = nf_inq_dim(ncidp,zid,namedim,nckev) + status = nf_inq_dim(ncidp,tid,namedim,ncrec) + + zrec=ncrec + zkev=nckev + zim=ncim + zjm=ncjm + + zkon=zim*(zjm-2)+2 + + write(*,*) 'read_pstoke : zrec = ', zrec + write(*,*) 'read_pstoke : kev = ', zkev + write(*,*) 'read_pstoke : zim = ', zim + write(*,*) 'read_pstoke : zjm = ', zjm + write(*,*) 'read_pstoke : kon = ', zkon + +c niveaux de pression + + status=NF_GET_VARA_REAL(ncidp,varidpl,1,kev,pl) + +c lecture de aire et phis + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=0 + + count(1)=zim + count(2)=zjm + count(3)=1 + count(4)=0 + +c +C**** Geopotentiel au sol *************************************** +c phis +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidps,start,count,phisfi2) +#else + status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,phisfi2,phisfi) + +C**** Aires des mails aux sol ************************************ +c aire +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidai,start,count,airefi2) +#else + status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,airefi2,airefi) + else + + print*,'ok1' + +c --------------------- +c lecture des champs +c --------------------- + + print*,'WARNING!!! Il n y a pas de test de coherence' + print*,'sur le nombre de niveaux verticaux dans le fichier nc' + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=irec + + count(1)=zim + count(2)=zjm + count(3)=kev + count(4)=1 + +C**** Temperature ******************************************** +cA FAIRE : Es-ce necessaire ? + +c abder t +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidt,start,count,t2) +#else + status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,t2,t) + +C**** Flux pour la convection (Tiedtk) ******************************************** +c mfu +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidmfu,start,count,mfu2) +#else + status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,mfu2,mfu) + +c mfd +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidmfd,start,count,mfd2) +#else + status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,mfd2,mfd) + +c en_u +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidenu,start,count,en_u2) +#else + status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,en_u2,en_u) + +c de_u +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,variddeu,start,count,de_u2) +#else + status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,de_u2,de_u) + +c en_d +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidend,start,count,en_d2) +#else + status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,en_d2,en_d) + +c de_d +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidded,start,count,de_d2) +#else + status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,de_d2,de_d) + +C**** Coefficient de mellange turbulent ******************************************* +c coefh + print*,'LECTURE de coefh a irec =',irec +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidch,start,count,coefh2) +#else + status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,coefh2,coefh) +c call dump2d(iip1,jjp1,coefh2(1,2),'COEFH2READ ') +c call dump2d(iim ,jjm ,coefh (2,2),'COEFH2READ ') + +C**** Flux ascendants et entrant dans le thermique ********************************** +cThermiques + print*,'LECTURE de fm_therm a irec =',irec +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfmth,start, + . count,fm_therm2) +#else + status=NF_GET_VARA_REAL(ncidp,varidfmth,start, + . count,fm_therm2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,fm_therm2,fm_therm) + print*,'LECTURE de en_therm a irec =',irec +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidenth,start, + . count,en_therm2) +#else + status=NF_GET_VARA_REAL(ncidp,varidenth,start, + . count,en_therm2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,en_therm2,en_therm) + +C**** Coefficients de lessivage ******************************************* +c frac_impa +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfi,start,count,frac_impa2) +#else + status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_impa2,frac_impa) + +c frac_nucl + +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfn,start,count,frac_nucl2) +#else + status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_nucl2,frac_nucl) + +C**** Vents aux sol ******************************************** + + start(3)=irec + start(4)=0 + count(3)=1 + count(4)=0 + +c pyu1 + print*,'LECTURE de yu1 a irec =',irec +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidyu1,start,count,pyu12) +#else + status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,pyu12,pyu1) + +c pyv1 + print*,'LECTURE de yv1 a irec =',irec +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidyv1,start,count,pyv12) +#else + status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,pyv12,pyv1) + +C**** Temerature au sol ******************************************** +c ftsol1 + print*,'LECTURE de ftsol1 a irec =',irec +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfts1,start,count,ftsol12) +#else + status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol12,ftsol1) + +c ftsol2 + print*,'LECTURE de ftsol2 a irec =',irec +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfts2,start,count,ftsol22) +#else + status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol22,ftsol2) + +c ftsol3 + print*,'LECTURE de ftsol3 a irec =',irec +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfts3,start,count,ftsol32) +#else + status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol32,ftsol3) + +c ftsol4 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfts4,start,count,ftsol42) +#else + status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol42,ftsol4) + +C**** Nature sol ******************************************** +c psrf1 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpsr1,start,count,psrf12) +#else + status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12) +#endif +c call dump2d(iip1-1,jjm+1,psrf12,'PSRF1NC') + call gr_ecrit_fi(1,kon,iim,jjm+1,psrf12,psrf1) + +c psrf2 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpsr2,start,count,psrf22) +#else + status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22) +#endif +c call dump2d(iip1-1,jjm+1,psrf22,'PSRF2NC') + call gr_ecrit_fi(1,kon,iim,jjm+1,psrf22,psrf2) + +c psrf3 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpsr3,start,count,psrf32) +#else + status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,psrf32,psrf3) + +c psrf4 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpsr4,start,count,psrf42) +#else + status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,psrf42,psrf4) + + do i = 1,kon + + psrf(i,1) = psrf1(i) + psrf(i,2) = psrf2(i) + psrf(i,3) = psrf3(i) +c test abderr +c print*,'Dans read_pstoke psrf3 =',psrf3(i),i + psrf(i,4) = psrf4(i) + + ftsol(i,1) = ftsol1(i) + ftsol(i,2) = ftsol2(i) + ftsol(i,3) = ftsol3(i) + ftsol(i,4) = ftsol4(i) + + enddo + + endif + + return + + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/readaerosol.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/readaerosol.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/readaerosol.F90 (revision 1280) @@ -0,0 +1,566 @@ +! $Id$ +! +MODULE readaerosol_mod + + REAL, SAVE :: not_valid=-333. + +CONTAINS + +SUBROUTINE readaerosol(name_aero, type, iyr_in, klev_src, pt_ap, pt_b, pt_out, psurf, load) + +!**************************************************************************************** +! This routine will read the aersosol from file. +! +! Read a year data with get_aero_fromfile depending on aer_type : +! - actuel : read year 1980 +! - preind : read natural data +! - scenario : read one or two years and do eventually linare time interpolation +! +! Return pointer, pt_out, to the year read or result from interpolation +!**************************************************************************************** + USE dimphy + + IMPLICIT NONE + + INCLUDE "iniprint.h" + + ! Input arguments + CHARACTER(len=7), INTENT(IN) :: name_aero + CHARACTER(len=*), INTENT(IN) :: type ! correspond to aer_type in clesphys.h + INTEGER, INTENT(IN) :: iyr_in + + ! Output + INTEGER, INTENT(OUT) :: klev_src + REAL, POINTER, DIMENSION(:) :: pt_ap ! Pointer for describing the vertical levels + REAL, POINTER, DIMENSION(:) :: pt_b ! Pointer for describing the vertical levels + REAL, POINTER, DIMENSION(:,:,:) :: pt_out ! The massvar distributions, DIMENSION(klon, klev_src, 12) + REAL, DIMENSION(klon,12), INTENT(OUT) :: psurf ! Surface pression for 12 months + REAL, DIMENSION(klon,12), INTENT(OUT) :: load ! Aerosol mass load in each column for 12 months + + ! Local variables + CHARACTER(len=4) :: cyear + REAL, POINTER, DIMENSION(:,:,:) :: pt_2 + REAL, DIMENSION(klon,12) :: psurf2, load2 + REAL :: p0 ! Reference pressure + INTEGER :: iyr1, iyr2, klev_src2 + INTEGER :: it, k, i + LOGICAL, PARAMETER :: lonlyone=.FALSE. + +!**************************************************************************************** +! Read data depending on aer_type +! +!**************************************************************************************** + + IF (type == 'actuel') THEN +! Read and return data for year 1980 +!**************************************************************************************** + cyear='1980' + ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month + ! pt_out has dimensions (klon, klev_src, 12) + CALL get_aero_fromfile(name_aero, cyear, klev_src, pt_ap, pt_b, p0, pt_out, psurf, load) + + + ELSE IF (type == 'preind') THEN +! Read and return data from file with suffix .nat +!**************************************************************************************** + cyear='.nat' + ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month + ! pt_out has dimensions (klon, klev_src, 12) + CALL get_aero_fromfile(name_aero, cyear, klev_src, pt_ap, pt_b, p0, pt_out, psurf, load) + + ELSE IF (type == 'scenario') THEN +! Read data depending on actual year and interpolate if necessary +!**************************************************************************************** + IF (iyr_in .LT. 1850) THEN + cyear='.nat' + WRITE(lunout,*) 'get_aero 1 iyr_in=', iyr_in,' ',cyear + ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month + ! pt_out has dimensions (klon, klev_src, 12) + CALL get_aero_fromfile(name_aero, cyear, klev_src, pt_ap, pt_b, p0, pt_out, psurf, load) + + ELSE IF (iyr_in .GE. 2100) THEN + cyear='2100' + WRITE(lunout,*) 'get_aero 2 iyr_in=', iyr_in,' ',cyear + ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month + ! pt_out has dimensions (klon, klev_src, 12) + CALL get_aero_fromfile(name_aero, cyear, klev_src, pt_ap, pt_b, p0, pt_out, psurf, load) + + ELSE + ! Read data from 2 decades and interpolate to actual year + ! a) from actual 10-yr-period + IF (iyr_in.LT.1900) THEN + iyr1 = 1850 + iyr2 = 1900 + ELSE IF (iyr_in.GE.1900.AND.iyr_in.LT.1920) THEN + iyr1 = 1900 + iyr2 = 1920 + ELSE + iyr1 = INT(iyr_in/10)*10 + iyr2 = INT(1+iyr_in/10)*10 + ENDIF + + WRITE(cyear,'(I4)') iyr1 + WRITE(lunout,*) 'get_aero 3 iyr_in=', iyr_in,' ',cyear + ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month + ! pt_out has dimensions (klon, klev_src, 12) + CALL get_aero_fromfile(name_aero, cyear, klev_src, pt_ap, pt_b, p0, pt_out, psurf, load) + + ! If to read two decades: + IF (.NOT.lonlyone) THEN + + ! b) from the next following one + WRITE(cyear,'(I4)') iyr2 + WRITE(lunout,*) 'get_aero 4 iyr_in=', iyr_in,' ',cyear + + NULLIFY(pt_2) + ! get_aero_fromfile returns pt_2 allocated and initialized with data for 12 month + ! pt_2 has dimensions (klon, klev_src, 12) + CALL get_aero_fromfile(name_aero, cyear, klev_src2, pt_ap, pt_b, p0, pt_2, psurf2, load2) + ! Test for same number of vertical levels + IF (klev_src /= klev_src2) THEN + WRITE(lunout,*) 'Two aerosols files with different number of vertical levels is not allowded' + CALL abort_gcm('readaersosol','Error in number of vertical levels',1) + END IF + + ! Linare interpolate to the actual year: + DO it=1,12 + DO k=1,klev_src + DO i = 1, klon + pt_out(i,k,it) = & + pt_out(i,k,it) - FLOAT(iyr_in-iyr1)/FLOAT(iyr2-iyr1) * & + (pt_out(i,k,it) - pt_2(i,k,it)) + END DO + END DO + + DO i = 1, klon + psurf(i,it) = & + psurf(i,it) - FLOAT(iyr_in-iyr1)/FLOAT(iyr2-iyr1) * & + (psurf(i,it) - psurf2(i,it)) + + load(i,it) = & + load(i,it) - FLOAT(iyr_in-iyr1)/FLOAT(iyr2-iyr1) * & + (load(i,it) - load2(i,it)) + END DO + END DO + + ! Deallocate pt_2 no more needed + DEALLOCATE(pt_2) + + END IF ! lonlyone + END IF ! iyr_in .LT. 1850 + + ELSE + WRITE(lunout,*)'This option is not implemented : aer_type = ', type + CALL abort_gcm('readaerosol','Error : aer_type parameter not accepted',1) + END IF ! type + + +END SUBROUTINE readaerosol + + + SUBROUTINE get_aero_fromfile(varname, cyr, klev_src, pt_ap, pt_b, p0, pt_year, psurf_out, load_out) +!**************************************************************************************** +! Read 12 month aerosol from file and distribute to local process on physical grid. +! Vertical levels, klev_src, may differ from model levels if new file format. +! +! For mpi_root and master thread : +! 1) Open file +! 2) Find vertical dimension klev_src +! 3) Read field month by month +! 4) Close file +! 5) Transform the global field from 2D(iim, jjp+1) to 1D(klon_glo) +! - Also the levels and the latitudes have to be inversed +! +! For all processes and threads : +! 6) Scatter global field(klon_glo) to local process domain(klon) +! 7) Test for negative values +!**************************************************************************************** + + USE netcdf + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE iophy, ONLY : io_lon, io_lat + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "iniprint.h" + +! Input argumets + CHARACTER(len=7), INTENT(IN) :: varname + CHARACTER(len=4), INTENT(IN) :: cyr + +! Output arguments + INTEGER, INTENT(OUT) :: klev_src ! Number of vertical levels in file + REAL, POINTER, DIMENSION(:) :: pt_ap ! Pointer for describing the vertical levels + REAL, POINTER, DIMENSION(:) :: pt_b ! Pointer for describing the vertical levels + REAL :: p0 ! Reference pressure value + REAL, POINTER, DIMENSION(:,:,:) :: pt_year ! Pointer-variabale from file, 12 month, grid : klon,klev_src + REAL, DIMENSION(klon,12), INTENT(OUT) :: psurf_out ! Surface pression for 12 months + REAL, DIMENSION(klon,12), INTENT(OUT) :: load_out ! Aerosol mass load in each column + +! Local variables + CHARACTER(len=30) :: fname + CHARACTER(len=8) :: filename='aerosols' + CHARACTER(len=30) :: cvar + INTEGER :: ncid, dimid, varid + INTEGER :: imth, i, j, k, ierr + REAL :: npole, spole + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: varmth + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: varyear ! Global variable read from file, 12 month + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: varyear_glo1D !(klon_glo, klev_src, 12) + REAL, ALLOCATABLE, DIMENSION(:) :: varktmp + + REAL, DIMENSION(iim,jjm+1,12) :: psurf_glo2D ! Surface pression for 12 months on dynamics global grid + REAL, DIMENSION(klon_glo,12) :: psurf_glo1D ! -"- on physical global grid + REAL, DIMENSION(iim,jjm+1,12) :: load_glo2D ! Load for 12 months on dynamics global grid + REAL, DIMENSION(klon_glo,12) :: load_glo1D ! -"- on physical global grid + REAL, DIMENSION(iim,jjm+1) :: vartmp + REAL, DIMENSION(iim) :: lon_src ! longitudes in file + REAL, DIMENSION(jjm+1) :: lat_src, lat_src_inv ! latitudes in file + LOGICAL :: new_file ! true if new file format detected + LOGICAL :: invert_lat ! true if the field has to be inverted for latitudes + + + ! Deallocate pointers + IF (ASSOCIATED(pt_ap)) DEALLOCATE(pt_ap) + IF (ASSOCIATED(pt_b)) DEALLOCATE(pt_b) + + IF (is_mpi_root .AND. is_omp_root) THEN + +! 1) Open file +!**************************************************************************************** + fname = filename//cyr//'.nc' + + WRITE(lunout,*) 'reading ', TRIM(fname) + CALL check_err( nf90_open(TRIM(fname), NF90_NOWRITE, ncid) ) + +! Test for equal longitudes and latitudes in file and model +!**************************************************************************************** + ! Read and test longitudes + CALL check_err( nf90_inq_varid(ncid, 'lon', varid) ) + CALL check_err( nf90_get_var(ncid, varid, lon_src(:)) ) + + IF (maxval(ABS(lon_src - io_lon)) > 0.001) THEN + WRITE(lunout,*) 'Problem in longitudes read from file : ',TRIM(fname) + WRITE(lunout,*) 'longitudes in file ', TRIM(fname),' : ', lon_src + WRITE(lunout,*) 'longitudes in model :', io_lon + + CALL abort_gcm('get_aero_fromfile', 'longitudes are not the same in file and model',1) + END IF + + ! Read and test latitudes + CALL check_err( nf90_inq_varid(ncid, 'lat', varid) ) + CALL check_err( nf90_get_var(ncid, varid, lat_src(:)) ) + + ! Invert source latitudes + DO j = 1, jjm+1 + lat_src_inv(j) = lat_src(jjm+1 +1 -j) + END DO + + IF (maxval(ABS(lat_src - io_lat)) < 0.001) THEN + ! Latitudes are the same + invert_lat=.FALSE. + ELSE IF (maxval(ABS(lat_src_inv - io_lat)) < 0.001) THEN + ! Inverted source latitudes correspond to model latitudes + WRITE(lunout,*) 'latitudes will be inverted for file : ',TRIM(fname) + invert_lat=.TRUE. + ELSE + WRITE(lunout,*) 'Problem in latitudes read from file : ',TRIM(fname) + WRITE(lunout,*) 'latitudes in file ', TRIM(fname),' : ', lat_src + WRITE(lunout,*) 'latitudes in model :', io_lat + CALL abort_gcm('get_aero_fromfile', 'latitudes do not correspond between file and model',1) + END IF + +! 2) Check if old or new file is avalabale. +! New type of file should contain the dimension 'lev' +! Old type of file should contain the dimension 'PRESNIVS' +!**************************************************************************************** + ierr = nf90_inq_dimid(ncid, 'lev', dimid) + IF (ierr /= NF90_NOERR) THEN + ! Coordinate axe lev not found. Check for presnivs. + ierr = nf90_inq_dimid(ncid, 'PRESNIVS', dimid) + IF (ierr /= NF90_NOERR) THEN + ! Dimension PRESNIVS not found either + CALL abort_gcm('get_aero_fromfile', 'dimension lev or presnivs not in file',1) + ELSE + ! Old file found + new_file=.FALSE. + WRITE(lunout,*) 'Vertical interpolation for ',TRIM(varname),' will not be done' + END IF + ELSE + ! New file found + new_file=.TRUE. + WRITE(lunout,*) 'Vertical interpolation for ',TRIM(varname),' will be done' + END IF + +! 2) Find vertical dimension klev_src +!**************************************************************************************** + CALL check_err( nf90_inquire_dimension(ncid, dimid, len = klev_src) ) + + ! Allocate variables depending on the number of vertical levels + ALLOCATE(varmth(iim, jjm+1, klev_src), varyear(iim, jjm+1, klev_src, 12), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('get_aero_fromfile', 'pb in allocation 1',1) + + ALLOCATE(pt_ap(klev_src), pt_b(klev_src), varktmp(klev_src), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('get_aero_fromfile', 'pb in allocation 2',1) + +! 3) Read all variables from file +! There is 2 options for the file structure : +! new_file=TRUE : read varyear, ps, pt_ap and pt_b +! new_file=FALSE : read varyear month by month +!**************************************************************************************** + + IF (new_file) THEN + +! ++) Read the aerosol concentration month by month and concatenate to total variable varyear +!**************************************************************************************** + ! Get variable id + CALL check_err( nf90_inq_varid(ncid, TRIM(varname), varid) ) + + ! Get the variable + CALL check_err( nf90_get_var(ncid, varid, varyear(:,:,:,:)) ) + +! ++) Read surface pression, 12 month in one variable +!**************************************************************************************** + ! Get variable id + CALL check_err( nf90_inq_varid(ncid, "ps", varid) ) + ! Get the variable + CALL check_err( nf90_get_var(ncid, varid, psurf_glo2D) ) + +! ++) Read mass load, 12 month in one variable +!**************************************************************************************** + ! Get variable id + CALL check_err( nf90_inq_varid(ncid, "load_"//TRIM(varname), varid) ) + ! Get the variable + CALL check_err( nf90_get_var(ncid, varid, load_glo2D) ) + +! ++) Read ap +!**************************************************************************************** + ! Get variable id + CALL check_err( nf90_inq_varid(ncid, "ap", varid) ) + ! Get the variable + CALL check_err( nf90_get_var(ncid, varid, pt_ap) ) + +! ++) Read b +!**************************************************************************************** + ! Get variable id + CALL check_err( nf90_inq_varid(ncid, "b", varid) ) + ! Get the variable + CALL check_err( nf90_get_var(ncid, varid, pt_b) ) + +! ++) Read p0 : reference pressure +!**************************************************************************************** + ! Get variable id + CALL check_err( nf90_inq_varid(ncid, "p0", varid) ) + ! Get the variable + CALL check_err( nf90_get_var(ncid, varid, p0) ) + + + ELSE ! old file + +! ++) Read the aerosol concentration month by month and concatenate to total variable varyear +!**************************************************************************************** + DO imth=1, 12 + IF (imth.EQ.1) THEN + cvar=TRIM(varname)//'JAN' + ELSE IF (imth.EQ.2) THEN + cvar=TRIM(varname)//'FEB' + ELSE IF (imth.EQ.3) THEN + cvar=TRIM(varname)//'MAR' + ELSE IF (imth.EQ.4) THEN + cvar=TRIM(varname)//'APR' + ELSE IF (imth.EQ.5) THEN + cvar=TRIM(varname)//'MAY' + ELSE IF (imth.EQ.6) THEN + cvar=TRIM(varname)//'JUN' + ELSE IF (imth.EQ.7) THEN + cvar=TRIM(varname)//'JUL' + ELSE IF (imth.EQ.8) THEN + cvar=TRIM(varname)//'AUG' + ELSE IF (imth.EQ.9) THEN + cvar=TRIM(varname)//'SEP' + ELSE IF (imth.EQ.10) THEN + cvar=TRIM(varname)//'OCT' + ELSE IF (imth.EQ.11) THEN + cvar=TRIM(varname)//'NOV' + ELSE IF (imth.EQ.12) THEN + cvar=TRIM(varname)//'DEC' + END IF + + ! Get variable id + CALL check_err( nf90_inq_varid(ncid, TRIM(cvar), varid) ) + + ! Get the variable + CALL check_err( nf90_get_var(ncid, varid, varmth) ) + + ! Store in variable for the whole year + varyear(:,:,:,imth)=varmth(:,:,:) + + END DO + + ! Putting dummy + psurf_glo2D(:,:,:) = not_valid + load_glo2D(:,:,:) = not_valid + pt_ap(:) = not_valid + pt_b(:) = not_valid + + END IF + +! 4) Close file +!**************************************************************************************** + CALL check_err( nf90_close(ncid) ) + + +! 5) Transform the global field from 2D(iim, jjp+1) to 1D(klon_glo) +!**************************************************************************************** +! Test if vertical levels have to be inversed + + IF ((pt_b(1) < pt_b(klev_src)) .OR. .NOT. new_file) THEN + WRITE(lunout,*) 'Vertical axis in file ',TRIM(fname), ' needs to be inverted' + WRITE(lunout,*) 'before pt_ap = ', pt_ap + WRITE(lunout,*) 'before pt_b = ', pt_b + + ! Inverse vertical levels for varyear + DO imth=1, 12 + varmth(:,:,:) = varyear(:,:,:,imth) ! use varmth temporarly + DO k=1, klev_src + DO j=1, jjm+1 + DO i=1,iim + varyear(i,j,k,imth) = varmth(i,j,klev_src+1-k) + END DO + END DO + END DO + END DO + + ! Inverte vertical axes for pt_ap and pt_b + varktmp(:) = pt_ap(:) + DO k=1, klev_src + pt_ap(k) = varktmp(klev_src+1-k) + END DO + + varktmp(:) = pt_b(:) + DO k=1, klev_src + pt_b(k) = varktmp(klev_src+1-k) + END DO + WRITE(lunout,*) 'after pt_ap = ', pt_ap + WRITE(lunout,*) 'after pt_b = ', pt_b + + ELSE + WRITE(lunout,*) 'Vertical axis in file ',TRIM(fname), ' is ok, no vertical inversion is done' + WRITE(lunout,*) 'pt_ap = ', pt_ap + WRITE(lunout,*) 'pt_b = ', pt_b + END IF + +! - Invert latitudes if necessary + DO imth=1, 12 + IF (invert_lat) THEN + + ! Invert latitudes for the variable + varmth(:,:,:) = varyear(:,:,:,imth) ! use varmth temporarly + DO k=1,klev_src + DO j=1,jjm+1 + DO i=1,iim + varyear(i,j,k,imth) = varmth(i,jjm+1+1-j,k) + END DO + END DO + END DO + + ! Invert latitudes for surface pressure + vartmp(:,:) = psurf_glo2D(:,:,imth) + DO j=1, jjm+1 + DO i=1,iim + psurf_glo2D(i,j,imth)= vartmp(i,jjm+1+1-j) + END DO + END DO + + ! Invert latitudes for the load + vartmp(:,:) = load_glo2D(:,:,imth) + DO j=1, jjm+1 + DO i=1,iim + load_glo2D(i,j,imth)= vartmp(i,jjm+1+1-j) + END DO + END DO + END IF ! invert_lat + + ! Do zonal mead at poles and distribut at whole first and last latitude + DO k=1, klev_src + npole=0. ! North pole, j=1 + spole=0. ! South pole, j=jjm+1 + DO i=1,iim + npole = npole + varyear(i,1,k,imth) + spole = spole + varyear(i,jjm+1,k,imth) + END DO + npole = npole/FLOAT(iim) + spole = spole/FLOAT(iim) + varyear(:,1, k,imth) = npole + varyear(:,jjm+1,k,imth) = spole + END DO + END DO ! imth + + ALLOCATE(varyear_glo1D(klon_glo, klev_src, 12), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('get_aero_fromfile', 'pb in allocation 3',1) + + ! Transform from 2D to 1D field + CALL grid2Dto1D_glo(varyear,varyear_glo1D) + CALL grid2Dto1D_glo(psurf_glo2D,psurf_glo1D) + CALL grid2Dto1D_glo(load_glo2D,load_glo1D) + + ELSE + ALLOCATE(varyear_glo1D(0,0,0)) + END IF ! is_mpi_root .AND. is_omp_root + +!$OMP BARRIER + +! 6) Distribute to all processes +! Scatter global field(klon_glo) to local process domain(klon) +! and distribute klev_src to all processes +!**************************************************************************************** + + ! Distribute klev_src + CALL bcast(klev_src) + + ! Allocate and distribute pt_ap and pt_b + IF (.NOT. ASSOCIATED(pt_ap)) THEN ! if pt_ap is allocated also pt_b is allocated + ALLOCATE(pt_ap(klev_src), pt_b(klev_src), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('get_aero_fromfile', 'pb in allocation 4',1) + END IF + CALL bcast(pt_ap) + CALL bcast(pt_b) + + ! Allocate space for output pointer variable at local process + IF (ASSOCIATED(pt_year)) DEALLOCATE(pt_year) + ALLOCATE(pt_year(klon, klev_src, 12), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('get_aero_fromfile', 'pb in allocation 5',1) + + ! Scatter global field to local domain at local process + CALL scatter(varyear_glo1D, pt_year) + CALL scatter(psurf_glo1D, psurf_out) + CALL scatter(load_glo1D, load_out) + +! 7) Test for negative values +!**************************************************************************************** + IF (MINVAL(pt_year) < 0.) THEN + WRITE(lunout,*) 'Warning! Negative values read from file :', fname + END IF + + END SUBROUTINE get_aero_fromfile + + + SUBROUTINE check_err(status) + USE netcdf + IMPLICIT NONE + + INCLUDE "iniprint.h" + INTEGER, INTENT (IN) :: status + + IF (status /= NF90_NOERR) THEN + WRITE(lunout,*) 'Error in get_aero_fromfile ',status + CALL abort_gcm('get_aero_fromfile',trim(nf90_strerror(status)),1) + END IF + + END SUBROUTINE check_err + + +END MODULE readaerosol_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/readaerosol_interp.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/readaerosol_interp.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/readaerosol_interp.F90 (revision 1280) @@ -0,0 +1,540 @@ +! $Id$ +! +SUBROUTINE readaerosol_interp(id_aero, itap, pdtphys, r_day, first, pplay, paprs, t_seri, mass_out, pi_mass_out) +! +! This routine will return the mass concentration at actual day(mass_out) and +! the pre-industrial values(pi_mass_out) for aerosol corresponding to "id_aero". +! The mass concentrations for all aerosols are saved in this routine but each +! call to this routine only treats the aerosol "id_aero". +! +! 1) Read in data for the whole year, only at first time step +! 2) Interpolate to the actual day, only at new day +! 3) Interpolate to the model vertical grid (target grid), only at new day +! 4) Test for negative mass values + + USE ioipsl + USE dimphy, ONLY : klev,klon + USE mod_phys_lmdz_para, ONLY : mpi_rank + USE readaerosol_mod + USE aero_mod, ONLY : naero_spc, name_aero + USE write_field_phy + USE phys_cal_mod + + IMPLICIT NONE + + INCLUDE "YOMCST.h" + INCLUDE "chem.h" + INCLUDE "temps.h" + INCLUDE "clesphys.h" + INCLUDE "iniprint.h" + INCLUDE "dimensions.h" + INCLUDE "comvert.h" +! +! Input: +!**************************************************************************************** + INTEGER, INTENT(IN) :: id_aero! Identity number for the aerosol to treat + INTEGER, INTENT(IN) :: itap ! Physic step count + REAL, INTENT(IN) :: pdtphys! Physic day step + REAL, INTENT(IN) :: r_day ! Day of integration + LOGICAL, INTENT(IN) :: first ! First model timestep + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay ! pression at model mid-layers + REAL, DIMENSION(klon,klev+1),INTENT(IN):: paprs ! pression between model layers + REAL, DIMENSION(klon,klev), INTENT(IN) :: t_seri ! air temperature +! +! Output: +!**************************************************************************************** + REAL, INTENT(OUT) :: mass_out(klon,klev) ! Mass of aerosol (monthly mean data,from file) [ug AIBCM/m3] + REAL, INTENT(OUT) :: pi_mass_out(klon,klev) ! Mass of preindustrial aerosol (monthly mean data,from file) [ug AIBCM/m3] +! +! Local Variables: +!**************************************************************************************** + INTEGER :: i, k, ierr + INTEGER :: iday, iyr, lmt_pas +! INTEGER :: im, day1, day2, im2 + INTEGER :: im, im2 + REAL :: day1, day2 + INTEGER :: pi_klev_src ! Only for testing purpose + INTEGER, SAVE :: klev_src ! Number of vertical levles in source field +!$OMP THREADPRIVATE(klev_src) + + REAL :: zrho ! Air density [kg/m3] + REAL :: volm ! Volyme de melange [kg/kg] + REAL, DIMENSION(klon) :: psurf_day, pi_psurf_day + REAL, DIMENSION(klon) :: load_src, pi_load_src ! Mass load at source grid + REAL, DIMENSION(klon) :: load_tgt, load_tgt_test + REAL, DIMENSION(klon,klev) :: delp ! pressure difference in each model layer + + REAL, ALLOCATABLE, DIMENSION(:,:) :: pplay_src ! pression mid-layer at source levels + REAL, ALLOCATABLE, DIMENSION(:,:) :: tmp1, tmp2 ! Temporary variables + REAL, ALLOCATABLE, DIMENSION(:,:,:,:), SAVE :: var_year ! VAR in right dimension for the total year + REAL, ALLOCATABLE, DIMENSION(:,:,:,:), SAVE :: pi_var_year ! pre-industrial VAR, -"- +!$OMP THREADPRIVATE(var_year,pi_var_year) + REAL, ALLOCATABLE, DIMENSION(:,:,:),SAVE :: var_day ! VAR interpolated to the actual day and model grid + REAL, ALLOCATABLE, DIMENSION(:,:,:),SAVE :: pi_var_day ! pre-industrial VAR, -"- +!$OMP THREADPRIVATE(var_day,pi_var_day) + REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: psurf_year, pi_psurf_year ! surface pressure for the total year +!$OMP THREADPRIVATE(psurf_year, pi_psurf_year) + REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: load_year, pi_load_year ! load in the column for the total year +!$OMP THREADPRIVATE(load_year, pi_load_year) + + REAL, DIMENSION(:,:,:), POINTER :: pt_tmp ! Pointer allocated in readaerosol + REAL, POINTER, DIMENSION(:), SAVE :: pt_ap, pt_b ! Pointer for describing the vertical levels +!$OMP THREADPRIVATE(pt_ap, pt_b) + INTEGER, SAVE :: nbr_tsteps ! number of time steps in file read + REAL, DIMENSION(14), SAVE :: month_len, month_start, month_mid +!$OMP THREADPRIVATE(nbr_tsteps, month_len, month_start, month_mid) + REAL :: jDay + + LOGICAL :: lnewday ! Indicates if first time step at a new day + LOGICAL :: OLDNEWDAY + LOGICAL,SAVE :: vert_interp ! Indicates if vertical interpolation will be done + LOGICAL,SAVE :: debug=.FALSE.! Debugging in this subroutine +!$OMP THREADPRIVATE(vert_interp, debug) + + +!**************************************************************************************** +! Initialization +! +!**************************************************************************************** + +! Calculation to find if it is a new day + + IF(mpi_rank == 0 .AND. debug )then + PRINT*,'CONTROL PANEL REGARDING TIME STEPING' + ENDIF + + ! Use phys_cal_mod + iday= day_cur + iyr = year_cur + im = mth_cur + +! iday = INT(r_day) +! iyr = iday/360 +! iday = iday-iyr*360 ! day of the actual year +! iyr = iyr + annee_ref ! year of the run +! im = iday/30 +1 ! the actual month + CALL ymds2ju(iyr, im, iday, 0., jDay) +! CALL ymds2ju(iyr, im, iday-(im-1)*30, 0., jDay) + + + IF(MOD(itap-1,NINT(86400./pdtphys)) == 0)THEN + lnewday=.TRUE. + ELSE + lnewday=.FALSE. + ENDIF + + IF(mpi_rank == 0 .AND. debug)then + ! 0.02 is about 0.5/24, namly less than half an hour + OLDNEWDAY = (r_day-FLOAT(iday) < 0.02) + ! Once per day, update aerosol fields + lmt_pas = NINT(86400./pdtphys) + PRINT*,'r_day-FLOAT(iday) =',r_day-FLOAT(iday) + PRINT*,'itap =',itap + PRINT*,'pdtphys =',pdtphys + PRINT*,'lmt_pas =',lmt_pas + PRINT*,'iday =',iday + PRINT*,'r_day =',r_day + PRINT*,'day_cur =',day_cur + PRINT*,'mth_cur =',mth_cur + PRINT*,'year_cur =',year_cur + PRINT*,'NINT(86400./pdtphys) =',NINT(86400./pdtphys) + PRINT*,'MOD(0,1) =',MOD(0,1) + PRINT*,'lnewday =',lnewday + PRINT*,'OLDNEWDAY =',OLDNEWDAY + ENDIF + + IF (.NOT. ALLOCATED(var_day)) THEN + ALLOCATE( var_day(klon, klev, naero_spc), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 1',1) + ALLOCATE( pi_var_day(klon, klev, naero_spc), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 2',1) + + ALLOCATE( psurf_year(klon, 12, naero_spc), pi_psurf_year(klon, 12, naero_spc), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 3',1) + + ALLOCATE( load_year(klon, 12, naero_spc), pi_load_year(klon, 12, naero_spc), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 4',1) + + lnewday=.TRUE. + + NULLIFY(pt_ap) + NULLIFY(pt_b) + END IF + +!**************************************************************************************** +! 1) Read in data : corresponding to the actual year and preindustrial data. +! Only for the first day of the year. +! +!**************************************************************************************** + IF ( (first .OR. iday==0) .AND. lnewday ) THEN + NULLIFY(pt_tmp) + + ! Reading values corresponding to the closest year taking into count the choice of aer_type. + ! For aer_type=scenario interpolation between 2 data sets is done in readaerosol. + CALL readaerosol(name_aero(id_aero), aer_type, iyr, klev_src, pt_ap, pt_b, pt_tmp, & + psurf_year(:,:,id_aero), load_year(:,:,id_aero)) + IF (.NOT. ALLOCATED(var_year)) THEN + ALLOCATE(var_year(klon, klev_src, 12, naero_spc), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 5',1) + END IF + var_year(:,:,:,id_aero) = pt_tmp(:,:,:) + + ! Reading values corresponding to the preindustrial concentrations. + CALL readaerosol(name_aero(id_aero), 'preind', iyr, pi_klev_src, pt_ap, pt_b, pt_tmp, & + pi_psurf_year(:,:,id_aero), pi_load_year(:,:,id_aero)) + + ! klev_src must be the same in both files. + ! Also supposing pt_ap and pt_b to be the same in the 2 files without testing. + IF (pi_klev_src /= klev_src) THEN + WRITE(lunout,*) 'Error! All forcing files for the same aerosol must have the same vertical dimension' + WRITE(lunout,*) 'Aerosol : ', name_aero(id_aero) + CALL abort_gcm('readaerosol_interp','Differnt vertical axes in aerosol forcing files',1) + END IF + + IF (.NOT. ALLOCATED(pi_var_year)) THEN + ALLOCATE(pi_var_year(klon, klev_src, 12, naero_spc), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 6',1) + END IF + pi_var_year(:,:,:,id_aero) = pt_tmp(:,:,:) + + IF (debug) THEN + CALL writefield_phy('var_year_jan',var_year(:,:,1,id_aero),klev_src) + CALL writefield_phy('var_year_dec',var_year(:,:,12,id_aero),klev_src) + CALL writefield_phy('psurf_src',psurf_year(:,:,id_aero),1) + CALL writefield_phy('pi_psurf_src',pi_psurf_year(:,:,id_aero),1) + CALL writefield_phy('load_year_src',load_year(:,:,id_aero),1) + CALL writefield_phy('pi_load_year_src',pi_load_year(:,:,id_aero),1) + END IF + + ! Pointer no more useful, deallocate. + DEALLOCATE(pt_tmp) + + ! Test if vertical interpolation will be needed. + IF (psurf_year(1,1,id_aero)==not_valid .OR. pi_psurf_year(1,1,id_aero)==not_valid ) THEN + ! Pressure=not_valid indicates old file format, see module readaerosol + vert_interp = .FALSE. + + ! If old file format, both psurf_year and pi_psurf_year must be not_valid + IF ( psurf_year(1,1,id_aero) /= pi_psurf_year(1,1,id_aero) ) THEN + WRITE(lunout,*) 'Warning! All forcing files for the same aerosol must have the same structure' + CALL abort_gcm('readaerosol_interp', 'The aerosol files have not the same format',1) + END IF + + IF (klev /= klev_src) THEN + WRITE(lunout,*) 'Old format of aerosol file do not allowed vertical interpolation' + CALL abort_gcm('readaerosol_interp', 'Old aerosol file not possible',1) + END IF + + ELSE + vert_interp = .TRUE. + END IF + +! Calendar initialisation +! + DO i = 2, 13 + month_len(i) = float(ioget_mon_len(year_cur, i-1)) + CALL ymds2ju(year_cur, i-1, 1, 0.0, month_start(i)) + ENDDO + month_len(1) = float(ioget_mon_len(year_cur-1, 12)) + CALL ymds2ju(year_cur-1, 12, 1, 0.0, month_start(1)) + month_len(14) = float(ioget_mon_len(year_cur+1, 1)) + CALL ymds2ju(year_cur+1, 1, 1, 0.0, month_start(14)) + month_mid(:) = month_start (:) + month_len(:)/2. + + if (debug) then + write(lunout,*)' month_len = ',month_len + write(lunout,*)' month_mid = ',month_mid + endif + + END IF ! IF ( (first .OR. iday==0) .AND. lnewday ) THEN + +!**************************************************************************************** +! - 2) Interpolate to the actual day. +! - 3) Interpolate to the model vertical grid. +! +!**************************************************************************************** + + IF (lnewday) THEN ! only if new day +!**************************************************************************************** +! 2) Interpolate to the actual day +! +!**************************************************************************************** + ! Find which months and days to use for time interpolation + nbr_tsteps = 12 + IF (nbr_tsteps == 12) then + IF (jDay < month_mid(im+1)) THEN + im2=im-1 + day2 = month_mid(im2+1) + day1 = month_mid(im+1) + IF (im2 <= 0) THEN + ! the month is january, thus the month before december + im2=12 + END IF + ELSE + ! the second half of the month + im2=im+1 + day2 = month_mid(im+1) + day1 = month_mid(im2+1) + IF (im2 > 12) THEN + ! the month is december, the following thus january + im2=1 + ENDIF + END IF + ELSE IF (nbr_tsteps == 14) then + im = im + 1 + IF (jDay < month_mid(im)) THEN + ! in the first half of the month use month before and actual month + im2=im-1 + day2 = month_mid(im2) + day1 = month_mid(im) + ELSE + ! the second half of the month + im2=im+1 + day2 = month_mid(im) + day1 = month_mid(im2) + END IF + ELSE + CALL abort_gcm('readaerosol_interp', 'number of months undefined',1) + ENDIF + if (debug) then + write(lunout,*)' jDay, day1, day2, im, im2 = ', jDay, day1, day2, im, im2 + endif + + + ! Time interpolation, still on vertical source grid + ALLOCATE(tmp1(klon,klev_src), tmp2(klon,klev_src),stat=ierr) + IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 7',1) + + ALLOCATE(pplay_src(klon,klev_src), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 8',1) + + + DO k=1,klev_src + DO i=1,klon + tmp1(i,k) = & + var_year(i,k,im2,id_aero) - (jDay-day2)/(day1-day2) * & + (var_year(i,k,im2,id_aero) - var_year(i,k,im,id_aero)) + + tmp2(i,k) = & + pi_var_year(i,k,im2,id_aero) - (jDay-day2)/(day1-day2) * & + (pi_var_year(i,k,im2,id_aero) - pi_var_year(i,k,im,id_aero)) + END DO + END DO + + ! Time interpolation for pressure at surface, still on vertical source grid + DO i=1,klon + psurf_day(i) = & + psurf_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * & + (psurf_year(i,im2,id_aero) - psurf_year(i,im,id_aero)) + + pi_psurf_day(i) = & + pi_psurf_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * & + (pi_psurf_year(i,im2,id_aero) - pi_psurf_year(i,im,id_aero)) + END DO + + ! Time interpolation for the load, still on vertical source grid + DO i=1,klon + load_src(i) = & + load_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * & + (load_year(i,im2,id_aero) - load_year(i,im,id_aero)) + + pi_load_src(i) = & + pi_load_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * & + (pi_load_year(i,im2,id_aero) - pi_load_year(i,im,id_aero)) + END DO + +!**************************************************************************************** +! 3) Interpolate to the model vertical grid (target grid) +! +!**************************************************************************************** + + IF (vert_interp) THEN + + ! - Interpolate variable tmp1 (on source grid) to var_day (on target grid) + !******************************************************************************** + ! a) calculate pression at vertical levels for the source grid using the + ! hybrid-sigma coordinates ap and b and the surface pressure, variables from file. + DO k = 1, klev_src + DO i = 1, klon + pplay_src(i,k)= pt_ap(k) + pt_b(k)*psurf_day(i) + END DO + END DO + + IF (debug) THEN + CALL writefield_phy('psurf_day_src',psurf_day(:),1) + CALL writefield_phy('pplay_src',pplay_src(:,:),klev_src) + CALL writefield_phy('pplay',pplay(:,:),klev) + CALL writefield_phy('day_src',tmp1,klev_src) + CALL writefield_phy('pi_day_src',tmp2,klev_src) + END IF + + ! b) vertical interpolation on pressure leveles + CALL pres2lev(tmp1(:,:), var_day(:,:,id_aero), klev_src, klev, pplay_src, pplay, & + 1, klon, .FALSE.) + + IF (debug) CALL writefield_phy('day_tgt',var_day(:,:,id_aero),klev) + + ! c) adjust to conserve total aerosol mass load in the vertical pillar + ! Calculate the load in the actual pillar and compare with the load + ! read from aerosol file. + + ! Find the pressure difference in each model layer + DO k = 1, klev + DO i = 1, klon + delp(i,k) = paprs(i,k) - paprs (i,k+1) + END DO + END DO + + ! Find the mass load in the actual pillar, on target grid + load_tgt(:) = 0. + DO k= 1, klev + DO i = 1, klon + zrho = pplay(i,k)/t_seri(i,k)/RD ! [kg/m3] + volm = var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg] + load_tgt(i) = load_tgt(i) + 1/RG * volm *delp(i,k) + END DO + END DO + + ! Adjust, uniform + DO k = 1, klev + DO i = 1, klon + var_day(i,k,id_aero) = var_day(i,k,id_aero)*load_src(i)/load_tgt(i) + END DO + END DO + + IF (debug) THEN + load_tgt_test(:) = 0. + DO k= 1, klev + DO i = 1, klon + zrho = pplay(i,k)/t_seri(i,k)/RD ! [kg/m3] + volm = var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg] + load_tgt_test(i) = load_tgt_test(i) + 1/RG * volm*delp(i,k) + END DO + END DO + + CALL writefield_phy('day_tgt2',var_day(:,:,id_aero),klev) + CALL writefield_phy('load_tgt',load_tgt(:),1) + CALL writefield_phy('load_tgt_test',load_tgt_test(:),1) + CALL writefield_phy('load_src',load_src(:),1) + END IF + + ! - Interpolate variable tmp2 (source grid) to pi_var_day (target grid) + !******************************************************************************** + ! a) calculate pression at vertical levels at source grid + DO k = 1, klev_src + DO i = 1, klon + pplay_src(i,k)= pt_ap(k) + pt_b(k)*pi_psurf_day(i) + END DO + END DO + + IF (debug) THEN + CALL writefield_phy('pi_psurf_day_src',pi_psurf_day(:),1) + CALL writefield_phy('pi_pplay_src',pplay_src(:,:),klev_src) + END IF + + ! b) vertical interpolation on pressure leveles + CALL pres2lev(tmp2(:,:), pi_var_day(:,:,id_aero), klev_src, klev, pplay_src, pplay, & + 1, klon, .FALSE.) + + IF (debug) CALL writefield_phy('pi_day_tgt',pi_var_day(:,:,id_aero),klev) + + ! c) adjust to conserve total aerosol mass load in the vertical pillar + ! Calculate the load in the actual pillar and compare with the load + ! read from aerosol file. + + ! Find the load in the actual pillar, on target grid + load_tgt(:) = 0. + DO k = 1, klev + DO i = 1, klon + zrho = pplay(i,k)/t_seri(i,k)/RD ! [kg/m3] + volm = pi_var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg] + load_tgt(i) = load_tgt(i) + 1/RG * volm * delp(i,k) + END DO + END DO + + DO k = 1, klev + DO i = 1, klon + pi_var_day(i,k,id_aero) = pi_var_day(i,k,id_aero)*pi_load_src(i)/load_tgt(i) + END DO + END DO + + IF (debug) THEN + load_tgt_test(:) = 0. + DO k = 1, klev + DO i = 1, klon + zrho = pplay(i,k)/t_seri(i,k)/RD ! [kg/m3] + volm = pi_var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg] + load_tgt_test(i) = load_tgt_test(i) + 1/RG * volm * delp(i,k) + END DO + END DO + CALL writefield_phy('pi_day_tgt2',pi_var_day(:,:,id_aero),klev) + CALL writefield_phy('pi_load_tgt',load_tgt(:),1) + CALL writefield_phy('pi_load_tgt_test',load_tgt_test(:),1) + CALL writefield_phy('pi_load_src',pi_load_src(:),1) + END IF + + + ELSE ! No vertical interpolation done + + var_day(:,:,id_aero) = tmp1(:,:) + pi_var_day(:,:,id_aero) = tmp2(:,:) + + END IF ! vert_interp + + + ! Deallocation + DEALLOCATE(tmp1, tmp2, pplay_src, stat=ierr) + +!**************************************************************************************** +! 4) Test for negative mass values +! +!**************************************************************************************** + IF (MINVAL(var_day(:,:,id_aero)) < 0.) THEN + DO k=1,klev + DO i=1,klon + ! Test for var_day + IF (var_day(i,k,id_aero) < 0.) THEN + IF (jDay-day2 < 0.) WRITE(lunout,*) 'jDay-day2=',jDay-day2 + IF (var_year(i,k,im2,id_aero) - var_year(i,k,im,id_aero) < 0.) THEN + WRITE(lunout,*) trim(name_aero(id_aero)),'(i,k,im2)-', & + trim(name_aero(id_aero)),'(i,k,im)=', & + var_year(i,k,im2,id_aero) - var_year(i,k,im,id_aero) + END IF + WRITE(lunout,*) 'stop for aerosol : ',name_aero(id_aero) + WRITE(lunout,*) 'day1, day2, jDay = ', day1, day2, jDay + CALL abort_gcm('readaerosol_interp','Error in interpolation 1',1) + END IF + END DO + END DO + END IF + + IF (MINVAL(pi_var_day(:,:,id_aero)) < 0. ) THEN + DO k=1, klev + DO i=1,klon + ! Test for pi_var_day + IF (pi_var_day(i,k,id_aero) < 0.) THEN + IF (jDay-day2 < 0.) WRITE(lunout,*) 'jDay-day2=',jDay-day2 + IF (pi_var_year(i,k,im2,id_aero) - pi_var_year(i,k,im,id_aero) < 0.) THEN + WRITE(lunout,*) trim(name_aero(id_aero)),'(i,k,im2)-', & + trim(name_aero(id_aero)),'(i,k,im)=', & + pi_var_year(i,k,im2,id_aero) - pi_var_year(i,k,im,id_aero) + END IF + + WRITE(lunout,*) 'stop for aerosol : ',name_aero(id_aero) + CALL abort_gcm('readaerosol_interp','Error in interpolation 2',1) + END IF + END DO + END DO + END IF + + END IF ! lnewday + +!**************************************************************************************** +! Copy output from saved variables +! +!**************************************************************************************** + + mass_out(:,:) = var_day(:,:,id_aero) + pi_mass_out(:,:) = pi_var_day(:,:,id_aero) + +END SUBROUTINE readaerosol_interp Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/readaerosol_optic.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/readaerosol_optic.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/readaerosol_optic.F90 (revision 1280) @@ -0,0 +1,200 @@ +! $Id$ +! +SUBROUTINE readaerosol_optic(debut, new_aod, flag_aerosol, itap, rjourvrai, & + pdtphys, pplay, paprs, t_seri, rhcl, presnivs, & + mass_solu_aero, mass_solu_aero_pi, & + tau_aero, piz_aero, cg_aero, & + tausum_aero, tau3d_aero ) + +! This routine will : +! 1) recevie the aerosols(already read and interpolated) corresponding to flag_aerosol +! 2) calculate the optical properties for the aerosols +! + + USE dimphy + USE aero_mod + IMPLICIT NONE + +! Input arguments +!**************************************************************************************** + LOGICAL, INTENT(IN) :: debut + LOGICAL, INTENT(IN) :: new_aod + INTEGER, INTENT(IN) :: flag_aerosol + INTEGER, INTENT(IN) :: itap + REAL, INTENT(IN) :: rjourvrai + REAL, INTENT(IN) :: pdtphys + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs + REAL, DIMENSION(klon,klev), INTENT(IN) :: t_seri + REAL, DIMENSION(klon,klev), INTENT(IN) :: rhcl ! humidite relative ciel clair + REAL, DIMENSION(klev), INTENT(IN) :: presnivs + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon,klev), INTENT(OUT) :: mass_solu_aero ! Total mass for all soluble aerosols + REAL, DIMENSION(klon,klev), INTENT(OUT) :: mass_solu_aero_pi ! -"- preindustrial values + REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(OUT) :: tau_aero ! Aerosol optical thickness + REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(OUT) :: piz_aero ! Single scattering albedo aerosol + REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(OUT) :: cg_aero ! asymmetry parameter aerosol + REAL, DIMENSION(klon,nwave,naero_spc), INTENT(OUT) :: tausum_aero + REAL, DIMENSION(klon,klev,nwave,naero_spc), INTENT(OUT) :: tau3d_aero + +! Local variables +!**************************************************************************************** + REAL, DIMENSION(klon) :: aerindex ! POLDER aerosol index + REAL, DIMENSION(klon,klev) :: sulfate ! SO4 aerosol concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: bcsol ! BC soluble concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: bcins ! BC insoluble concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: pomsol ! POM soluble concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: pomins ! POM insoluble concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: cidust ! DUST aerosol concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: sscoarse ! SS Coarse concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: sssupco ! SS Super Coarse concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: ssacu ! SS Acumulation concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: sulfate_pi + REAL, DIMENSION(klon,klev) :: bcsol_pi + REAL, DIMENSION(klon,klev) :: bcins_pi + REAL, DIMENSION(klon,klev) :: pomsol_pi + REAL, DIMENSION(klon,klev) :: pomins_pi + REAL, DIMENSION(klon,klev) :: cidust_pi + REAL, DIMENSION(klon,klev) :: sscoarse_pi + REAL, DIMENSION(klon,klev) :: sssupco_pi + REAL, DIMENSION(klon,klev) :: ssacu_pi + REAL, DIMENSION(klon,klev) :: pdel + REAL, DIMENSION(klon,klev,naero_spc) :: m_allaer + REAL, DIMENSION(klon,klev,naero_spc) :: m_allaer_pi !RAF +! REAL, DIMENSION(klon,naero_tot) :: fractnat_allaer !RAF delete?? + + INTEGER :: k, i + +!**************************************************************************************** +! 1) Get aerosol mass +! +!**************************************************************************************** +! Read and interpolate sulfate + IF ( flag_aerosol .EQ. 1 .OR. & + flag_aerosol .EQ. 6 ) THEN + + CALL readaerosol_interp(id_ASSO4M, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sulfate, sulfate_pi) + ELSE + sulfate(:,:) = 0. ; sulfate_pi(:,:) = 0. + END IF + +! Read and interpolate bcsol and bcins + IF ( flag_aerosol .EQ. 2 .OR. & + flag_aerosol .EQ. 6 ) THEN + + ! Get bc aerosol distribution + CALL readaerosol_interp(id_ASBCM, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcsol, bcsol_pi ) + CALL readaerosol_interp(id_AIBCM, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcins, bcins_pi ) + ELSE + bcsol(:,:) = 0. ; bcsol_pi(:,:) = 0. + bcins(:,:) = 0. ; bcins_pi(:,:) = 0. + END IF + + +! Read and interpolate pomsol and pomins + IF ( flag_aerosol .EQ. 3 .OR. & + flag_aerosol .EQ. 6 ) THEN + + CALL readaerosol_interp(id_ASPOMM, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomsol, pomsol_pi) + CALL readaerosol_interp(id_AIPOMM, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomins, pomins_pi) + ELSE + pomsol(:,:) = 0. ; pomsol_pi(:,:) = 0. + pomins(:,:) = 0. ; pomins_pi(:,:) = 0. + END IF + + +! Read and interpolate csssm, ssssm, assssm + IF (flag_aerosol .EQ. 4 .OR. & + flag_aerosol .EQ. 6 ) THEN + + CALL readaerosol_interp(id_SSSSM ,itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sssupco, sssupco_pi) + CALL readaerosol_interp(id_CSSSM ,itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sscoarse,sscoarse_pi) + CALL readaerosol_interp(id_ASSSM ,itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, ssacu, ssacu_pi) + + ELSE + sscoarse(:,:) = 0. ; sscoarse_pi(:,:) = 0. + ssacu(:,:) = 0. ; ssacu_pi(:,:) = 0. + sssupco(:,:) = 0. ; sssupco_pi = 0. + ENDIF + +! Read and interpolate cidustm + IF (flag_aerosol .EQ. 5 .OR. & + flag_aerosol .EQ. 6 ) THEN + + CALL readaerosol_interp(id_CIDUSTM, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, cidust, cidust_pi) + + ELSE + cidust(:,:) = 0. ; cidust_pi(:,:) = 0. + ENDIF + +! +! Store all aerosols in one variable +! + m_allaer(:,:,id_ASBCM) = bcsol(:,:) ! ASBCM + m_allaer(:,:,id_ASPOMM) = pomsol(:,:) ! ASPOMM + m_allaer(:,:,id_ASSO4M) = sulfate(:,:) ! ASSO4M (= SO4) + m_allaer(:,:,id_CSSO4M) = 0. ! CSSO4M + m_allaer(:,:,id_SSSSM) = sssupco(:,:) ! SSSSM + m_allaer(:,:,id_CSSSM) = sscoarse(:,:) ! CSSSM + m_allaer(:,:,id_ASSSM) = ssacu(:,:) ! ASSSM + m_allaer(:,:,id_CIDUSTM)= cidust(:,:) ! CIDUSTM + m_allaer(:,:,id_AIBCM) = bcins(:,:) ! AIBCM + m_allaer(:,:,id_AIPOMM) = pomins(:,:) ! AIPOMM + +!RAF + m_allaer_pi(:,:,1) = bcsol_pi(:,:) ! ASBCM pre-ind + m_allaer_pi(:,:,2) = pomsol_pi(:,:) ! ASPOMM pre-ind + m_allaer_pi(:,:,3) = sulfate_pi(:,:) ! ASSO4M (= SO4) pre-ind + m_allaer_pi(:,:,4) = 0. ! CSSO4M pre-ind + m_allaer_pi(:,:,5) = sssupco_pi(:,:) ! SSSSM pre-ind + m_allaer_pi(:,:,6) = sscoarse_pi(:,:) ! CSSSM pre-ind + m_allaer_pi(:,:,7) = ssacu_pi(:,:) ! ASSSM pre-ind + m_allaer_pi(:,:,8) = cidust_pi(:,:) ! CIDUSTM pre-ind + m_allaer_pi(:,:,9) = bcins_pi(:,:) ! AIBCM pre-ind + m_allaer_pi(:,:,10) = pomins_pi(:,:) ! AIPOMM pre-ind + +! +! Calculate the total mass of all soluble aersosols +! + mass_solu_aero(:,:) = sulfate(:,:) + bcsol(:,:) + pomsol(:,:) ! + & +! sscoarse(:,:) + ssacu(:,:) + sssupco(:,:) + mass_solu_aero_pi(:,:) = sulfate_pi(:,:) + bcsol_pi(:,:) + pomsol_pi(:,:) ! + & +! sscoarse_pi(:,:) + ssacu_pi(:,:) + sssupco_pi(:,:) + +!**************************************************************************************** +! 2) Calculate optical properties for the aerosols +! +!**************************************************************************************** + DO k = 1, klev + DO i = 1, klon + pdel(i,k) = paprs(i,k) - paprs (i,k+1) + END DO + END DO + + IF (new_aod) THEN + +! RAF delete?? fractnat_allaer(:,:) = 0. +! RAF fractnat_allaer -> m_allaer_pi + + CALL aeropt_2bands( & + pdel, m_allaer, pdtphys, rhcl, & + tau_aero, piz_aero, cg_aero, & + m_allaer_pi, flag_aerosol, & + pplay, t_seri, presnivs) + + ! aeropt_5wv only for validation and diagnostics. + CALL aeropt_5wv( & + pdel, m_allaer, & + pdtphys, rhcl, aerindex, & + flag_aerosol, pplay, t_seri, & + tausum_aero, tau3d_aero, presnivs) + ELSE + + CALL aeropt(pplay, paprs, t_seri, sulfate, rhcl, & + tau_aero(:,:,id_ASSO4M,:), piz_aero(:,:,id_ASSO4M,:), cg_aero(:,:,id_ASSO4M,:), aerindex) + + END IF + +END SUBROUTINE readaerosol_optic Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/regdim.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/regdim.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/regdim.h (revision 1280) @@ -0,0 +1,16 @@ +! +! $Header$ +! + INTEGER i1_deb, i1_fin + INTEGER i2_deb, i2_fin +ccc PARAMETER (i1_deb=21, i1_fin=40) +ccc PARAMETER (i2_deb=41, i2_fin=44) +cccc PARAMETER (i1_deb=47, i1_fin=77) +cccc PARAMETER (i2_deb=78, i2_fin=79) + PARAMETER (i1_deb=16, i1_fin=30) + PARAMETER (i2_deb=31, i2_fin=33) +c + INTEGER j_deb, j_fin +ccc PARAMETER (j_deb=29, j_fin=61) +cccc PARAMETER (j_deb=21, j_fin=51) + PARAMETER (j_deb=18, j_fin=39) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/regr_lat_time_climoz_m.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/regr_lat_time_climoz_m.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/regr_lat_time_climoz_m.F90 (revision 1280) @@ -0,0 +1,456 @@ +! $Id$ +module regr_lat_time_climoz_m + + ! Author: Lionel GUEZ + + implicit none + + private + public regr_lat_time_climoz + +contains + + subroutine regr_lat_time_climoz(read_climoz) + + ! "regr_lat_time_climoz" stands for "regrid latitude time + ! climatology ozone". + + ! This procedure reads a climatology of ozone from a NetCDF file, + ! regrids it in latitude and time, and writes the regridded field + ! to a new NetCDF file. + + ! The input field depends on time, pressure level and latitude. + + ! If the input field has missing values, they must be signaled by + ! the "missing_value" attribute. + + ! We assume that the input field is a step function of latitude + ! and that the input latitude coordinate gives the centers of steps. + ! Regridding in latitude is made by averaging, with a cosine of + ! latitude factor. + ! The target LMDZ latitude grid is the "scalar" grid: "rlatu". + ! The values of "rlatu" are taken to be the centers of intervals. + + ! We assume that in the input file: + + ! -- Latitude is in degrees. + + ! -- Latitude and pressure are strictly monotonic (as all NetCDF + ! coordinate variables should be). + + ! -- The time coordinate is in ascending order (even though we do + ! not use its values). + ! The input file may contain either values for 12 months or values + ! for 14 months. + ! If there are 14 months then we assume that we have (in that order): + ! December, January, February, ..., November, December, January + + ! -- Missing values are contiguous, at the bottom of + ! the vertical domain and at the latitudinal boundaries. + + ! If values are all missing at a given latitude and date, then we + ! replace those missing values by values at the closest latitude, + ! equatorward, with valid values. + ! Then, at each latitude and each date, the missing values are replaced + ! by the lowest valid value above missing values. + + ! Regridding in time is by linear interpolation. + ! Monthly values are processed to get daily values, on the basis + ! of a 360-day calendar. + ! If there are 14 months, we use the first December value to + ! interpolate values between January 1st and mid-January. + ! We use the last January value to interpolate values between + ! mid-December and end of December. + ! If there are only 12 months in the input file then we assume + ! periodicity for interpolation at the beginning and at the end of the + ! year. + + use regr1_step_av_m, only: regr1_step_av + use regr3_lint_m, only: regr3_lint + use netcdf95, only: handle_err, nf95_close, nf95_get_att, nf95_gw_var, & + nf95_inq_dimid, nf95_inq_varid, nf95_inquire_dimension, nf95_open, & + nf95_put_var + use netcdf, only: nf90_get_att, nf90_get_var, nf90_noerr, nf90_nowrite + use assert_m, only: assert + + integer, intent(in):: read_climoz ! read ozone climatology + ! Allowed values are 1 and 2 + ! 1: read a single ozone climatology that will be used day and night + ! 2: read two ozone climatologies, the average day and night + ! climatology and the daylight climatology + + ! Variables local to the procedure: + + include "dimensions.h" + ! (for "jjm") + include "paramet.h" + ! (for the other included files) + include "comgeom2.h" + ! (for "rlatv") + include "comconst.h" + ! (for "pi") + + integer n_plev ! number of pressure levels in the input data + integer n_lat ! number of latitudes in the input data + integer n_month ! number of months in the input data + + real, pointer:: latitude(:) + ! (of input data, converted to rad, sorted in strictly ascending order) + + real, allocatable:: lat_in_edg(:) + ! (edges of latitude intervals for input data, in rad, in strictly + ! ascending order) + + real, pointer:: plev(:) + ! pressure levels of input data, sorted in strictly ascending + ! order, converted to hPa + + logical desc_lat ! latitude in descending order in the input file + logical desc_plev ! pressure levels in descending order in the input file + + real, allocatable:: o3_in(:, :, :, :) + ! (n_lat, n_plev, n_month, read_climoz) + ! ozone climatologies from the input file + ! "o3_in(j, k, :, :)" is at latitude "latitude(j)" and pressure + ! level "plev(k)". + ! Third dimension is month index, first value may be December or January. + ! "o3_in(:, :, :, 1)" is for the day- night average, "o3_in(:, :, :, 2)" + ! is for daylight. + + real missing_value + + real, allocatable:: o3_regr_lat(:, :, :, :) + ! (jjm + 1, n_plev, 0:13, read_climoz) + ! mean of "o3_in" over a latitude interval of LMDZ + ! First dimension is latitude interval. + ! The latitude interval for "o3_regr_lat(j,:, :, :)" contains "rlatu(j)". + ! If "j" is between 2 and "jjm" then the interval is: + ! [rlatv(j), rlatv(j-1)] + ! If "j" is 1 or "jjm + 1" then the interval is: + ! [rlatv(1), pi / 2] + ! or: + ! [- pi / 2, rlatv(jjm)] + ! respectively. + ! "o3_regr_lat(:, k, :, :)" is for pressure level "plev(k)". + ! Third dimension is month number, 1 for January. + ! "o3_regr_lat(:, :, :, 1)" is average day and night, + ! "o3_regr_lat(:, :, :, 2)" is for daylight. + + real, allocatable:: o3_out(:, :, :, :) + ! (jjm + 1, n_plev, 360, read_climoz) + ! regridded ozone climatology + ! "o3_out(j, k, l, :)" is at latitude "rlatu(j)", pressure + ! level "plev(k)" and date "January 1st 0h" + "tmidday(l)", in a + ! 360-day calendar. + ! "o3_out(:, :, :, 1)" is average day and night, + ! "o3_out(:, :, :, 2)" is for daylight. + + integer j, k, l,m + + ! For NetCDF: + integer ncid_in, ncid_out ! IDs for input and output files + integer varid_plev, varid_time, varid, ncerr, dimid + character(len=80) press_unit ! pressure unit + + integer varid_in(read_climoz), varid_out(read_climoz) + ! index 1 is for average ozone day and night, index 2 is for + ! daylight ozone. + + real, parameter:: tmidmonth(0:13) = (/(-15. + 30. * l, l = 0, 13)/) + ! (time to middle of month, in days since January 1st 0h, in a + ! 360-day calendar) + ! (We add values -15 and 375 so that, for example, day 3 of the year is + ! interpolated between the December and the January value.) + + real, parameter:: tmidday(360) = (/(l + 0.5, l = 0, 359)/) + ! (time to middle of day, in days since January 1st 0h, in a + ! 360-day calendar) + + !--------------------------------- + + print *, "Call sequence information: regr_lat_time_climoz" + call assert(read_climoz == 1 .or. read_climoz == 2, "regr_lat_time_climoz") + + call nf95_open("climoz.nc", nf90_nowrite, ncid_in) + + ! Get coordinates from the input file: + + call nf95_inq_varid(ncid_in, "latitude", varid) + call nf95_gw_var(ncid_in, varid, latitude) + ! Convert from degrees to rad, because we will take the sine of latitude: + latitude = latitude / 180. * pi + n_lat = size(latitude) + ! We need to supply the latitudes to "regr1_step_av" in + ! ascending order, so invert order if necessary: + desc_lat = latitude(1) > latitude(n_lat) + if (desc_lat) latitude = latitude(n_lat:1:-1) + + ! Compute edges of latitude intervals: + allocate(lat_in_edg(n_lat + 1)) + lat_in_edg(1) = - pi / 2 + forall (j = 2:n_lat) lat_in_edg(j) = (latitude(j - 1) + latitude(j)) / 2 + lat_in_edg(n_lat + 1) = pi / 2 + deallocate(latitude) ! pointer + + call nf95_inq_varid(ncid_in, "plev", varid) + call nf95_gw_var(ncid_in, varid, plev) + n_plev = size(plev) + ! We only need the pressure coordinate to copy it to the output file. + ! The program "gcm" will assume that pressure levels are in + ! ascending order in the regridded climatology so invert order if + ! necessary: + desc_plev = plev(1) > plev(n_plev) + if (desc_plev) plev = plev(n_plev:1:-1) + call nf95_get_att(ncid_in, varid, "units", press_unit) + if (press_unit == "Pa") then + ! Convert to hPa: + plev = plev / 100. + elseif (press_unit /= "hPa") then + print *, "regr_lat_time_climoz: the only recognized units are Pa " & + // "and hPa." + stop 1 + end if + + ! Create the output file and get the variable IDs: + call prepare_out(ncid_in, n_plev, ncid_out, varid_out, varid_plev, & + varid_time) + + ! Write remaining coordinate variables: + call nf95_put_var(ncid_out, varid_plev, plev) + call nf95_put_var(ncid_out, varid_time, tmidday) + + deallocate(plev) ! pointer + + ! Get the number of months: + call nf95_inq_dimid(ncid_in, "time", dimid) + call nf95_inquire_dimension(ncid_in, dimid, len=n_month) + + allocate(o3_in(n_lat, n_plev, n_month, read_climoz)) + + call nf95_inq_varid(ncid_in, "tro3", varid_in(1)) + ncerr = nf90_get_var(ncid_in, varid_in(1), o3_in(:, :, :, 1)) + call handle_err("regr_lat_time_climoz nf90_get_var tro3", ncerr, ncid_in) + + if (read_climoz == 2) then + call nf95_inq_varid(ncid_in, "tro3_daylight", varid_in(2)) + ncerr = nf90_get_var(ncid_in, varid_in(2), o3_in(:, :, :, 2)) + call handle_err("regr_lat_time_climoz nf90_get_var tro3_daylight", & + ncerr, ncid_in, varid_in(2)) + end if + + if (desc_lat) o3_in = o3_in(n_lat:1:-1, :, :, :) + if (desc_plev) o3_in = o3_in(:, n_plev:1:-1, :, :) + + do m = 1, read_climoz + ncerr = nf90_get_att(ncid_in, varid_in(m), "missing_value", & + missing_value) + if (ncerr == nf90_noerr) then + do l = 1, n_month + ! Take care of latitudes where values are all missing: + + ! Next to the south pole: + j = 1 + do while (o3_in(j, 1, l, m) == missing_value) + j = j + 1 + end do + if (j > 1) o3_in(:j-1, :, l, m) = & + spread(o3_in(j, :, l, m), dim=1, ncopies=j-1) + + ! Next to the north pole: + j = n_lat + do while (o3_in(j, 1, l, m) == missing_value) + j = j - 1 + end do + if (j < n_lat) o3_in(j+1:, :, l, m) = & + spread(o3_in(j, :, l, m), dim=1, ncopies=n_lat-j) + + ! Take care of missing values at high pressure: + do j = 1, n_lat + ! Find missing values, starting from top of atmosphere + ! and going down. + ! We have already taken care of latitudes full of + ! missing values so the highest level has a valid value. + k = 2 + do while (o3_in(j, k, l, m) /= missing_value .and. k < n_plev) + k = k + 1 + end do + ! Replace missing values with the valid value at the + ! lowest level above missing values: + if (o3_in(j, k, l, m) == missing_value) & + o3_in(j, k:n_plev, l, m) = o3_in(j, k-1, l, m) + end do + end do + else + print *, "regr_lat_time_climoz: field ", m, & + ", no missing value attribute" + end if + end do + + call nf95_close(ncid_in) + + allocate(o3_regr_lat(jjm + 1, n_plev, 0:13, read_climoz)) + allocate(o3_out(jjm + 1, n_plev, 360, read_climoz)) + + ! Regrid in latitude: + ! We average with respect to sine of latitude, which is + ! equivalent to weighting by cosine of latitude: + if (n_month == 12) then + print *, & + "Found 12 months in ozone climatologies, assuming periodicity..." + o3_regr_lat(jjm+1:1:-1, :, 1:12, :) = regr1_step_av(o3_in, & + xs=sin(lat_in_edg), xt=sin((/- pi / 2, rlatv(jjm:1:-1), pi / 2/))) + ! (invert order of indices in "o3_regr_lat" because "rlatu" is + ! in descending order) + + ! Duplicate January and December values, in preparation of time + ! interpolation: + o3_regr_lat(:, :, 0, :) = o3_regr_lat(:, :, 12, :) + o3_regr_lat(:, :, 13, :) = o3_regr_lat(:, :, 1, :) + else + print *, "Using 14 months in ozone climatologies..." + o3_regr_lat(jjm+1:1:-1, :, :, :) = regr1_step_av(o3_in, & + xs=sin(lat_in_edg), xt=sin((/- pi / 2, rlatv(jjm:1:-1), pi / 2/))) + ! (invert order of indices in "o3_regr_lat" because "rlatu" is + ! in descending order) + end if + + ! Regrid in time by linear interpolation: + o3_out = regr3_lint(o3_regr_lat, tmidmonth, tmidday) + + ! Write to file: + do m = 1, read_climoz + call nf95_put_var(ncid_out, varid_out(m), o3_out(jjm+1:1:-1, :, :, m)) + ! (The order of "rlatu" is inverted in the output file) + end do + + call nf95_close(ncid_out) + + end subroutine regr_lat_time_climoz + + !******************************************** + + subroutine prepare_out(ncid_in, n_plev, ncid_out, varid_out, varid_plev, & + varid_time) + + ! This subroutine creates the NetCDF output file, defines + ! dimensions and variables, and writes one of the coordinate variables. + + use netcdf95, only: nf95_create, nf95_def_dim, nf95_def_var, & + nf95_put_att, nf95_enddef, nf95_copy_att, nf95_put_var + use netcdf, only: nf90_clobber, nf90_float, nf90_global + + integer, intent(in):: ncid_in, n_plev + integer, intent(out):: ncid_out, varid_plev, varid_time + + integer, intent(out):: varid_out(:) ! dim(1 or 2) + ! "varid_out(1)" is for average ozone day and night, + ! "varid_out(2)" is for daylight ozone. + + ! Variables local to the procedure: + + include "dimensions.h" + ! (for "jjm") + include "paramet.h" + ! (for the other included files) + include "comgeom2.h" + ! (for "rlatu") + include "comconst.h" + ! (for "pi") + + integer ncerr + integer dimid_rlatu, dimid_plev, dimid_time + integer varid_rlatu + + !--------------------------- + + print *, "Call sequence information: prepare_out" + + call nf95_create("climoz_LMDZ.nc", nf90_clobber, ncid_out) + + ! Dimensions: + call nf95_def_dim(ncid_out, "time", 360, dimid_time) + call nf95_def_dim(ncid_out, "plev", n_plev, dimid_plev) + call nf95_def_dim(ncid_out, "rlatu", jjm + 1, dimid_rlatu) + + ! Define coordinate variables: + + call nf95_def_var(ncid_out, "time", nf90_float, dimid_time, varid_time) + call nf95_put_att(ncid_out, varid_time, "units", "days since 2000-1-1") + call nf95_put_att(ncid_out, varid_time, "calendar", "360_day") + call nf95_put_att(ncid_out, varid_time, "standard_name", "time") + + call nf95_def_var(ncid_out, "plev", nf90_float, dimid_plev, varid_plev) + call nf95_put_att(ncid_out, varid_plev, "units", "millibar") + call nf95_put_att(ncid_out, varid_plev, "standard_name", "air_pressure") + call nf95_put_att(ncid_out, varid_plev, "long_name", "air pressure") + + call nf95_def_var(ncid_out, "rlatu", nf90_float, dimid_rlatu, varid_rlatu) + call nf95_put_att(ncid_out, varid_rlatu, "units", "degrees_north") + call nf95_put_att(ncid_out, varid_rlatu, "standard_name", "latitude") + + ! Define the primary variables: + + call nf95_def_var(ncid_out, "tro3", nf90_float, & + (/dimid_rlatu, dimid_plev, dimid_time/), varid_out(1)) + call nf95_put_att(ncid_out, varid_out(1), "long_name", & + "ozone mole fraction") + call nf95_put_att(ncid_out, varid_out(1), "standard_name", & + "mole_fraction_of_ozone_in_air") + + if (size(varid_out) == 2) then + call nf95_def_var(ncid_out, "tro3_daylight", nf90_float, & + (/dimid_rlatu, dimid_plev, dimid_time/), varid_out(2)) + call nf95_put_att(ncid_out, varid_out(2), "long_name", & + "ozone mole fraction in daylight") + end if + + ! Global attributes: + + ! The following commands, copying attributes, may fail. + ! That is OK. + ! It should just mean that the attribute is not defined in the input file. + + call nf95_copy_att(ncid_in, nf90_global, "Conventions", ncid_out, & + nf90_global, ncerr) + call handle_err_copy_att("Conventions") + + call nf95_copy_att(ncid_in, nf90_global, "title", ncid_out, nf90_global, & + ncerr) + call handle_err_copy_att("title") + + call nf95_copy_att(ncid_in, nf90_global, "institution", ncid_out, & + nf90_global, ncerr) + call handle_err_copy_att("institution") + + call nf95_copy_att(ncid_in, nf90_global, "source", ncid_out, nf90_global, & + ncerr) + call handle_err_copy_att("source") + + call nf95_put_att(ncid_out, nf90_global, "comment", "Regridded for LMDZ") + + call nf95_enddef(ncid_out) + + ! Write one of the coordinate variables: + call nf95_put_var(ncid_out, varid_rlatu, rlatu(jjm+1:1:-1) / pi * 180.) + ! (convert from rad to degrees and sort in ascending order) + + contains + + subroutine handle_err_copy_att(att_name) + + use netcdf, only: nf90_noerr, nf90_strerror + + character(len=*), intent(in):: att_name + + !---------------------------------------- + + if (ncerr /= nf90_noerr) then + print *, "regr_lat_time_climoz_m prepare_out nf95_copy_att " & + // att_name // " -- " // trim(nf90_strerror(ncerr)) + end if + + end subroutine handle_err_copy_att + + end subroutine prepare_out + +end module regr_lat_time_climoz_m Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/regr_pr_av_m.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/regr_pr_av_m.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/regr_pr_av_m.F90 (revision 1280) @@ -0,0 +1,121 @@ +! $Id$ +module regr_pr_av_m + + ! Author: Lionel GUEZ + + implicit none + +contains + + subroutine regr_pr_av(ncid, name, julien, press_in_edg, paprs, v3) + + ! "regr_pr_av" stands for "regrid pressure averaging". + ! In this procedure: + ! -- the root process reads 2D latitude-pressure fields from a + ! NetCDF file, at a given day. + ! -- the fields are packed to the LMDZ horizontal "physics" + ! grid and scattered to all threads of all processes; + ! -- in all the threads of all the processes, the fields are regridded in + ! pressure to the LMDZ vertical grid. + ! We assume that, in the input file, the fields have 3 dimensions: + ! latitude, pressure, julian day. + ! We assume that the input fields are already on the "rlatu" + ! latitudes, excepth that latitudes are in ascending order in the input + ! file. + ! We assume that the inputs fields have the same pressure coordinate. + + ! The target vertical LMDZ grid is the grid of layer boundaries. + ! Regridding in pressure is done by averaging a step function of pressure. + + ! All the fields are regridded as a single multi-dimensional array + ! so it saves CPU time to call this procedure once for several NetCDF + ! variables rather than several times, each time for a single + ! NetCDF variable. + + use dimphy, only: klon + use netcdf95, only: nf95_inq_varid, handle_err + use netcdf, only: nf90_get_var + use assert_m, only: assert + use assert_eq_m, only: assert_eq + use regr1_step_av_m, only: regr1_step_av + use mod_phys_lmdz_mpi_data, only: is_mpi_root + + use mod_phys_lmdz_transfert_para, only: scatter2d + ! (pack to the LMDZ horizontal "physics" grid and scatter) + + integer, intent(in):: ncid ! NetCDF ID of the file + character(len=*), intent(in):: name(:) ! of the NetCDF variables + integer, intent(in):: julien ! jour julien, 1 <= julien <= 360 + + real, intent(in):: press_in_edg(:) + ! edges of pressure intervals for input data, in Pa, in strictly + ! ascending order + + real, intent(in):: paprs(:, :) ! (klon, llm + 1) + ! (pression pour chaque inter-couche, en Pa) + + real, intent(out):: v3(:, :, :) ! (klon, llm, size(name)) + ! regridded fields on the partial "physics" grid + ! "v3(i, k, l)" is at longitude "xlon(i)", latitude + ! "xlat(i)", in pressure interval "[paprs(i, k+1), paprs(i, k)]", + ! for NetCDF variable "name(l)". + + ! Variables local to the procedure: + + include "dimensions.h" + integer varid, ncerr ! for NetCDF + + real v1(iim, jjm + 1, size(press_in_edg) - 1, size(name)) + ! input fields at day "julien", on the global "dynamics" horizontal grid + ! First dimension is for longitude. + ! The values are the same for all longitudes. + ! "v1(:, j, k, l)" is at latitude "rlatu(j)", for + ! pressure interval "[press_in_edg(k), press_in_edg(k+1)]" and + ! NetCDF variable "name(l)". + + real v2(klon, size(press_in_edg) - 1, size(name)) + ! fields scattered to the partial "physics" horizontal grid + ! "v2(i, k, l)" is at longitude "xlon(i)", latitude "xlat(i)", + ! for pressure interval "[press_in_edg(k), press_in_edg(k+1)]" and + ! NetCDF variable "name(l)". + + integer i, n_var + + !-------------------------------------------- + + call assert(size(v3, 1) == klon, size(v3, 2) == llm, "regr_pr_av v3 klon") + n_var = assert_eq(size(name), size(v3, 3), "regr_pr_av v3 n_var") + call assert(shape(paprs) == (/klon, llm+1/), "regr_pr_av paprs") + + !$omp master + if (is_mpi_root) then + do i = 1, n_var + call nf95_inq_varid(ncid, name(i), varid) + + ! Get data at the right day from the input file: + ncerr = nf90_get_var(ncid, varid, v1(1, :, :, i), & + start=(/1, 1, julien/)) + call handle_err("regr_pr_av nf90_get_var " // name(i), ncerr, ncid) + end do + + ! Latitudes are in ascending order in the input file while + ! "rlatu" is in descending order so we need to invert order: + v1(1, :, :, :) = v1(1, jjm+1:1:-1, :, :) + + ! Duplicate on all longitudes: + v1(2:, :, :, :) = spread(v1(1, :, :, :), dim=1, ncopies=iim-1) + end if + !$omp end master + + call scatter2d(v1, v2) + + ! Regrid in pressure at each horizontal position: + do i = 1, klon + v3(i, llm:1:-1, :) = regr1_step_av(v2(i, :, :), press_in_edg, & + paprs(i, llm+1:1:-1)) + ! (invert order of indices because "paprs" is in descending order) + end do + + end subroutine regr_pr_av + +end module regr_pr_av_m Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/regr_pr_int_m.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/regr_pr_int_m.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/regr_pr_int_m.F90 (revision 1280) @@ -0,0 +1,106 @@ +! $Id$ +module regr_pr_int_m + + ! Author: Lionel GUEZ + + implicit none + +contains + + subroutine regr_pr_int(ncid, name, julien, plev, pplay, top_value, v3) + + ! "regr_pr_int" stands for "regrid pressure interpolation". + ! In this procedure: + ! -- the root process reads a 2D latitude-pressure field from a + ! NetCDF file, at a given day. + ! -- the field is packed to the LMDZ horizontal "physics" + ! grid and scattered to all threads of all processes; + ! -- in all the threads of all the processes, the field is regridded in + ! pressure to the LMDZ vertical grid. + ! We assume that, in the input file, the field has 3 dimensions: + ! latitude, pressure, julian day. + ! We assume that latitudes are in ascending order in the input file. + ! The target vertical LMDZ grid is the grid of mid-layers. + ! Regridding is by linear interpolation. + + use dimphy, only: klon + use netcdf95, only: nf95_inq_varid, handle_err + use netcdf, only: nf90_get_var + use assert_m, only: assert + use regr1_lint_m, only: regr1_lint + use mod_phys_lmdz_mpi_data, only: is_mpi_root + + use mod_phys_lmdz_transfert_para, only: scatter2d + ! (pack to the LMDZ horizontal "physics" grid and scatter) + + integer, intent(in):: ncid ! NetCDF ID of the file + character(len=*), intent(in):: name ! of the NetCDF variable + integer, intent(in):: julien ! jour julien, 1 <= julien <= 360 + + real, intent(in):: plev(:) + ! (pressure level of input data, in Pa, in strictly ascending order) + + real, intent(in):: pplay(:, :) ! (klon, llm) + ! (pression pour le mileu de chaque couche, en Pa) + + real, intent(in):: top_value + ! (extra value of field at 0 pressure) + + real, intent(out):: v3(:, :) ! (klon, llm) + ! (regridded field on the partial "physics" grid) + ! ("v3(i, k)" is at longitude "xlon(i)", latitude + ! "xlat(i)", middle of layer "k".) + + ! Variables local to the procedure: + + include "dimensions.h" + integer varid, ncerr ! for NetCDF + + real v1(iim, jjm + 1, 0:size(plev)) + ! (input field at day "julien", on the global "dynamics" horizontal grid) + ! (First dimension is for longitude. + ! The value is the same for all longitudes. + ! "v1(:, j, k >=1)" is at latitude "rlatu(j)" and pressure "plev(k)".) + + real v2(klon, 0:size(plev)) + ! (field scattered to the partial "physics" horizontal grid) + ! "v2(i, k >= 1)" is at longitude "xlon(i)", latitude "xlat(i)" + ! and pressure "plev(k)".) + + integer i + + !-------------------------------------------- + + call assert(shape(v3) == (/klon, llm/), "regr_pr_int v3") + call assert(shape(pplay) == (/klon, llm/), "regr_pr_int pplay") + + !$omp master + if (is_mpi_root) then + call nf95_inq_varid(ncid, name, varid) + + ! Get data at the right day from the input file: + ncerr = nf90_get_var(ncid, varid, v1(1, :, 1:), start=(/1, 1, julien/)) + call handle_err("regr_pr_int nf90_get_var " // name, ncerr, ncid) + ! Latitudes are in ascending order in the input file while + ! "rlatu" is in descending order so we need to invert order: + v1(1, :, 1:) = v1(1, jjm+1:1:-1, 1:) + + ! Complete "v1" with the value at 0 pressure: + v1(1, :, 0) = top_value + + ! Duplicate on all longitudes: + v1(2:, :, :) = spread(v1(1, :, :), dim=1, ncopies=iim-1) + end if + !$omp end master + + call scatter2d(v1, v2) + + ! Regrid in pressure at each horizontal position: + do i = 1, klon + v3(i, llm:1:-1) = regr1_lint(v2(i, :), (/0., plev/), pplay(i, llm:1:-1)) + ! (invert order of indices because "pplay" is in descending order) + end do + + end subroutine regr_pr_int + +end module regr_pr_int_m Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/screenc.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/screenc.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/screenc.F90 (revision 1280) @@ -0,0 +1,84 @@ +! +! $Header$ +! + SUBROUTINE screenc(klon, knon, nsrf, zxli, & + speed, temp, q_zref, zref, & + ts, qsurf, rugos, psol, & + ustar, testar, qstar, okri, ri1, & + pref, delu, delte, delq) + IMPLICIT NONE +!----------------------------------------------------------------------- +! +! Objet : calcul "correcteur" des anomalies du vent, de la temperature +! potentielle et de l'humidite relative au niveau de reference zref et +! par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) +! a partir des equations de Louis. +! +! Reference : Hess, Colman et McAvaney (1995) +! +! I. Musat, 01.07.2002 +!----------------------------------------------------------------------- +! +! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude) +! knon----input-I- nombre de points pour un type de surface +! nsrf----input-I- indice pour le type de surface; voir indicesol.h +! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li +! speed---input-R- module du vent au 1er niveau du modele +! temp----input-R- temperature de l'air au 1er niveau du modele +! q_zref--input-R- humidite relative au 1er niveau du modele +! zref----input-R- altitude de reference +! ts------input-R- temperature de l'air a la surface +! qsurf---input-R- humidite relative a la surface +! rugos---input-R- rugosite +! psol----input-R- pression au sol +! ustar---input-R- facteur d'echelle pour le vent +! testar--input-R- facteur d'echelle pour la temperature potentielle +! qstar---input-R- facteur d'echelle pour l'humidite relative +! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce +! et zref par rapport au Ri entre la sfce et la 1ere couche +! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche +! +! pref----input-R- pression au niveau de reference +! delu----input-R- anomalie du vent par rapport au 1er niveau +! delte---input-R- anomalie de la temperature potentielle par rapport a la surface +! delq----input-R- anomalie de l'humidite relative par rapport a la surface +! + INTEGER, intent(in) :: klon, knon, nsrf + LOGICAL, intent(in) :: zxli, okri + REAL, dimension(klon), intent(in) :: speed, temp, q_zref + REAL, intent(in) :: zref + REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, psol + REAL, dimension(klon), intent(in) :: ustar, testar, qstar, ri1 +! + REAL, dimension(klon), intent(out) :: pref, delu, delte, delq +!----------------------------------------------------------------------- + include "YOMCST.h" +! +! Variables locales + INTEGER :: i + REAL, dimension(klon) :: cdram, cdrah, cdran, zri1, gref +! +!------------------------------------------------------------------------- + DO i=1, knon + gref(i) = zref*RG + ENDDO +! +! Richardson at reference level +! + CALL coefcdrag (klon, knon, nsrf, zxli, & + speed, temp, q_zref, gref, & + psol, ts, qsurf, rugos, & + okri, ri1, & + cdram, cdrah, cdran, zri1, & + pref) +! + DO i = 1, knon + delu(i) = ustar(i)/sqrt(cdram(i)) + delte(i)= (testar(i)* sqrt(cdram(i)))/ & + cdrah(i) + delq(i)= (qstar(i)* sqrt(cdram(i)))/ & + cdrah(i) + ENDDO +! + RETURN + END SUBROUTINE screenc Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/screenp.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/screenp.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/screenp.F90 (revision 1280) @@ -0,0 +1,109 @@ +! +! $Header$ +! + SUBROUTINE screenp(klon, knon, nsrf, & + & speed, tair, qair, & + & ts, qsurf, rugos, lmon, & + & ustar, testar, qstar, zref, & + & delu, delte, delq) + IMPLICIT none +!------------------------------------------------------------------------- +! +! Objet : calcul "predicteur" des anomalies du vent, de la temperature +! potentielle et de l'humidite relative au niveau de reference zref et +! par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) +! a partir des relations de Dyer-Businger. +! +! Reference : Hess, Colman et McAvaney (1995) +! +! I. Musat, 01.07.2002 +!------------------------------------------------------------------------- +! +! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude) +! knon----input-I- nombre de points pour un type de surface +! nsrf----input-I- indice pour le type de surface; voir indicesol.h +! speed---input-R- module du vent au 1er niveau du modele +! tair----input-R- temperature de l'air au 1er niveau du modele +! qair----input-R- humidite relative au 1er niveau du modele +! ts------input-R- temperature de l'air a la surface +! qsurf---input-R- humidite relative a la surface +! rugos---input-R- rugosite +! lmon----input-R- longueur de Monin-Obukov +! ustar---input-R- facteur d'echelle pour le vent +! testar--input-R- facteur d'echelle pour la temperature potentielle +! qstar---input-R- facteur d'echelle pour l'humidite relative +! zref----input-R- altitude de reference +! +! delu----input-R- anomalie du vent par rapport au 1er niveau +! delte---input-R- anomalie de la temperature potentielle par rapport a la surface +! delq----input-R- anomalie de l'humidite relative par rapport a la surface +! + INTEGER, intent(in) :: klon, knon, nsrf + REAL, dimension(klon), intent(in) :: speed, tair, qair + REAL, dimension(klon), intent(in) :: ts, qsurf, rugos + DOUBLE PRECISION, dimension(klon), intent(in) :: lmon + REAL, dimension(klon), intent(in) :: ustar, testar, qstar + REAL, intent(in) :: zref +! + REAL, dimension(klon), intent(out) :: delu, delte, delq +! +!------------------------------------------------------------------------- +! Variables locales et constantes : + REAL, PARAMETER :: RKAR=0.40 + INTEGER :: i + REAL :: xtmp, xtmp0 +!------------------------------------------------------------------------- + DO i = 1, knon +! + IF (lmon(i).GE.0.) THEN +! +! STABLE CASE +! + IF (speed(i).GT.1.5.AND.lmon(i).LE.1.0 & + & .AND. rugos(i).LE.1.0) THEN + delu(i) = (ustar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) + & + min(5.d0, 5.0 *(zref - rugos(i))/lmon(i))) + delte(i) = (testar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) + & + min(5.d0, 5.0 * (zref - rugos(i))/lmon(i))) + delq(i) = (qstar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) + & + min(5.d0, 5.0 * (zref - rugos(i))/lmon(i))) + ELSE + delu(i) = 0.1 * speed(i) + delte(i) = 0.1 * (tair(i) - ts(i) ) + delq(i) = 0.1 * (max(qair(i),0.0) - max(qsurf(i),0.0)) + ENDIF + ELSE +! +! UNSTABLE CASE +! + IF (speed(i).GT.5.0.AND.abs(lmon(i)).LE.50.0) THEN + xtmp = (1. - 16. * (zref/lmon(i)))**(1./4.) + xtmp0 = (1. - 16. * (rugos(i)/lmon(i)))**(1./4.) + delu(i) = (ustar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) & + - 2.*log(0.5*(1. + xtmp)) & + + 2.*log(0.5*(1. + xtmp0)) & + - log(0.5*(1. + xtmp*xtmp)) & + + log(0.5*(1. + xtmp0*xtmp0)) & + + 2.*atan(xtmp) - 2.*atan(xtmp0)) + delte(i) = (testar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) & + - 2.0 * log(0.5*(1. + xtmp*xtmp)) & + + 2.0 * log(0.5*(1. + xtmp0*xtmp0))) + delq(i) = (qstar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) & + - 2.0 * log(0.5*(1. + xtmp*xtmp)) & + + 2.0 * log(0.5*(1. + xtmp0*xtmp0))) + ELSE + delu(i) = 0.5 * speed(i) + delte(i) = 0.5 * (tair(i) - ts(i) ) + delq(i) = 0.5 * (max(qair(i),0.0) - max(qsurf(i),0.0)) + ENDIF + ENDIF +! + ENDDO + RETURN + END SUBROUTINE screenp Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/soil.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/soil.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/soil.F90 (revision 1280) @@ -0,0 +1,278 @@ +! +! $Header$ +! +SUBROUTINE soil(ptimestep, indice, knon, snow, ptsrf, & + ptsoil, pcapcal, pfluxgrd) + + USE dimphy + USE mod_phys_lmdz_para + IMPLICIT NONE + +!======================================================================= +! +! Auteur: Frederic Hourdin 30/01/92 +! ------- +! +! Object: Computation of : the soil temperature evolution +! ------- the surfacic heat capacity "Capcal" +! the surface conduction flux pcapcal +! +! +! Method: Implicit time integration +! ------- +! Consecutive ground temperatures are related by: +! T(k+1) = C(k) + D(k)*T(k) (*) +! The coefficients C and D are computed at the t-dt time-step. +! Routine structure: +! 1) C and D coefficients are computed from the old temperature +! 2) new temperatures are computed using (*) +! 3) C and D coefficients are computed from the new temperature +! profile for the t+dt time-step +! 4) the coefficients A and B are computed where the diffusive +! fluxes at the t+dt time-step is given by +! Fdiff = A + B Ts(t+dt) +! or Fdiff = F0 + Capcal (Ts(t+dt)-Ts(t))/dt +! with F0 = A + B (Ts(t)) +! Capcal = B*dt +! +! Interface: +! ---------- +! +! Arguments: +! ---------- +! ptimestep physical timestep (s) +! indice sub-surface index +! snow(klon) snow +! ptsrf(klon) surface temperature at time-step t (K) +! ptsoil(klon,nsoilmx) temperature inside the ground (K) +! pcapcal(klon) surfacic specific heat (W*m-2*s*K-1) +! pfluxgrd(klon) surface diffusive flux from ground (Wm-2) +! +!======================================================================= + INCLUDE "YOMCST.h" + INCLUDE "dimsoil.h" + INCLUDE "indicesol.h" + INCLUDE "comsoil.h" +!----------------------------------------------------------------------- +! Arguments +! --------- + REAL, INTENT(IN) :: ptimestep + INTEGER, INTENT(IN) :: indice, knon + REAL, DIMENSION(klon), INTENT(IN) :: snow + REAL, DIMENSION(klon), INTENT(IN) :: ptsrf + + REAL, DIMENSION(klon,nsoilmx), INTENT(INOUT) :: ptsoil + REAL, DIMENSION(klon), INTENT(OUT) :: pcapcal + REAL, DIMENSION(klon), INTENT(OUT) :: pfluxgrd + +!----------------------------------------------------------------------- +! Local variables +! --------------- + INTEGER :: ig, jk, ierr + REAL :: min_period,dalph_soil + REAL, DIMENSION(nsoilmx) :: zdz2 + REAL :: z1s + REAL, DIMENSION(klon) :: ztherm_i + REAL, DIMENSION(klon,nsoilmx,nbsrf) :: C_coef, D_coef + +! Local saved variables +! --------------------- + REAL, SAVE :: lambda +!$OMP THREADPRIVATE(lambda) + REAL, DIMENSION(nsoilmx), SAVE :: dz1, dz2 +!$OMP THREADPRIVATE(dz1,dz2) + LOGICAL, SAVE :: firstcall=.TRUE. +!$OMP THREADPRIVATE(firstcall) + +!----------------------------------------------------------------------- +! Depthts: +! -------- + REAL fz,rk,fz1,rk1,rk2 + fz(rk)=fz1*(dalph_soil**rk-1.)/(dalph_soil-1.) + + +!----------------------------------------------------------------------- +! Calculation of some constants +! NB! These constants do not depend on the sub-surfaces +!----------------------------------------------------------------------- + + IF (firstcall) THEN +!----------------------------------------------------------------------- +! ground levels +! grnd=z/l where l is the skin depth of the diurnal cycle: +!----------------------------------------------------------------------- + + min_period=1800. ! en secondes + dalph_soil=2. ! rapport entre les epaisseurs de 2 couches succ. +!$OMP MASTER + IF (is_mpi_root) THEN + OPEN(99,file='soil.def',status='old',form='formatted',iostat=ierr) + IF (ierr == 0) THEN ! Read file only if it exists + READ(99,*) min_period + READ(99,*) dalph_soil + PRINT*,'Discretization for the soil model' + PRINT*,'First level e-folding depth',min_period, & + ' dalph',dalph_soil + CLOSE(99) + END IF + ENDIF +!$OMP END MASTER + CALL bcast(min_period) + CALL bcast(dalph_soil) + +! la premiere couche represente un dixieme de cycle diurne + fz1=SQRT(min_period/3.14) + + DO jk=1,nsoilmx + rk1=jk + rk2=jk-1 + dz2(jk)=fz(rk1)-fz(rk2) + ENDDO + DO jk=1,nsoilmx-1 + rk1=jk+.5 + rk2=jk-.5 + dz1(jk)=1./(fz(rk1)-fz(rk2)) + ENDDO + lambda=fz(.5)*dz1(1) + PRINT*,'full layers, intermediate layers (seconds)' + DO jk=1,nsoilmx + rk=jk + rk1=jk+.5 + rk2=jk-.5 + PRINT *,'fz=', & + fz(rk1)*fz(rk2)*3.14,fz(rk)*fz(rk)*3.14 + ENDDO + + firstcall =.FALSE. + END IF + + +!----------------------------------------------------------------------- +! Calcul de l'inertie thermique a partir de la variable rnat. +! on initialise a inertie_ice meme au-dessus d'un point de mer au cas +! ou le point de mer devienne point de glace au pas suivant +! on corrige si on a un point de terre avec ou sans glace +! +!----------------------------------------------------------------------- + IF (indice == is_sic) THEN + DO ig = 1, knon + ztherm_i(ig) = inertie_ice + IF (snow(ig) > 0.0) ztherm_i(ig) = inertie_sno + ENDDO + ELSE IF (indice == is_lic) THEN + DO ig = 1, knon + ztherm_i(ig) = inertie_ice + IF (snow(ig) > 0.0) ztherm_i(ig) = inertie_sno + ENDDO + ELSE IF (indice == is_ter) THEN + DO ig = 1, knon + ztherm_i(ig) = inertie_sol + IF (snow(ig) > 0.0) ztherm_i(ig) = inertie_sno + ENDDO + ELSE IF (indice == is_oce) THEN + DO ig = 1, knon + ztherm_i(ig) = inertie_ice + ENDDO + ELSE + PRINT*, "valeur d indice non prevue", indice + CALL abort + ENDIF + + +!----------------------------------------------------------------------- +! 1) +! Calculation of Cgrf and Dgrd coefficients using soil temperature from +! previous time step. +! +! These variables are recalculated on the local compressed grid instead +! of saved in restart file. +!----------------------------------------------------------------------- + DO jk=1,nsoilmx + zdz2(jk)=dz2(jk)/ptimestep + ENDDO + + DO ig=1,knon + z1s = zdz2(nsoilmx)+dz1(nsoilmx-1) + C_coef(ig,nsoilmx-1,indice)= & + zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1s + D_coef(ig,nsoilmx-1,indice)=dz1(nsoilmx-1)/z1s + ENDDO + + DO jk=nsoilmx-1,2,-1 + DO ig=1,knon + z1s = 1./(zdz2(jk)+dz1(jk-1)+dz1(jk) & + *(1.-D_coef(ig,jk,indice))) + C_coef(ig,jk-1,indice)= & + (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*C_coef(ig,jk,indice)) * z1s + D_coef(ig,jk-1,indice)=dz1(jk-1)*z1s + ENDDO + ENDDO + +!----------------------------------------------------------------------- +! 2) +! Computation of the soil temperatures using the Cgrd and Dgrd +! coefficient computed above +! +!----------------------------------------------------------------------- + +! Surface temperature + DO ig=1,knon + ptsoil(ig,1)=(lambda*C_coef(ig,1,indice)+ptsrf(ig))/ & + (lambda*(1.-D_coef(ig,1,indice))+1.) + ENDDO + +! Other temperatures + DO jk=1,nsoilmx-1 + DO ig=1,knon + ptsoil(ig,jk+1)=C_coef(ig,jk,indice)+D_coef(ig,jk,indice) & + *ptsoil(ig,jk) + ENDDO + ENDDO + + IF (indice == is_sic) THEN + DO ig = 1 , knon + ptsoil(ig,nsoilmx) = RTT - 1.8 + END DO + ENDIF + +!----------------------------------------------------------------------- +! 3) +! Calculate the Cgrd and Dgrd coefficient corresponding to actual soil +! temperature +!----------------------------------------------------------------------- + DO ig=1,knon + z1s = zdz2(nsoilmx)+dz1(nsoilmx-1) + C_coef(ig,nsoilmx-1,indice) = zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1s + D_coef(ig,nsoilmx-1,indice) = dz1(nsoilmx-1)/z1s + ENDDO + + DO jk=nsoilmx-1,2,-1 + DO ig=1,knon + z1s = 1./(zdz2(jk)+dz1(jk-1)+dz1(jk) & + *(1.-D_coef(ig,jk,indice))) + C_coef(ig,jk-1,indice) = & + (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*C_coef(ig,jk,indice)) * z1s + D_coef(ig,jk-1,indice) = dz1(jk-1)*z1s + ENDDO + ENDDO + +!----------------------------------------------------------------------- +! 4) +! Computation of the surface diffusive flux from ground and +! calorific capacity of the ground +!----------------------------------------------------------------------- + DO ig=1,knon + pfluxgrd(ig) = ztherm_i(ig)*dz1(1)* & + (C_coef(ig,1,indice)+(D_coef(ig,1,indice)-1.)*ptsoil(ig,1)) + pcapcal(ig) = ztherm_i(ig)* & + (dz2(1)+ptimestep*(1.-D_coef(ig,1,indice))*dz1(1)) + z1s = lambda*(1.-D_coef(ig,1,indice))+1. + pcapcal(ig) = pcapcal(ig)/z1s + pfluxgrd(ig) = pfluxgrd(ig) & + + pcapcal(ig) * (ptsoil(ig,1) * z1s & + - lambda * C_coef(ig,1,indice) & + - ptsrf(ig)) & + /ptimestep + ENDDO + +END SUBROUTINE soil Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/solarlong.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/solarlong.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/solarlong.F (revision 1280) @@ -0,0 +1,131 @@ + SUBROUTINE solarlong(pday,psollong,pdist_sol) + + USE ioipsl + + IMPLICIT NONE + +c======================================================================= +c +c Objet: +c ------ +c +c Calcul de la distance soleil-planete et de la declinaison +c en fonction du jour de l'annee. +c +c +c Methode: +c -------- +c +c Calcul complet de l'elipse +c +c Interface: +c ---------- +c +c Uncommon comprenant les parametres orbitaux. +c +c Arguments: +c ---------- +c +c Input: +c ------ +c pday jour de l'annee (le jour 0 correspondant a l'equinoxe) +c lwrite clef logique pour sorties de controle +c +c Output: +c ------- +c pdist_sol distance entre le soleil et la planete +c ( en unite astronomique pour utiliser la constante +c solaire terrestre 1370 Wm-2 ) +c pdecli declinaison ( en radians ) +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "planete.h" +#include "YOMCST.h" + include 'iniprint.h' + +c arguments: +c ---------- + + REAL pday,pdist_sol,pdecli,psollong + LOGICAL lwrite + +c Local: +c ------ + + REAL zanom,xref,zx0,zdx,zteta,zz,pi + INTEGER iter + REAL :: pyear_day,pperi_day + REAL :: jD_eq, jD_peri + +c----------------------------------------------------------------------- +c calcul de l'angle polaire et de la distance au soleil : +c ------------------------------------------------------- + +c Initialisation eventuelle: + if(.not.unitastr.gt.1.e-4) then + call ioget_calendar(pyear_day) + call ymds2ju(2000, 3, 21, 0., jD_eq) + call ymds2ju(2001, 1, 4, 0., jD_peri) + pperi_day = jD_peri - jD_eq + pperi_day = R_peri + 180. + write(lunout,*)' Number of days in a year = ',pyear_day +c call iniorbit(249.22,206.66,669.,485.,25.2) + call iniorbit(152.59,146.61,pyear_day,pperi_day,R_incl) + endif + +c calcul de l'zanomalie moyenne + + zz=(pday-peri_day)/year_day + pi=2.*asin(1.) + zanom=2.*pi*(zz-nint(zz)) + xref=abs(zanom) + +c resolution de l'equation horaire zx0 - e * sin (zx0) = xref +c methode de Newton + +! zx0=xref+e_elips*sin(xref) + zx0=xref+R_ecc*sin(xref) + DO 110 iter=1,10 +! zdx=-(zx0-e_elips*sin(zx0)-xref)/(1.-e_elips*cos(zx0)) + zdx=-(zx0-R_ecc*sin(zx0)-xref)/(1.-R_ecc*cos(zx0)) + if(abs(zdx).le.(1.e-7)) goto 120 + zx0=zx0+zdx +110 continue +120 continue + zx0=zx0+zdx + if(zanom.lt.0.) zx0=-zx0 + +c zteta est la longitude solaire + +! zteta=2.*atan(sqrt((1.+e_elips)/(1.-e_elips))*tan(zx0/2.)) + zteta=2.*atan(sqrt((1.+R_ecc)/(1.-R_ecc))*tan(zx0/2.)) + + psollong=zteta-timeperi + + IF(psollong.LT.0.) psollong=psollong+2.*pi + IF(psollong.GT.2.*pi) psollong=psollong-2.*pi + + psollong = psollong * 180. / pi + +c distance soleil + + pdist_sol = (1-R_ecc*R_ecc) + & /(1+R_ecc*COS(pi/180.*(psollong-(R_peri+180.0)))) +! pdist_sol = (1-e_elips*e_elips) +! & /(1+e_elips*COS(pi/180.*(psollong-(R_peri+180.0)))) +c----------------------------------------------------------------------- +c sorties eventuelles: +c --------------------- + +c IF (lwrite) THEN +c PRINT*,'jour de l"annee :',pday +c PRINT*,'distance au soleil (en unite astronomique) :',pdist_sol +c PRINT*,'declinaison (en degres) :',pdecli*180./pi +c ENDIF + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/stdlevvar.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/stdlevvar.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/stdlevvar.F90 (revision 1280) @@ -0,0 +1,278 @@ +! +! $Header$ +! + SUBROUTINE stdlevvar(klon, knon, nsrf, zxli, & + u1, v1, t1, q1, z1, & + ts1, qsurf, rugos, psol, pat1, & + t_2m, q_2m, t_10m, q_10m, u_10m, ustar) + IMPLICIT NONE +!------------------------------------------------------------------------- +! +! Objet : calcul de la temperature et l'humidite relative a 2m et du +! module du vent a 10m a partir des relations de Dyer-Businger et +! des equations de Louis. +! +! Reference : Hess, Colman et McAvaney (1995) +! +! I. Musat, 01.07.2002 +! +!AM On rajoute en sortie t et q a 10m pr le calcule d'hbtm2 dans clmain +! +!------------------------------------------------------------------------- +! +! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude) +! knon----input-I- nombre de points pour un type de surface +! nsrf----input-I- indice pour le type de surface; voir indicesol.h +! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li +! u1------input-R- vent zonal au 1er niveau du modele +! v1------input-R- vent meridien au 1er niveau du modele +! t1------input-R- temperature de l'air au 1er niveau du modele +! q1------input-R- humidite relative au 1er niveau du modele +! z1------input-R- geopotentiel au 1er niveau du modele +! ts1-----input-R- temperature de l'air a la surface +! qsurf---input-R- humidite relative a la surface +! rugos---input-R- rugosite +! psol----input-R- pression au sol +! pat1----input-R- pression au 1er niveau du modele +! +! t_2m---output-R- temperature de l'air a 2m +! q_2m---output-R- humidite relative a 2m +! u_10m--output-R- vitesse du vent a 10m +!AM +! t_10m--output-R- temperature de l'air a 10m +! q_10m--output-R- humidite specifique a 10m +! ustar--output-R- u* +! + INTEGER, intent(in) :: klon, knon, nsrf + LOGICAL, intent(in) :: zxli + REAL, dimension(klon), intent(in) :: u1, v1, t1, q1, z1, ts1 + REAL, dimension(klon), intent(in) :: qsurf, rugos + REAL, dimension(klon), intent(in) :: psol, pat1 +! + REAL, dimension(klon), intent(out) :: t_2m, q_2m, ustar + REAL, dimension(klon), intent(out) :: u_10m, t_10m, q_10m +!------------------------------------------------------------------------- + include "YOMCST.h" +!IM PLUS + include "YOETHF.h" +! +! Quelques constantes et options: +! +! RKAR : constante de von Karman + REAL, PARAMETER :: RKAR=0.40 +! niter : nombre iterations calcul "corrector" +! INTEGER, parameter :: niter=6, ncon=niter-1 + INTEGER, parameter :: niter=2, ncon=niter-1 +! +! Variables locales + INTEGER :: i, n + REAL :: zref + REAL, dimension(klon) :: speed +! tpot : temperature potentielle + REAL, dimension(klon) :: tpot + REAL, dimension(klon) :: zri1, cdran + REAL, dimension(klon) :: cdram, cdrah +! ri1 : nb. de Richardson entre la surface --> la 1ere couche + REAL, dimension(klon) :: ri1 + REAL, dimension(klon) :: testar, qstar + REAL, dimension(klon) :: zdte, zdq +! lmon : longueur de Monin-Obukhov selon Hess, Colman and McAvaney + DOUBLE PRECISION, dimension(klon) :: lmon + DOUBLE PRECISION, parameter :: eps=1.0D-20 + REAL, dimension(klon) :: delu, delte, delq + REAL, dimension(klon) :: u_zref, te_zref, q_zref + REAL, dimension(klon) :: temp, pref + LOGICAL :: okri + REAL, dimension(klon) :: u_zref_p, te_zref_p, temp_p, q_zref_p +!convertgence + REAL, dimension(klon) :: te_zref_con, q_zref_con + REAL, dimension(klon) :: u_zref_c, te_zref_c, temp_c, q_zref_c + REAL, dimension(klon) :: ok_pred, ok_corr +! REAL, dimension(klon) :: conv_te, conv_q +!------------------------------------------------------------------------- + DO i=1, knon + speed(i)=SQRT(u1(i)**2+v1(i)**2) + ri1(i) = 0.0 + ENDDO +! + okri=.FALSE. + CALL coefcdrag(klon, knon, nsrf, zxli, & + & speed, t1, q1, z1, psol, & + & ts1, qsurf, rugos, okri, ri1, & + & cdram, cdrah, cdran, zri1, pref) +! +!---------Star variables---------------------------------------------------- +! + DO i = 1, knon + ri1(i) = zri1(i) + tpot(i) = t1(i)* (psol(i)/pat1(i))**RKAPPA + ustar(i) = sqrt(cdram(i) * speed(i) * speed(i)) + zdte(i) = tpot(i) - ts1(i) + zdq(i) = max(q1(i),0.0) - max(qsurf(i),0.0) +! +! +!IM BUG BUG BUG zdte(i) = max(zdte(i),1.e-10) + zdte(i) = sign(max(abs(zdte(i)),1.e-10),zdte(i)) +! + testar(i) = (cdrah(i) * zdte(i) * speed(i))/ustar(i) + qstar(i) = (cdrah(i) * zdq(i) * speed(i))/ustar(i) + lmon(i) = (ustar(i) * ustar(i) * tpot(i))/ & + & (RKAR * RG * testar(i)) + ENDDO +! +!----------First aproximation of variables at zref -------------------------- + zref = 2.0 + CALL screenp(klon, knon, nsrf, speed, tpot, q1, & + & ts1, qsurf, rugos, lmon, & + & ustar, testar, qstar, zref, & + & delu, delte, delq) +! + DO i = 1, knon + u_zref(i) = delu(i) + q_zref(i) = max(qsurf(i),0.0) + delq(i) + te_zref(i) = ts1(i) + delte(i) + temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA) + q_zref_p(i) = q_zref(i) +! te_zref_p(i) = te_zref(i) + temp_p(i) = temp(i) + ENDDO +! +! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995 +! + DO n = 1, niter +! + okri=.TRUE. + CALL screenc(klon, knon, nsrf, zxli, & + & u_zref, temp, q_zref, zref, & + & ts1, qsurf, rugos, psol, & + & ustar, testar, qstar, okri, ri1, & + & pref, delu, delte, delq) +! + DO i = 1, knon + u_zref(i) = delu(i) + q_zref(i) = delq(i) + max(qsurf(i),0.0) + te_zref(i) = delte(i) + ts1(i) +! +! return to normal temperature +! + temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA) +! temp(i) = te_zref(i) - (zref* RG)/RCPD/ & +! (1 + RVTMP2 * max(q_zref(i),0.0)) +! +!IM +++ +! IF(temp(i).GT.350.) THEN +! WRITE(*,*) 'temp(i) GT 350 K !!',i,nsrf,temp(i) +! ENDIF +!IM --- +! + IF(n.EQ.ncon) THEN + te_zref_con(i) = te_zref(i) + q_zref_con(i) = q_zref(i) + ENDIF +! + ENDDO +! + ENDDO +! +! verifier le critere de convergence : 0.25% pour te_zref et 5% pour qe_zref +! +! DO i = 1, knon +! conv_te(i) = (te_zref(i) - te_zref_con(i))/te_zref_con(i) +! conv_q(i) = (q_zref(i) - q_zref_con(i))/q_zref_con(i) +!IM +++ +! IF(abs(conv_te(i)).GE.0.0025.AND.abs(conv_q(i)).GE.0.05) THEN +! PRINT*,'DIV','i=',i,te_zref_con(i),te_zref(i),conv_te(i), & +! q_zref_con(i),q_zref(i),conv_q(i) +! ENDIF +!IM --- +! ENDDO +! + DO i = 1, knon + q_zref_c(i) = q_zref(i) + temp_c(i) = temp(i) +! +! IF(zri1(i).LT.0.) THEN +! IF(nsrf.EQ.1) THEN +! ok_pred(i)=1. +! ok_corr(i)=0. +! ELSE +! ok_pred(i)=0. +! ok_corr(i)=1. +! ENDIF +! ELSE +! ok_pred(i)=0. +! ok_corr(i)=1. +! ENDIF +! + ok_pred(i)=0. + ok_corr(i)=1. +! + t_2m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i) + q_2m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i) +!IM +++ +! IF(n.EQ.niter) THEN +! IF(t_2m(i).LT.t1(i).AND.t_2m(i).LT.ts1(i)) THEN +! PRINT*,' BAD t2m LT ',i,nsrf,t_2m(i),t1(i),ts1(i) +! ELSEIF(t_2m(i).GT.t1(i).AND.t_2m(i).GT.ts1(i)) THEN +! PRINT*,' BAD t2m GT ',i,nsrf,t_2m(i),t1(i),ts1(i) +! ENDIF +! ENDIF +!IM --- + ENDDO +! +! +!----------First aproximation of variables at zref -------------------------- +! + zref = 10.0 + CALL screenp(klon, knon, nsrf, speed, tpot, q1, & + & ts1, qsurf, rugos, lmon, & + & ustar, testar, qstar, zref, & + & delu, delte, delq) +! + DO i = 1, knon + u_zref(i) = delu(i) + q_zref(i) = max(qsurf(i),0.0) + delq(i) + te_zref(i) = ts1(i) + delte(i) + temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA) +! temp(i) = te_zref(i) - (zref* RG)/RCPD/ & +! (1 + RVTMP2 * max(q_zref(i),0.0)) + u_zref_p(i) = u_zref(i) + ENDDO +! +! Iteration of the variables at the reference level zref : corrector ; see Hess & McAvaney, 1995 +! + DO n = 1, niter +! + okri=.TRUE. + CALL screenc(klon, knon, nsrf, zxli, & + & u_zref, temp, q_zref, zref, & + & ts1, qsurf, rugos, psol, & + & ustar, testar, qstar, okri, ri1, & + & pref, delu, delte, delq) +! + DO i = 1, knon + u_zref(i) = delu(i) + q_zref(i) = delq(i) + max(qsurf(i),0.0) + te_zref(i) = delte(i) + ts1(i) + temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA) +! temp(i) = te_zref(i) - (zref* RG)/RCPD/ & +! (1 + RVTMP2 * max(q_zref(i),0.0)) + ENDDO +! + ENDDO +! + DO i = 1, knon + u_zref_c(i) = u_zref(i) +! + u_10m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i) +! +!AM + q_zref_c(i) = q_zref(i) + temp_c(i) = temp(i) + t_10m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i) + q_10m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i) +!MA + ENDDO +! + RETURN + END subroutine stdlevvar Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/stratocu_if.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/stratocu_if.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/stratocu_if.F90 (revision 1280) @@ -0,0 +1,78 @@ + SUBROUTINE stratocu_if(klon,klev,pctsrf,paprs, pplay,t & +,seuil_inversion,weak_inversion,dthmin) +implicit none + +!====================================================================== +! J'introduit un peu de diffusion sauf dans les endroits +! ou une forte inversion est presente +! On peut dire qu'il represente la convection peu profonde +! +! Arguments: +! klon-----input-I- nombre de points a traiter +! paprs----input-R- pression a chaque intercouche (en Pa) +! pplay----input-R- pression au milieu de chaque couche (en Pa) +! t--------input-R- temperature (K) +! +! weak_inversion-----logical +!====================================================================== +! +! Arguments: +! + INTEGER, INTENT(IN) :: klon,klev + REAL, DIMENSION(klon, klev+1), INTENT(IN) :: paprs + REAL, DIMENSION(klon, klev), INTENT(IN) :: pplay + REAL, DIMENSION(klon, 4), INTENT(IN) :: pctsrf + REAL, DIMENSION(klon, klev), INTENT(IN) :: t + + REAL, DIMENSION(klon), INTENT(OUT) :: weak_inversion +! +! Quelques constantes et options: +! + REAL seuil_inversion ! au-dela l'inversion est consideree trop faible +! PARAMETER (seuil=-0.1) + +! +! Variables locales: +! + INTEGER i, k, invb(klon) + REAL zl2(klon) + REAL dthmin(klon), zdthdp + + INCLUDE "indicesol.h" + INCLUDE "YOMCST.h" + +! +! Chercher la zone d'inversion forte +! + + DO i = 1, klon + invb(i) = klev + dthmin(i)=0.0 + ENDDO + DO k = 2, klev/2-1 + DO i = 1, klon + zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) & + - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1) + zdthdp = zdthdp * 100.0 + IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. & + zdthdp.LT.dthmin(i) ) THEN + dthmin(i) = zdthdp + invb(i) = k + ENDIF + ENDDO + ENDDO + + +! +! Introduire une diffusion: +! + DO i = 1, klon + IF ( (pctsrf(i,is_oce) < 0.5) .OR. & + (invb(i) == klev) .OR. (dthmin(i) > seuil_inversion) ) THEN + weak_inversion(i)=1. + ELSE + weak_inversion(i)=0. + ENDIF + ENDDO + + END SUBROUTINE stratocu_if Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/suphel.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/suphel.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/suphel.F (revision 1280) @@ -0,0 +1,211 @@ +! +! $Header$ +! + SUBROUTINE suphel +C +#include "YOMCST.h" +#include "YOETHF.h" +cIM cf. JLD + LOGICAL firstcall + SAVE firstcall +c$OMP THREADPRIVATE(firstcall) + DATA firstcall /.TRUE./ + + IF (firstcall) THEN + PRINT*, 'suphel initialise les constantes du GCM' + firstcall = .FALSE. + ELSE + PRINT*, 'suphel DEJA APPELE ' + RETURN + ENDIF +C ----------------------------------------------------------------- +C +C* 1. DEFINE FUNDAMENTAL CONSTANTS. +C ----------------------------- +C + WRITE(UNIT=6,FMT='(''0*** Constants of the ICM ***'')') + RPI=2.*ASIN(1.) + RCLUM=299792458. + RHPLA=6.6260755E-34 + RKBOL=1.380658E-23 + RNAVO=6.0221367E+23 + WRITE(UNIT=6,FMT='('' *** Fundamental constants ***'')') + WRITE(UNIT=6,FMT='('' PI = '',E13.7,'' -'')')RPI + WRITE(UNIT=6,FMT='('' c = '',E13.7,''m s-1'')') + S RCLUM + WRITE(UNIT=6,FMT='('' h = '',E13.7,''J s'')') + S RHPLA + WRITE(UNIT=6,FMT='('' K = '',E13.7,''J K-1'')') + S RKBOL + WRITE(UNIT=6,FMT='('' N = '',E13.7,''mol-1'')') + S RNAVO +C +C ---------------------------------------------------------------- +C +C* 2. DEFINE ASTRONOMICAL CONSTANTS. +C ------------------------------ +C + RDAY=86400. + REA=149597870000. + REPSM=0.409093 +C + RSIYEA=365.25*RDAY*2.*RPI/6.283076 + RSIDAY=RDAY/(1.+RDAY/RSIYEA) + ROMEGA=2.*RPI/RSIDAY +c +c exp1 R_ecc = 0.05 +c exp1 R_peri = 102.04 +c exp1 R_incl = 22.5 +c exp1 print*, 'Parametres orbitaux modifies' +c ref R_ecc = 0.016724 +c ref R_peri = 102.04 +c ref R_incl = 23.5 +c +cIM 161002 : pour avoir les ctes AMIP II +cIM 161002 R_ecc = 0.016724 +cIM 161002 R_peri = 102.04 +cIM 161002 R_incl = 23.5 +cIM on mets R_ecc, R_peri, R_incl dans conf_phys.F90 +c R_ecc = 0.016715 +c R_peri = 102.7 +c R_incl = 23.441 +c + WRITE(UNIT=6,FMT='('' *** Astronomical constants ***'')') + WRITE(UNIT=6,FMT='('' day = '',E13.7,'' s'')')RDAY + WRITE(UNIT=6,FMT='('' half g. axis = '',E13.7,'' m'')')REA + WRITE(UNIT=6,FMT='('' mean anomaly = '',E13.7,'' -'')')REPSM + WRITE(UNIT=6,FMT='('' sideral year = '',E13.7,'' s'')')RSIYEA + WRITE(UNIT=6,FMT='('' sideral day = '',E13.7,'' s'')')RSIDAY + WRITE(UNIT=6,FMT='('' omega = '',E13.7,'' s-1'')') + S ROMEGA +c write(unit=6,fmt='('' excentricite = '',e13.7,''-'')')R_ecc +c write(unit=6,fmt='('' equinoxe = '',e13.7,''-'')')R_peri +c write(unit=6,fmt='('' inclinaison = '',e13.7,''-'')')R_incl +C +C ------------------------------------------------------------------ +C +C* 3. DEFINE GEOIDE. +C -------------- +C + RG=9.80665 + RA=6371229. + R1SA=SNGL(1.D0/DBLE(RA)) + WRITE(UNIT=6,FMT='('' *** Geoide ***'')') + WRITE(UNIT=6,FMT='('' Gravity = '',E13.7,'' m s-2'')') + S RG + WRITE(UNIT=6,FMT='('' Earth radius = '',E13.7,'' m'')')RA + WRITE(UNIT=6,FMT='('' Inverse E.R. = '',E13.7,'' m'')')R1SA +C +C ----------------------------------------------------------------- +C +C* 4. DEFINE RADIATION CONSTANTS. +C --------------------------- +C +c z.x.li RSIGMA=2. * RPI**5 * RKBOL**4 /(15.* RCLUM**2 * RHPLA**3) + rsigma = 2.*rpi**5 * (rkbol/rhpla)**3 * rkbol/rclum/rclum/15. +cIM init. dans conf_phys.F90 RI0=1365. + WRITE(UNIT=6,FMT='('' *** Radiation ***'')') + WRITE(UNIT=6,FMT='('' Stefan-Bol. = '',E13.7,'' W m-2 K-4'' + S )') RSIGMA +cIM init. dans conf_phys.F90 WRITE(UNIT=6,FMT='('' Solar const. = '',E13.7,'' W m-2'')') +cIM init. dans conf_phys.F90 S RI0 +C +C ----------------------------------------------------------------- +C +C* 5. DEFINE THERMODYNAMIC CONSTANTS, GAS PHASE. +C ------------------------------------------ +C + R=RNAVO*RKBOL + RMD=28.9644 + RMO3=47.9942 + RMV=18.0153 + RD=1000.*R/RMD + RV=1000.*R/RMV + RCPD=3.5*RD + RCVD=RCPD-RD + RCPV=4. *RV + RCVV=RCPV-RV + RKAPPA=RD/RCPD + RETV=RV/RD-1. + WRITE(UNIT=6,FMT='('' *** Thermodynamic, gas ***'')') + WRITE(UNIT=6,FMT='('' Perfect gas = '',e13.7)') R + WRITE(UNIT=6,FMT='('' Dry air mass = '',e13.7)') RMD + WRITE(UNIT=6,FMT='('' Ozone mass = '',e13.7)') RMO3 + WRITE(UNIT=6,FMT='('' Vapour mass = '',e13.7)') RMV + WRITE(UNIT=6,FMT='('' Dry air cst. = '',e13.7)') RD + WRITE(UNIT=6,FMT='('' Vapour cst. = '',e13.7)') RV + WRITE(UNIT=6,FMT='('' Cpd = '',e13.7)') RCPD + WRITE(UNIT=6,FMT='('' Cvd = '',e13.7)') RCVD + WRITE(UNIT=6,FMT='('' Cpv = '',e13.7)') RCPV + WRITE(UNIT=6,FMT='('' Cvv = '',e13.7)') RCVV + WRITE(UNIT=6,FMT='('' Rd/Cpd = '',e13.7)') RKAPPA + WRITE(UNIT=6,FMT='('' Rv/Rd-1 = '',e13.7)') RETV +C +C ---------------------------------------------------------------- +C +C* 6. DEFINE THERMODYNAMIC CONSTANTS, LIQUID PHASE. +C --------------------------------------------- +C + RCW=RCPV + WRITE(UNIT=6,FMT='('' *** Thermodynamic, liquid ***'')') + WRITE(UNIT=6,FMT='('' Cw = '',E13.7)') RCW +C +C ---------------------------------------------------------------- +C +C* 7. DEFINE THERMODYNAMIC CONSTANTS, SOLID PHASE. +C -------------------------------------------- +C + RCS=RCPV + WRITE(UNIT=6,FMT='('' *** thermodynamic, solid ***'')') + WRITE(UNIT=6,FMT='('' Cs = '',E13.7)') RCS +C +C ---------------------------------------------------------------- +C +C* 8. DEFINE THERMODYNAMIC CONSTANTS, TRANSITION OF PHASE. +C ---------------------------------------------------- +C + RTT=273.16 + RLVTT=2.5008E+6 + RLSTT=2.8345E+6 + RLMLT=RLSTT-RLVTT + RATM=100000. + WRITE(UNIT=6,FMT='('' *** Thermodynamic, trans. ***'')') + WRITE(UNIT=6,FMT='('' Fusion point = '',E13.7)') RTT + WRITE(UNIT=6,FMT='('' RLvTt = '',E13.7)') RLVTT + WRITE(UNIT=6,FMT='('' RLsTt = '',E13.7)') RLSTT + WRITE(UNIT=6,FMT='('' RLMlt = '',E13.7)') RLMLT + WRITE(UNIT=6,FMT='('' Normal press. = '',E13.7)') RATM + WRITE(UNIT=6,FMT='('' Latent heat : '')') +C +C ---------------------------------------------------------------- +C +C* 9. SATURATED VAPOUR PRESSURE. +C -------------------------- +C + RESTT=611.14 + RGAMW=(RCW-RCPV)/RV + RBETW=RLVTT/RV+RGAMW*RTT + RALPW=LOG(RESTT)+RBETW/RTT+RGAMW*LOG(RTT) + RGAMS=(RCS-RCPV)/RV + RBETS=RLSTT/RV+RGAMS*RTT + RALPS=LOG(RESTT)+RBETS/RTT+RGAMS*LOG(RTT) + RGAMD=RGAMS-RGAMW + RBETD=RBETS-RBETW + RALPD=RALPS-RALPW +C +C ------------------------------------------------------------------ +c +c calculer les constantes pour les fonctions thermodynamiques +c + RVTMP2=RCPV/RCPD-1. + RHOH2O=RATM/100. + R2ES=RESTT*RD/RV + R3LES=17.269 + R3IES=21.875 + R4LES=35.86 + R4IES=7.66 + R5LES=R3LES*(RTT-R4LES) + R5IES=R3IES*(RTT-R4IES) +C + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_land_bucket_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_land_bucket_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_land_bucket_mod.F90 (revision 1280) @@ -0,0 +1,175 @@ +! +MODULE surf_land_bucket_mod +! +! Surface land bucket module +! +! This module is used when no external land model is choosen. +! + IMPLICIT NONE + +CONTAINS + + SUBROUTINE surf_land_bucket(itime, jour, knon, knindex, debut, dtime,& + tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, & + spechum, petAcoef, peqAcoef, petBcoef, peqBcoef, pref, & + u1, v1, rugoro, swnet, lwnet, & + snow, qsol, agesno, tsoil, & + qsurf, z0_new, alb1_new, alb2_new, evap, & + fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l) + + USE limit_read_mod + USE surface_data + USE fonte_neige_mod + USE calcul_fluxs_mod + USE cpl_mod + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para +!**************************************************************************************** +! Bucket calculations for surface. +! + INCLUDE "clesphys.h" + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + INCLUDE "YOMCST.h" + +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + LOGICAL, INTENT(IN) :: debut + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: tsurf + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: tq_cdrag + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: petAcoef, peqAcoef + REAL, DIMENSION(klon), INTENT(IN) :: petBcoef, peqBcoef + REAL, DIMENSION(klon), INTENT(IN) :: pref + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + REAL, DIMENSION(klon), INTENT(IN) :: rugoro + REAL, DIMENSION(klon), INTENT(IN) :: swnet, lwnet + +! In/Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow, qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil + +! Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: z0_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new, alb2_new + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + +! Local variables +!**************************************************************************************** + REAL, DIMENSION(klon) :: soilcap, soilflux + REAL, DIMENSION(klon) :: cal, beta, dif_grnd, capsol + REAL, DIMENSION(klon) :: alb_neig, alb_lim + REAL, DIMENSION(klon) :: zfra + REAL, DIMENSION(klon) :: radsol ! total net radiance at surface + REAL, DIMENSION(klon) :: u0, v0, u1_lay, v1_lay + REAL, DIMENSION(klon) :: dummy_riverflow,dummy_coastalflow + INTEGER :: i +! +!**************************************************************************************** + + +! +!* Read from limit.nc : albedo(alb_lim), length of rugosity(z0_new) +! + CALL limit_read_rug_alb(itime, dtime, jour,& + knon, knindex, & + z0_new, alb_lim) +! +!* Calcultaion of fluxes +! + +! calculate total absorbed radiance at surface + radsol(:) = 0.0 + radsol(1:knon) = swnet(1:knon) + lwnet(1:knon) + +! calculate constants + CALL calbeta(dtime, is_ter, knon, snow, qsol, beta, capsol, dif_grnd) + +! calculate temperature, heat capacity and conduction flux in soil + IF (soil_model) THEN + CALL soil(dtime, is_ter, knon, snow, tsurf, tsoil, soilcap, soilflux) + DO i=1, knon + cal(i) = RCPD / soilcap(i) + radsol(i) = radsol(i) + soilflux(i) + END DO + ELSE + cal(:) = RCPD * capsol(:) + ENDIF + +! Suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + u1_lay(:) = u1(:) - u0(:) + v1_lay(:) = v1(:) - v0(:) + + CALL calcul_fluxs(knon, is_ter, dtime, & + tsurf, p1lay, cal, beta, tq_cdrag, pref, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, & + petAcoef, peqAcoef, petBcoef, peqBcoef, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + +! +!* Calculate snow height, run_off, age of snow +! + CALL fonte_neige( knon, is_ter, knindex, dtime, & + tsurf, precip_rain, precip_snow, & + snow, qsol, tsurf_new, evap) +! +!* Calculate the age of snow +! + CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:)) + + WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0. + + DO i=1, knon + zfra(i) = MAX(0.0,MIN(1.0, snow(i)/(snow(i)+10.0))) + alb_lim(i) = alb_neig(i) *zfra(i) + alb_lim(i)*(1.0-zfra(i)) + END DO + +! +!* Return albedo : +! alb1_new and alb2_new are here given the same values +! + alb1_new(:) = 0.0 + alb2_new(:) = 0.0 + alb1_new(1:knon) = alb_lim(1:knon) + alb2_new(1:knon) = alb_lim(1:knon) + +! +!* Calculate the rugosity +! + DO i = 1, knon + z0_new(i) = MAX(1.5e-05,SQRT(z0_new(i)**2 + rugoro(i)**2)) + END DO + +!* Send to coupler +! The run-off from river and coast are not calculated in the bucket modele. +! For testing purpose of the coupled modele we put the run-off to zero. + IF (type_ocean=='couple') THEN + dummy_riverflow(:) = 0.0 + dummy_coastalflow(:) = 0.0 + CALL cpl_send_land_fields(itime, knon, knindex, & + dummy_riverflow, dummy_coastalflow) + ENDIF + +! +!* End +! + END SUBROUTINE surf_land_bucket +! +!**************************************************************************************** +! +END MODULE surf_land_bucket_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_land_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_land_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_land_mod.F90 (revision 1280) @@ -0,0 +1,178 @@ +! +MODULE surf_land_mod + + IMPLICIT NONE + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE surf_land(itime, dtime, date0, jour, knon, knindex, & + rlon, rlat, & + debut, lafin, zlev, ccanopy, swnet, lwnet, albedo, & + tsurf, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + pref, u1, v1, rugoro, pctsrf, & + lwdown_m, q2m, t2m, & + snow, qsol, agesno, tsoil, & + z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, & + qsurf, tsurf_new, dflux_s, dflux_l, & + flux_u1, flux_v1 ) + + USE dimphy + USE surface_data, ONLY : ok_veget + +#ifdef ORCHIDEE_NOOPENMP + USE surf_land_orchidee_noopenmp_mod +#else + USE surf_land_orchidee_mod +#endif + USE surf_land_bucket_mod + USE calcul_fluxs_mod + + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + INCLUDE "YOMCST.h" + +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: date0 + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + LOGICAL, INTENT(IN) :: debut, lafin + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: zlev, ccanopy + REAL, DIMENSION(klon), INTENT(IN) :: swnet, lwnet + REAL, DIMENSION(klon), INTENT(IN) :: albedo ! albedo for whole short-wave interval + REAL, DIMENSION(klon), INTENT(IN) :: tsurf + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: pref ! pressure reference + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + REAL, DIMENSION(klon), INTENT(IN) :: rugoro + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + REAL, DIMENSION(klon), INTENT(IN) :: lwdown_m ! downwelling longwave radiation at mean surface + ! corresponds to previous sollwdown + REAL, DIMENSION(klon), INTENT(IN) :: q2m, t2m + +! In/Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow, qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil + +! Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: z0_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new ! albdeo for shortwave interval 1(visible) + REAL, DIMENSION(klon), INTENT(OUT) :: alb2_new ! albedo for shortwave interval 2(near infrared) + REAL, DIMENSION(klon), INTENT(OUT) :: evap + REAL, DIMENSION(klon), INTENT(OUT) :: fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 ! flux for U and V at first model level + +! Local variables +!**************************************************************************************** + REAL, DIMENSION(klon) :: p1lay_tmp + REAL, DIMENSION(klon) :: pref_tmp + REAL, DIMENSION(klon) :: swdown ! downwelling shortwave radiation at land surface + REAL, DIMENSION(klon) :: lwdown ! downwelling longwave radiation at land surface + REAL, DIMENSION(klon) :: epot_air ! potential air temperature + REAL, DIMENSION(klon) :: tsol_rad, emis_new ! output from interfsol not used + REAL, DIMENSION(klon) :: u0, v0 ! surface speed + INTEGER :: i + + +!**************************************************************************************** +! Choice between call to vegetation model (ok_veget=true) or simple calculation below +! +!**************************************************************************************** + IF (ok_veget) THEN +!**************************************************************************************** +! Call model sechiba in model ORCHIDEE +! +!**************************************************************************************** + p1lay_tmp(:) = 0.0 + pref_tmp(:) = 0.0 + p1lay_tmp(1:knon) = p1lay(1:knon)/100. + pref_tmp(1:knon) = pref(1:knon)/100. +! +!* Calculate incoming flux for SW and LW interval: swdown, lwdown +! + swdown(:) = 0.0 + lwdown(:) = 0.0 + DO i = 1, knon + swdown(i) = swnet(i)/(1-albedo(i)) + lwdown(i) = lwnet(i) + RSIGMA*tsurf(i)**4 + END DO +! +!* Calculate potential air temperature +! + epot_air(:) = 0.0 + DO i = 1, knon + epot_air(i) = RCPD*temp_air(i)*(pref(i)/p1lay(i))**RKAPPA + END DO + + ! temporary for keeping same results using lwdown_m instead of lwdown + CALL surf_land_orchidee(itime, dtime, date0, knon, & + knindex, rlon, rlat, pctsrf, & + debut, lafin, & + zlev, u1, v1, temp_air, spechum, epot_air, ccanopy, & + cdragh, AcoefH, AcoefQ, BcoefH, BcoefQ, & + precip_rain, precip_snow, lwdown_m, swnet, swdown, & + pref_tmp, q2m, t2m, & + evap, fluxsens, fluxlat, & + tsol_rad, tsurf_new, alb1_new, alb2_new, & + emis_new, z0_new, qsurf) + +! +!* Add contribution of relief to surface roughness +! + DO i=1,knon + z0_new(i) = MAX(1.5e-05,SQRT(z0_new(i)**2 + rugoro(i)**2)) + ENDDO + + ELSE ! not ok_veget +!**************************************************************************************** +! No extern vegetation model choosen, call simple bucket calculations instead. +! +!**************************************************************************************** + CALL surf_land_bucket(itime, jour, knon, knindex, debut, dtime,& + tsurf, p1lay, cdragh, precip_rain, precip_snow, temp_air, & + spechum, AcoefH, AcoefQ, BcoefH, BcoefQ, pref, & + u1, v1, rugoro, swnet, lwnet, & + snow, qsol, agesno, tsoil, & + qsurf, z0_new, alb1_new, alb2_new, evap, & + fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l) + + ENDIF ! ok_veget + +!**************************************************************************************** +! Calculation for all land models +! - Flux calculation at first modele level for U and V +!**************************************************************************************** +! Suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + CALL calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + + END SUBROUTINE surf_land +! +!**************************************************************************************** +! +END MODULE surf_land_mod +! +!**************************************************************************************** +! Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_land_orchidee_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_land_orchidee_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_land_orchidee_mod.F90 (revision 1280) @@ -0,0 +1,675 @@ +! +MODULE surf_land_orchidee_mod +#ifndef ORCHIDEE_NOOPENMP +! +! This module controles the interface towards the model ORCHIDEE +! +! Subroutines in this module : surf_land_orchidee +! Init_orchidee_index +! Get_orchidee_communicator +! Init_neighbours + + USE dimphy +#ifdef CPP_VEGET + USE intersurf ! module d'ORCHIDEE +#endif + USE cpl_mod, ONLY : cpl_send_land_fields + USE surface_data, ONLY : type_ocean + USE comgeomphy, ONLY : cuphy, cvphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para, mpi_root_rank=>mpi_root + + IMPLICIT NONE + + PRIVATE + PUBLIC :: surf_land_orchidee + + LOGICAL, ALLOCATABLE, SAVE :: flag_omp(:) +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE surf_land_orchidee(itime, dtime, date0, knon, & + knindex, rlon, rlat, pctsrf, & + debut, lafin, & + plev, u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & + tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, & + precip_rain, precip_snow, lwdown, swnet, swdown, & + ps, q2m, t2m, & + evap, fluxsens, fluxlat, & + tsol_rad, tsurf_new, alb1_new, alb2_new, & + emis_new, z0_new, qsurf) + + USE mod_surf_para + USE mod_synchro_omp + +USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, fco2_land_inst, fco2_lu_inst + +! +! Cette routine sert d'interface entre le modele atmospherique et le +! modele de sol continental. Appel a sechiba +! +! L. Fairhead 02/2000 +! +! input: +! itime numero du pas de temps +! dtime pas de temps de la physique (en s) +! nisurf index de la surface a traiter (1 = sol continental) +! knon nombre de points de la surface a traiter +! knindex index des points de la surface a traiter +! rlon longitudes de la grille entiere +! rlat latitudes de la grille entiere +! pctsrf tableau des fractions de surface de chaque maille +! debut logical: 1er appel a la physique (lire les restart) +! lafin logical: dernier appel a la physique (ecrire les restart) +! (si false calcul simplifie des fluxs sur les continents) +! plev hauteur de la premiere couche (Pa) +! u1_lay vitesse u 1ere couche +! v1_lay vitesse v 1ere couche +! temp_air temperature de l'air 1ere couche +! spechum humidite specifique 1ere couche +! epot_air temp pot de l'air +! ccanopy concentration CO2 canopee, correspond au co2_send de +! carbon_cycle_mod ou valeur constant co2_ppm +! tq_cdrag cdrag +! petAcoef coeff. A de la resolution de la CL pour t +! peqAcoef coeff. A de la resolution de la CL pour q +! petBcoef coeff. B de la resolution de la CL pour t +! peqBcoef coeff. B de la resolution de la CL pour q +! precip_rain precipitation liquide +! precip_snow precipitation solide +! lwdown flux IR descendant a la surface +! swnet flux solaire net +! swdown flux solaire entrant a la surface +! ps pression au sol +! radsol rayonnement net aus sol (LW + SW) +! +! +! output: +! evap evaporation totale +! fluxsens flux de chaleur sensible +! fluxlat flux de chaleur latente +! tsol_rad +! tsurf_new temperature au sol +! alb1_new albedo in visible SW interval +! alb2_new albedo in near IR interval +! emis_new emissivite +! z0_new surface roughness +! qsurf air moisture at surface +! + INCLUDE "indicesol.h" + INCLUDE "temps.h" + INCLUDE "YOMCST.h" + INCLUDE "iniprint.h" + INCLUDE "dimensions.h" + +! +! Parametres d'entree +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime + REAL, INTENT(IN) :: dtime + REAL, INTENT(IN) :: date0 + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + LOGICAL, INTENT(IN) :: debut, lafin + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(IN) :: plev + REAL, DIMENSION(klon), INTENT(IN) :: u1_lay, v1_lay + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: epot_air, ccanopy + REAL, DIMENSION(klon), INTENT(IN) :: tq_cdrag + REAL, DIMENSION(klon), INTENT(IN) :: petAcoef, peqAcoef + REAL, DIMENSION(klon), INTENT(IN) :: petBcoef, peqBcoef + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: lwdown, swnet, swdown, ps + REAL, DIMENSION(klon), INTENT(IN) :: q2m, t2m + +! Parametres de sortie +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat, qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: tsol_rad, tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new, alb2_new + REAL, DIMENSION(klon), INTENT(OUT) :: emis_new, z0_new + +! Local +!**************************************************************************************** + INTEGER :: ij, jj, igrid, ireal, index + INTEGER :: error + REAL, DIMENSION(klon) :: swdown_vrai + REAL, DIMENSION(klon) :: fco2_land_comp ! sur grille compresse + REAL, DIMENSION(klon) :: fco2_lu_comp ! sur grille compresse + CHARACTER (len = 20) :: modname = 'surf_land_orchidee' + CHARACTER (len = 80) :: abort_message + LOGICAL,SAVE :: check = .FALSE. + !$OMP THREADPRIVATE(check) + +! type de couplage dans sechiba +! character (len=10) :: coupling = 'implicit' +! drapeaux controlant les appels dans SECHIBA +! type(control_type), save :: control_in +! Preserved albedo + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: albedo_keep, zlev + !$OMP THREADPRIVATE(albedo_keep,zlev) +! coordonnees geographiques + REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: lalo + !$OMP THREADPRIVATE(lalo) +! pts voisins + INTEGER,ALLOCATABLE, DIMENSION(:,:), SAVE :: neighbours + !$OMP THREADPRIVATE(neighbours) +! fractions continents + REAL,ALLOCATABLE, DIMENSION(:), SAVE :: contfrac + !$OMP THREADPRIVATE(contfrac) +! resolution de la grille + REAL, ALLOCATABLE, DIMENSION (:,:), SAVE :: resolution + !$OMP THREADPRIVATE(resolution) + + REAL, ALLOCATABLE, DIMENSION (:,:), SAVE :: lon_scat, lat_scat + !$OMP THREADPRIVATE(lon_scat,lat_scat) + + LOGICAL, SAVE :: lrestart_read = .TRUE. + !$OMP THREADPRIVATE(lrestart_read) + LOGICAL, SAVE :: lrestart_write = .FALSE. + !$OMP THREADPRIVATE(lrestart_write) + + REAL, DIMENSION(knon,2) :: albedo_out + +! Pb de nomenclature + REAL, DIMENSION(klon) :: petA_orc, peqA_orc + REAL, DIMENSION(klon) :: petB_orc, peqB_orc +! Pb de correspondances de grilles + INTEGER, DIMENSION(:), SAVE, ALLOCATABLE :: ig, jg + !$OMP THREADPRIVATE(ig,jg) + INTEGER :: indi, indj + INTEGER, SAVE, ALLOCATABLE,DIMENSION(:) :: ktindex + !$OMP THREADPRIVATE(ktindex) + +! Essai cdrag + REAL, DIMENSION(klon) :: cdrag + INTEGER,SAVE :: offset + !$OMP THREADPRIVATE(offset) + + REAL, DIMENSION(klon_glo) :: rlon_g,rlat_g + INTEGER, SAVE :: orch_comm + !$OMP THREADPRIVATE(orch_comm) + + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: coastalflow + !$OMP THREADPRIVATE(coastalflow) + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: riverflow + !$OMP THREADPRIVATE(riverflow) + + INTEGER :: orch_omp_rank + INTEGER :: orch_omp_size +! +! Fin definition +!**************************************************************************************** + + IF (check) WRITE(lunout,*)'Entree ', modname + +! Initialisation + + IF (debut) THEN +! Test of coherence between variable ok_veget and cpp key CPP_VEGET +#ifndef CPP_VEGET + abort_message='Pb de coherence: ok_veget = .true. mais CPP_VEGET = .false.' + CALL abort_gcm(modname,abort_message,1) +#endif + + CALL Init_surf_para(knon) + ALLOCATE(ktindex(knon)) + IF ( .NOT. ALLOCATED(albedo_keep)) THEN +!ym ALLOCATE(albedo_keep(klon)) +!ym bizarre que non alloué en knon precedement + ALLOCATE(albedo_keep(knon)) + ALLOCATE(zlev(knon)) + ENDIF +! Pb de correspondances de grilles + ALLOCATE(ig(klon)) + ALLOCATE(jg(klon)) + ig(1) = 1 + jg(1) = 1 + indi = 0 + indj = 2 + DO igrid = 2, klon - 1 + indi = indi + 1 + IF ( indi > iim) THEN + indi = 1 + indj = indj + 1 + ENDIF + ig(igrid) = indi + jg(igrid) = indj + ENDDO + ig(klon) = 1 + jg(klon) = jjm + 1 + + IF ((.NOT. ALLOCATED(lalo))) THEN + ALLOCATE(lalo(knon,2), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lalo' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + IF ((.NOT. ALLOCATED(lon_scat))) THEN + ALLOCATE(lon_scat(iim,jjm+1), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lon_scat' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + IF ((.NOT. ALLOCATED(lat_scat))) THEN + ALLOCATE(lat_scat(iim,jjm+1), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lat_scat' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + lon_scat = 0. + lat_scat = 0. + DO igrid = 1, knon + index = knindex(igrid) + lalo(igrid,2) = rlon(index) + lalo(igrid,1) = rlat(index) + ENDDO + + + + CALL Gather(rlon,rlon_g) + CALL Gather(rlat,rlat_g) + + IF (is_mpi_root) THEN + index = 1 + DO jj = 2, jjm + DO ij = 1, iim + index = index + 1 + lon_scat(ij,jj) = rlon_g(index) + lat_scat(ij,jj) = rlat_g(index) + ENDDO + ENDDO + lon_scat(:,1) = lon_scat(:,2) + lat_scat(:,1) = rlat_g(1) + lon_scat(:,jjm+1) = lon_scat(:,2) + lat_scat(:,jjm+1) = rlat_g(klon_glo) + ENDIF + + CALL bcast(lon_scat) + CALL bcast(lat_scat) +! +! Allouer et initialiser le tableau des voisins et des fraction de continents +! + IF ( (.NOT.ALLOCATED(neighbours))) THEN + ALLOCATE(neighbours(knon,8), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation neighbours' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + neighbours = -1. + IF (( .NOT. ALLOCATED(contfrac))) THEN + ALLOCATE(contfrac(knon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation contfrac' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + + DO igrid = 1, knon + ireal = knindex(igrid) + contfrac(igrid) = pctsrf(ireal,is_ter) + ENDDO + + + CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter)) + +! +! Allocation et calcul resolutions + IF ( (.NOT.ALLOCATED(resolution))) THEN + ALLOCATE(resolution(knon,2), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation resolution' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + DO igrid = 1, knon + ij = knindex(igrid) + resolution(igrid,1) = cuphy(ij) + resolution(igrid,2) = cvphy(ij) + ENDDO + + ALLOCATE(coastalflow(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation coastalflow' + CALL abort_gcm(modname,abort_message,1) + ENDIF + + ALLOCATE(riverflow(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation riverflow' + CALL abort_gcm(modname,abort_message,1) + ENDIF +! +! Allocate variables needed for carbon_cycle_mod +! + IF (carbon_cycle_cpl) THEN + IF (.NOT. ALLOCATED(fco2_land_inst)) THEN + ALLOCATE(fco2_land_inst(klon),stat=error) + IF (error /= 0) CALL abort_gcm(modname,'Pb in allocation fco2_land_inst',1) + + ALLOCATE(fco2_lu_inst(klon),stat=error) + IF(error /=0) CALL abort_gcm(modname,'Pb in allocation fco2_lu_inst',1) + END IF + END IF + + ENDIF ! (fin debut) + + +! +! Appel a la routine sols continentaux +! + IF (lafin) lrestart_write = .TRUE. + IF (check) WRITE(lunout,*)'lafin ',lafin,lrestart_write + + petA_orc(1:knon) = petBcoef(1:knon) * dtime + petB_orc(1:knon) = petAcoef(1:knon) + peqA_orc(1:knon) = peqBcoef(1:knon) * dtime + peqB_orc(1:knon) = peqAcoef(1:knon) + + cdrag = 0. + cdrag(1:knon) = tq_cdrag(1:knon) + +! zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/287.05*temp_air(1:knon))*9.80665) + zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/RD*temp_air(1:knon))*RG) + + +! PF et PASB +! where(cdrag > 0.01) +! cdrag = 0.01 +! endwhere +! write(*,*)'Cdrag = ',minval(cdrag),maxval(cdrag) + + + IF (debut) THEN + CALL Init_orchidee_index(knon,knindex,offset,ktindex) + CALL Get_orchidee_communicator(orch_comm,orch_omp_size,orch_omp_rank) + CALL Init_synchro_omp + + IF (knon > 0) THEN +#ifdef CPP_VEGET + CALL Init_intersurf(nbp_lon,nbp_lat,knon,ktindex,offset,orch_omp_size,orch_omp_rank,orch_comm) +#endif + ENDIF + + + IF (knon > 0) THEN + +#ifdef CPP_VEGET + CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, knon, ktindex, dtime, & + lrestart_read, lrestart_write, lalo, & + contfrac, neighbours, resolution, date0, & + zlev, u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, & + cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, & + precip_rain, precip_snow, lwdown, swnet, swdown, ps, & + evap, fluxsens, fluxlat, coastalflow, riverflow, & + tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, & + lon_scat, lat_scat, q2m, t2m) +#endif + ENDIF + + CALL Synchro_omp + + albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2. + + ENDIF + + +! swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon)) + swdown_vrai(1:knon) = swdown(1:knon) + + IF (knon > 0) THEN +#ifdef CPP_VEGET + CALL intersurf_main (itime+itau_phy, iim, jjm+1, knon, ktindex, dtime, & + lrestart_read, lrestart_write, lalo, & + contfrac, neighbours, resolution, date0, & + zlev, u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), & + cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), & + precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown_vrai(1:knon), ps(1:knon), & + evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), & + tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), & + lon_scat, lat_scat, q2m, t2m) +#endif + ENDIF + + CALL Synchro_omp + + albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2. + +!* Send to coupler +! + IF (type_ocean=='couple') THEN + CALL cpl_send_land_fields(itime, knon, knindex, & + riverflow, coastalflow) + ENDIF + + alb1_new(1:knon) = albedo_out(1:knon,1) + alb2_new(1:knon) = albedo_out(1:knon,2) + +! Convention orchidee: positif vers le haut + fluxsens(1:knon) = -1. * fluxsens(1:knon) + fluxlat(1:knon) = -1. * fluxlat(1:knon) + +! evap = -1. * evap + + IF (debut) lrestart_read = .FALSE. + + IF (debut) CALL Finalize_surf_para + + +! JG : TEMPORAIRE!!!! Les variables fco2_land_comp et fco2_lu_comp seront plus tard en sortie d'ORCHIDEE +! ici mis a valeur quelquonque pour test. Ces variables sont sur la grille compresse avec uniquement des points de terres + + fco2_land_comp(:) = 1. + fco2_lu_comp(:) = 10. + +! Decompress variables for the module carbon_cycle_mod + IF (carbon_cycle_cpl) THEN + fco2_land_inst(:)=0. + fco2_lu_inst(:)=0. + + DO igrid = 1, knon + ireal = knindex(igrid) + fco2_land_inst(ireal) = fco2_land_comp(igrid) + fco2_lu_inst(ireal) = fco2_lu_comp(igrid) + END DO + END IF + + END SUBROUTINE surf_land_orchidee +! +!**************************************************************************************** +! + SUBROUTINE Init_orchidee_index(knon,knindex,offset,ktindex) + USE mod_surf_para + USE mod_grid_phy_lmdz + + INTEGER,INTENT(IN) :: knon + INTEGER,INTENT(IN) :: knindex(klon) + INTEGER,INTENT(OUT) :: offset + INTEGER,INTENT(OUT) :: ktindex(klon) + + INTEGER :: ktindex_glo(knon_glo) + INTEGER :: offset_para(0:omp_size*mpi_size-1) + INTEGER :: LastPoint + INTEGER :: task + + ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin-1)+(klon_omp_begin-1)+nbp_lon-1 + + CALL gather_surf(ktindex(1:knon),ktindex_glo) + + IF (is_mpi_root .AND. is_omp_root) THEN + LastPoint=0 + DO Task=0,mpi_size*omp_size-1 + IF (knon_glo_para(Task)>0) THEN + offset_para(task)= LastPoint-MOD(LastPoint,nbp_lon) + LastPoint=ktindex_glo(knon_glo_end_para(task)) + ENDIF + ENDDO + ENDIF + + CALL bcast(offset_para) + + offset=offset_para(omp_size*mpi_rank+omp_rank) + + ktindex(1:knon)=ktindex(1:knon)-offset + + END SUBROUTINE Init_orchidee_index + +! +!************************* *************************************************************** +! + + SUBROUTINE Get_orchidee_communicator(orch_comm,orch_omp_size,orch_omp_rank) + USE mod_surf_para + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + INTEGER,INTENT(OUT) :: orch_comm + INTEGER,INTENT(OUT) :: orch_omp_size + INTEGER,INTENT(OUT) :: orch_omp_rank + INTEGER :: color + INTEGER :: i,ierr +! +! End definition +!**************************************************************************************** + + + IF (is_omp_root) THEN + + IF (knon_mpi==0) THEN + color = 0 + ELSE + color = 1 + ENDIF + +#ifdef CPP_MPI + CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr) +#endif + + ENDIF + CALL bcast_omp(orch_comm) + + IF (knon_mpi /= 0) THEN + orch_omp_size=0 + DO i=0,omp_size-1 + IF (knon_omp_para(i) /=0) THEN + orch_omp_size=orch_omp_size+1 + IF (i==omp_rank) orch_omp_rank=orch_omp_size-1 + ENDIF + ENDDO + ENDIF + + + END SUBROUTINE Get_orchidee_communicator +! +!**************************************************************************************** +! + + SUBROUTINE Init_neighbours(knon,neighbours,knindex,pctsrf) + USE mod_grid_phy_lmdz + USE mod_surf_para + INCLUDE "indicesol.h" + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, DIMENSION(klon), INTENT(IN) :: pctsrf + +! Output arguments +!**************************************************************************************** + INTEGER, DIMENSION(knon,8), INTENT(OUT) :: neighbours + +! Local variables +!**************************************************************************************** + INTEGER :: i, igrid, jj, ij, iglob + INTEGER :: ierr, ireal, index + INTEGER, DIMENSION(8,3) :: off_ini + INTEGER, DIMENSION(8) :: offset + INTEGER, DIMENSION(nbp_lon,nbp_lat) :: correspond + INTEGER, DIMENSION(knon_glo) :: ktindex_glo + INTEGER, DIMENSION(knon_glo,8) :: neighbours_glo + REAL, DIMENSION(klon_glo) :: pctsrf_glo + INTEGER :: ktindex(klon) +! +! End definition +!**************************************************************************************** + + ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin-1)+(klon_omp_begin-1)+nbp_lon-1 + + CALL gather_surf(ktindex(1:knon),ktindex_glo) + CALL gather(pctsrf,pctsrf_glo) + + IF (is_mpi_root .AND. is_omp_root) THEN + neighbours_glo(:,:)=-1 +! Initialisation des offset +! +! offset bord ouest + off_ini(1,1) = - nbp_lon ; off_ini(2,1) = - nbp_lon + 1 ; off_ini(3,1) = 1 + off_ini(4,1) = nbp_lon + 1 ; off_ini(5,1) = nbp_lon ; off_ini(6,1) = 2 * nbp_lon - 1 + off_ini(7,1) = nbp_lon -1 ; off_ini(8,1) = - 1 +! offset point normal + off_ini(1,2) = - nbp_lon ; off_ini(2,2) = - nbp_lon + 1 ; off_ini(3,2) = 1 + off_ini(4,2) = nbp_lon + 1 ; off_ini(5,2) = nbp_lon ; off_ini(6,2) = nbp_lon - 1 + off_ini(7,2) = -1 ; off_ini(8,2) = - nbp_lon - 1 +! offset bord est + off_ini(1,3) = - nbp_lon ; off_ini(2,3) = - 2 * nbp_lon + 1 ; off_ini(3,3) = - nbp_lon + 1 + off_ini(4,3) = 1 ; off_ini(5,3) = nbp_lon ; off_ini(6,3) = nbp_lon - 1 + off_ini(7,3) = -1 ; off_ini(8,3) = - nbp_lon - 1 +! +! +! Attention aux poles +! + DO igrid = 1, knon_glo + index = ktindex_glo(igrid) + jj = INT((index - 1)/nbp_lon) + 1 + ij = index - (jj - 1) * nbp_lon + correspond(ij,jj) = igrid + ENDDO + + DO igrid = 1, knon_glo + iglob = ktindex_glo(igrid) + + IF (MOD(iglob, nbp_lon) == 1) THEN + offset = off_ini(:,1) + ELSE IF(MOD(iglob, nbp_lon) == 0) THEN + offset = off_ini(:,3) + ELSE + offset = off_ini(:,2) + ENDIF + + DO i = 1, 8 + index = iglob + offset(i) + ireal = (MIN(MAX(1, index - nbp_lon + 1), klon_glo)) + IF (pctsrf_glo(ireal) > EPSFRA) THEN + jj = INT((index - 1)/nbp_lon) + 1 + ij = index - (jj - 1) * nbp_lon + neighbours_glo(igrid, i) = correspond(ij, jj) + ENDIF + ENDDO + ENDDO + + ENDIF + + DO i = 1, 8 + CALL scatter_surf(neighbours_glo(:,i),neighbours(1:knon,i)) + ENDDO + END SUBROUTINE Init_neighbours + +! +!**************************************************************************************** +! +#endif +END MODULE surf_land_orchidee_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_land_orchidee_noopenmp_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_land_orchidee_noopenmp_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_land_orchidee_noopenmp_mod.F90 (revision 1280) @@ -0,0 +1,748 @@ +! +! $Header$ +! +MODULE surf_land_orchidee_noopenmp_mod +! +! This module is compiled only if CPP key ORCHIDEE_NOOPENMP is defined. +! This module should be used with ORCHIDEE sequentiel or parallele MPI version (not MPI-OpenMP mixte) + +#ifdef ORCHIDEE_NOOPENMP +! +! This module controles the interface towards the model ORCHIDEE +! +! Subroutines in this module : surf_land_orchidee +! Init_orchidee_index +! Get_orchidee_communicator +! Init_neighbours + USE dimphy +#ifdef CPP_VEGET + USE intersurf ! module d'ORCHIDEE +#endif + USE cpl_mod, ONLY : cpl_send_land_fields + USE surface_data, ONLY : type_ocean + USE comgeomphy, ONLY : cuphy, cvphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + + IMPLICIT NONE + + PRIVATE + PUBLIC :: surf_land_orchidee + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE surf_land_orchidee(itime, dtime, date0, knon, & + knindex, rlon, rlat, pctsrf, & + debut, lafin, & + plev, u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & + tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, & + precip_rain, precip_snow, lwdown, swnet, swdown, & + ps, q2m, t2m, & + evap, fluxsens, fluxlat, & + tsol_rad, tsurf_new, alb1_new, alb2_new, & + emis_new, z0_new, qsurf) +! +! Cette routine sert d'interface entre le modele atmospherique et le +! modele de sol continental. Appel a sechiba +! +! L. Fairhead 02/2000 +! +! input: +! itime numero du pas de temps +! dtime pas de temps de la physique (en s) +! nisurf index de la surface a traiter (1 = sol continental) +! knon nombre de points de la surface a traiter +! knindex index des points de la surface a traiter +! rlon longitudes de la grille entiere +! rlat latitudes de la grille entiere +! pctsrf tableau des fractions de surface de chaque maille +! debut logical: 1er appel a la physique (lire les restart) +! lafin logical: dernier appel a la physique (ecrire les restart) +! (si false calcul simplifie des fluxs sur les continents) +! plev hauteur de la premiere couche (Pa) +! u1_lay vitesse u 1ere couche +! v1_lay vitesse v 1ere couche +! temp_air temperature de l'air 1ere couche +! spechum humidite specifique 1ere couche +! epot_air temp pot de l'air +! ccanopy concentration CO2 canopee, correspond au co2_send de +! carbon_cycle_mod ou valeur constant co2_ppm +! tq_cdrag cdrag +! petAcoef coeff. A de la resolution de la CL pour t +! peqAcoef coeff. A de la resolution de la CL pour q +! petBcoef coeff. B de la resolution de la CL pour t +! peqBcoef coeff. B de la resolution de la CL pour q +! precip_rain precipitation liquide +! precip_snow precipitation solide +! lwdown flux IR descendant a la surface +! swnet flux solaire net +! swdown flux solaire entrant a la surface +! ps pression au sol +! radsol rayonnement net aus sol (LW + SW) +! +! +! output: +! evap evaporation totale +! fluxsens flux de chaleur sensible +! fluxlat flux de chaleur latente +! tsol_rad +! tsurf_new temperature au sol +! alb1_new albedo in visible SW interval +! alb2_new albedo in near IR interval +! emis_new emissivite +! z0_new surface roughness +! qsurf air moisture at surface +! + USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, fco2_land_inst, fco2_lu_inst + IMPLICIT NONE + + INCLUDE "indicesol.h" + INCLUDE "temps.h" + INCLUDE "YOMCST.h" + INCLUDE "iniprint.h" + INCLUDE "dimensions.h" + +! +! Parametres d'entree +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime + REAL, INTENT(IN) :: dtime + REAL, INTENT(IN) :: date0 + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + LOGICAL, INTENT(IN) :: debut, lafin + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(IN) :: plev + REAL, DIMENSION(klon), INTENT(IN) :: u1_lay, v1_lay + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: epot_air, ccanopy + REAL, DIMENSION(klon), INTENT(IN) :: tq_cdrag + REAL, DIMENSION(klon), INTENT(IN) :: petAcoef, peqAcoef + REAL, DIMENSION(klon), INTENT(IN) :: petBcoef, peqBcoef + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: lwdown, swnet, swdown, ps + REAL, DIMENSION(klon), INTENT(IN) :: q2m, t2m + +! Parametres de sortie +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat, qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: tsol_rad, tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new, alb2_new + REAL, DIMENSION(klon), INTENT(OUT) :: emis_new, z0_new + +! Local +!**************************************************************************************** + INTEGER :: ij, jj, igrid, ireal, index + INTEGER :: error + REAL, DIMENSION(klon) :: swdown_vrai + REAL, DIMENSION(klon) :: fco2_land_comp ! sur grille compresse + REAL, DIMENSION(klon) :: fco2_lu_comp ! sur grille compresse + CHARACTER (len = 20) :: modname = 'surf_land_orchidee' + CHARACTER (len = 80) :: abort_message + LOGICAL,SAVE :: check = .FALSE. + !$OMP THREADPRIVATE(check) + +! type de couplage dans sechiba +! character (len=10) :: coupling = 'implicit' +! drapeaux controlant les appels dans SECHIBA +! type(control_type), save :: control_in +! Preserved albedo + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: albedo_keep, zlev + !$OMP THREADPRIVATE(albedo_keep,zlev) +! coordonnees geographiques + REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: lalo + !$OMP THREADPRIVATE(lalo) +! pts voisins + INTEGER,ALLOCATABLE, DIMENSION(:,:), SAVE :: neighbours + !$OMP THREADPRIVATE(neighbours) +! fractions continents + REAL,ALLOCATABLE, DIMENSION(:), SAVE :: contfrac + !$OMP THREADPRIVATE(contfrac) +! resolution de la grille + REAL, ALLOCATABLE, DIMENSION (:,:), SAVE :: resolution + !$OMP THREADPRIVATE(resolution) + + REAL, ALLOCATABLE, DIMENSION (:,:), SAVE :: lon_scat, lat_scat + !$OMP THREADPRIVATE(lon_scat,lat_scat) + + LOGICAL, SAVE :: lrestart_read = .TRUE. + !$OMP THREADPRIVATE(lrestart_read) + LOGICAL, SAVE :: lrestart_write = .FALSE. + !$OMP THREADPRIVATE(lrestart_write) + + REAL, DIMENSION(knon,2) :: albedo_out + !$OMP THREADPRIVATE(albedo_out) + +! Pb de nomenclature + REAL, DIMENSION(klon) :: petA_orc, peqA_orc + REAL, DIMENSION(klon) :: petB_orc, peqB_orc +! Pb de correspondances de grilles + INTEGER, DIMENSION(:), SAVE, ALLOCATABLE :: ig, jg + !$OMP THREADPRIVATE(ig,jg) + INTEGER :: indi, indj + INTEGER, SAVE, ALLOCATABLE,DIMENSION(:) :: ktindex + !$OMP THREADPRIVATE(ktindex) + +! Essai cdrag + REAL, DIMENSION(klon) :: cdrag + INTEGER,SAVE :: offset + !$OMP THREADPRIVATE(offset) + + REAL, DIMENSION(klon_glo) :: rlon_g,rlat_g + INTEGER, SAVE :: orch_comm + !$OMP THREADPRIVATE(orch_comm) + + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: coastalflow + !$OMP THREADPRIVATE(coastalflow) + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: riverflow + !$OMP THREADPRIVATE(riverflow) +! +! Fin definition +!**************************************************************************************** +#ifdef CPP_VEGET + + IF (check) WRITE(lunout,*)'Entree ', modname + +! Initialisation + + IF (debut) THEN + ALLOCATE(ktindex(knon)) + IF ( .NOT. ALLOCATED(albedo_keep)) THEN + ALLOCATE(albedo_keep(klon)) + ALLOCATE(zlev(knon)) + ENDIF +! Pb de correspondances de grilles + ALLOCATE(ig(klon)) + ALLOCATE(jg(klon)) + ig(1) = 1 + jg(1) = 1 + indi = 0 + indj = 2 + DO igrid = 2, klon - 1 + indi = indi + 1 + IF ( indi > iim) THEN + indi = 1 + indj = indj + 1 + ENDIF + ig(igrid) = indi + jg(igrid) = indj + ENDDO + ig(klon) = 1 + jg(klon) = jjm + 1 + + IF ((.NOT. ALLOCATED(lalo))) THEN + ALLOCATE(lalo(knon,2), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lalo' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + IF ((.NOT. ALLOCATED(lon_scat))) THEN + ALLOCATE(lon_scat(iim,jjm+1), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lon_scat' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + IF ((.NOT. ALLOCATED(lat_scat))) THEN + ALLOCATE(lat_scat(iim,jjm+1), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lat_scat' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + lon_scat = 0. + lat_scat = 0. + DO igrid = 1, knon + index = knindex(igrid) + lalo(igrid,2) = rlon(index) + lalo(igrid,1) = rlat(index) + ENDDO + + + + CALL Gather(rlon,rlon_g) + CALL Gather(rlat,rlat_g) + + IF (is_mpi_root) THEN + index = 1 + DO jj = 2, jjm + DO ij = 1, iim + index = index + 1 + lon_scat(ij,jj) = rlon_g(index) + lat_scat(ij,jj) = rlat_g(index) + ENDDO + ENDDO + lon_scat(:,1) = lon_scat(:,2) + lat_scat(:,1) = rlat_g(1) + lon_scat(:,jjm+1) = lon_scat(:,2) + lat_scat(:,jjm+1) = rlat_g(klon_glo) + ENDIF + + CALL bcast(lon_scat) + CALL bcast(lat_scat) + +! +! Allouer et initialiser le tableau des voisins et des fraction de continents +! + IF ( (.NOT.ALLOCATED(neighbours))) THEN + ALLOCATE(neighbours(knon,8), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation neighbours' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + neighbours = -1. + IF (( .NOT. ALLOCATED(contfrac))) THEN + ALLOCATE(contfrac(knon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation contfrac' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + + DO igrid = 1, knon + ireal = knindex(igrid) + contfrac(igrid) = pctsrf(ireal,is_ter) + ENDDO + + + CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter)) + +! +! Allocation et calcul resolutions + IF ( (.NOT.ALLOCATED(resolution))) THEN + ALLOCATE(resolution(knon,2), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation resolution' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + DO igrid = 1, knon + ij = knindex(igrid) + resolution(igrid,1) = cuphy(ij) + resolution(igrid,2) = cvphy(ij) + ENDDO + + ALLOCATE(coastalflow(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation coastalflow' + CALL abort_gcm(modname,abort_message,1) + ENDIF + + ALLOCATE(riverflow(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation riverflow' + CALL abort_gcm(modname,abort_message,1) + ENDIF + +! +! Allocate variables needed for carbon_cycle_mod +! + IF (carbon_cycle_cpl) THEN + IF (.NOT. ALLOCATED(fco2_land_inst)) THEN + ALLOCATE(fco2_land_inst(klon),stat=error) + IF (error /= 0) CALL abort_gcm(modname,'Pb in allocation fco2_land_inst',1) + + ALLOCATE(fco2_lu_inst(klon),stat=error) + IF(error /=0) CALL abort_gcm(modname,'Pb in allocation fco2_lu_inst',1) + END IF + END IF + + ENDIF ! (fin debut) + +! +! Appel a la routine sols continentaux +! + IF (lafin) lrestart_write = .TRUE. + IF (check) WRITE(lunout,*)'lafin ',lafin,lrestart_write + + petA_orc(1:knon) = petBcoef(1:knon) * dtime + petB_orc(1:knon) = petAcoef(1:knon) + peqA_orc(1:knon) = peqBcoef(1:knon) * dtime + peqB_orc(1:knon) = peqAcoef(1:knon) + + cdrag = 0. + cdrag(1:knon) = tq_cdrag(1:knon) + +! zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/287.05*temp_air(1:knon))*9.80665) + zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/RD*temp_air(1:knon))*RG) + + +! PF et PASB +! where(cdrag > 0.01) +! cdrag = 0.01 +! endwhere +! write(*,*)'Cdrag = ',minval(cdrag),maxval(cdrag) + +! +! Init Orchidee +! +! if (pole_nord) then +! offset=0 +! ktindex(:)=ktindex(:)+iim-1 +! else +! offset = klon_mpi_begin-1+iim-1 +! ktindex(:)=ktindex(:)+MOD(offset,iim) +! offset=offset-MOD(offset,iim) +! endif + + IF (debut) THEN + CALL Get_orchidee_communicator(knon,orch_comm) + IF (knon /=0) THEN + CALL Init_orchidee_index(knon,orch_comm,knindex,offset,ktindex) + +#ifndef CPP_MPI + ! Interface for ORCHIDEE compiled in sequential mode(without preprocessing flag CPP_MPI) + CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, knon, ktindex, dtime, & + lrestart_read, lrestart_write, lalo, & + contfrac, neighbours, resolution, date0, & + zlev, u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, & + cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, & + precip_rain, precip_snow, lwdown, swnet, swdown, ps, & + evap, fluxsens, fluxlat, coastalflow, riverflow, & + tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, & + lon_scat, lat_scat, q2m, t2m) + +#else + ! Interface for ORCHIDEE version 1.9 or later(1.9.2, 1.9.3, 1.9.4) compiled in parallel mode(with preprocessing flag CPP_MPI) + CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, offset, knon, ktindex, & + orch_comm, dtime, lrestart_read, lrestart_write, lalo, & + contfrac, neighbours, resolution, date0, & + zlev, u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), & + cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), & + precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown(1:knon), ps(1:knon), & + evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), & + tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), & + lon_scat, lat_scat, q2m, t2m) +#endif + + ENDIF + + albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2. + + ENDIF + +! swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon)) + swdown_vrai(1:knon) = swdown(1:knon) + + IF (knon /=0) THEN + +#ifndef CPP_MPI + ! Interface for ORCHIDEE compiled in sequential mode(without preprocessing flag CPP_MPI) + CALL intersurf_main (itime+itau_phy, iim, jjm+1, knon, ktindex, dtime, & + lrestart_read, lrestart_write, lalo, & + contfrac, neighbours, resolution, date0, & + zlev, u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, & + cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, & + precip_rain, precip_snow, lwdown, swnet, swdown_vrai, ps, & + evap, fluxsens, fluxlat, coastalflow, riverflow, & + tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, & + lon_scat, lat_scat, q2m, t2m) + +#else + ! Interface for ORCHIDEE version 1.9 or later compiled in parallel mode(with preprocessing flag CPP_MPI) + CALL intersurf_main (itime+itau_phy, iim, jjm+1,offset, knon, ktindex, & + orch_comm,dtime, lrestart_read, lrestart_write, lalo, & + contfrac, neighbours, resolution, date0, & + zlev, u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), & + cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), & + precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown_vrai(1:knon), ps(1:knon), & + evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), & + tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), & + lon_scat, lat_scat, q2m, t2m) +#endif + + ENDIF + + albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2. + +!* Send to coupler +! + IF (type_ocean=='couple') THEN + CALL cpl_send_land_fields(itime, knon, knindex, & + riverflow, coastalflow) + ENDIF + + alb1_new(1:knon) = albedo_out(1:knon,1) + alb2_new(1:knon) = albedo_out(1:knon,2) + +! Convention orchidee: positif vers le haut + fluxsens(1:knon) = -1. * fluxsens(1:knon) + fluxlat(1:knon) = -1. * fluxlat(1:knon) + +! evap = -1. * evap + + IF (debut) lrestart_read = .FALSE. + + +! JG : TEMPORAIRE!!!! Les variables fco2_land_comp et fco2_lu_comp seront plus tard en sortie d'ORCHIDEE +! ici mis a valeur quelquonque pour test. Ces variables sont sur la grille compresse avec uniquement des points de terres + + fco2_land_comp(:) = 1. + fco2_lu_comp(:) = 10. + +! Decompress variables for the module carbon_cycle_mod + IF (carbon_cycle_cpl) THEN + fco2_land_inst(:)=0. + fco2_lu_inst(:)=0. + + DO igrid = 1, knon + ireal = knindex(igrid) + fco2_land_inst(ireal) = fco2_land_comp(igrid) + fco2_lu_inst(ireal) = fco2_lu_comp(igrid) + END DO + END IF + +#endif + END SUBROUTINE surf_land_orchidee +! +!**************************************************************************************** +! + SUBROUTINE Init_orchidee_index(knon,orch_comm,knindex,offset,ktindex) + + INCLUDE "dimensions.h" + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + INTEGER, INTENT(IN) :: orch_comm + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + +! Output arguments +!**************************************************************************************** + INTEGER, INTENT(OUT) :: offset + INTEGER, DIMENSION(knon), INTENT(OUT) :: ktindex + +! Local varables +!**************************************************************************************** +#ifdef CPP_MPI + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status +#endif + + INTEGER :: MyLastPoint + INTEGER :: LastPoint + INTEGER :: mpi_rank_orch + INTEGER :: mpi_size_orch + INTEGER :: ierr +! +! End definition +!**************************************************************************************** + + MyLastPoint=klon_mpi_begin-1+knindex(knon)+iim-1 + + IF (is_parallel) THEN +#ifdef CPP_MPI + CALL MPI_COMM_SIZE(orch_comm,mpi_size_orch,ierr) + CALL MPI_COMM_RANK(orch_comm,mpi_rank_orch,ierr) +#endif + ELSE + mpi_rank_orch=0 + mpi_size_orch=1 + ENDIF + + IF (is_parallel) THEN + IF (mpi_rank_orch /= 0) THEN +#ifdef CPP_MPI + CALL MPI_RECV(LastPoint,1,MPI_INTEGER,mpi_rank_orch-1,1234,orch_comm,status,ierr) +#endif + ENDIF + + IF (mpi_rank_orch /= mpi_size_orch-1) THEN +#ifdef CPP_MPI + CALL MPI_SEND(MyLastPoint,1,MPI_INTEGER,mpi_rank_orch+1,1234,orch_comm,ierr) +#endif + ENDIF + ENDIF + + IF (mpi_rank_orch == 0) THEN + offset=0 + ELSE + offset=LastPoint-MOD(LastPoint,iim) + ENDIF + + ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin+iim-1)-offset-1 + + + END SUBROUTINE Init_orchidee_index +! +!**************************************************************************************** +! + SUBROUTINE Get_orchidee_communicator(knon,orch_comm) + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + + INTEGER,INTENT(IN) :: knon + INTEGER,INTENT(OUT) :: orch_comm + + INTEGER :: color + INTEGER :: ierr +! +! End definition +!**************************************************************************************** + + IF (knon==0) THEN + color = 0 + ELSE + color = 1 + ENDIF + +#ifdef CPP_MPI + CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr) +#endif + + END SUBROUTINE Get_orchidee_communicator +! +!**************************************************************************************** +! + SUBROUTINE Init_neighbours(knon,neighbours,ktindex,pctsrf) + + INCLUDE "indicesol.h" + INCLUDE "dimensions.h" +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: ktindex + REAL, DIMENSION(klon), INTENT(IN) :: pctsrf + +! Output arguments +!**************************************************************************************** + INTEGER, DIMENSION(knon,8), INTENT(OUT) :: neighbours + +! Local variables +!**************************************************************************************** + INTEGER :: knon_g + INTEGER :: i, igrid, jj, ij, iglob + INTEGER :: ierr, ireal, index + INTEGER, DIMENSION(0:mpi_size-1) :: knon_nb + INTEGER, DIMENSION(0:mpi_size-1) :: displs + INTEGER, DIMENSION(8,3) :: off_ini + INTEGER, DIMENSION(8) :: offset + INTEGER, DIMENSION(knon) :: ktindex_p + INTEGER, DIMENSION(iim,jjm+1) :: correspond + INTEGER, ALLOCATABLE, DIMENSION(:) :: ktindex_g + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: neighbours_g + REAL, DIMENSION(klon_glo) :: pctsrf_g + +! +! End definition +!**************************************************************************************** + + IF (is_sequential) THEN + knon_nb(:)=knon + ELSE + +#ifdef CPP_MPI + CALL MPI_GATHER(knon,1,MPI_INTEGER,knon_nb,1,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr) +#endif + + ENDIF + + IF (is_mpi_root) THEN + knon_g=SUM(knon_nb(:)) + ALLOCATE(ktindex_g(knon_g)) + ALLOCATE(neighbours_g(knon_g,8)) + neighbours_g(:,:)=-1 + displs(0)=0 + DO i=1,mpi_size-1 + displs(i)=displs(i-1)+knon_nb(i-1) + ENDDO + ELSE + ALLOCATE(neighbours_g(1,8)) + ENDIF + + ktindex_p(1:knon)=ktindex(1:knon)+klon_mpi_begin-1+iim-1 + + IF (is_sequential) THEN + ktindex_g(:)=ktindex_p(:) + ELSE + +#ifdef CPP_MPI + CALL MPI_GATHERV(ktindex_p,knon,MPI_INTEGER,ktindex_g,knon_nb,& + displs,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr) +#endif + + ENDIF + + CALL Gather(pctsrf,pctsrf_g) + + IF (is_mpi_root) THEN +! Initialisation des offset +! +! offset bord ouest + off_ini(1,1) = - iim ; off_ini(2,1) = - iim + 1; off_ini(3,1) = 1 + off_ini(4,1) = iim + 1; off_ini(5,1) = iim ; off_ini(6,1) = 2 * iim - 1 + off_ini(7,1) = iim -1 ; off_ini(8,1) = - 1 +! offset point normal + off_ini(1,2) = - iim ; off_ini(2,2) = - iim + 1; off_ini(3,2) = 1 + off_ini(4,2) = iim + 1; off_ini(5,2) = iim ; off_ini(6,2) = iim - 1 + off_ini(7,2) = -1 ; off_ini(8,2) = - iim - 1 +! offset bord est + off_ini(1,3) = - iim; off_ini(2,3) = - 2 * iim + 1; off_ini(3,3) = - iim + 1 + off_ini(4,3) = 1 ; off_ini(5,3) = iim ; off_ini(6,3) = iim - 1 + off_ini(7,3) = -1 ; off_ini(8,3) = - iim - 1 +! +! +! Attention aux poles +! + DO igrid = 1, knon_g + index = ktindex_g(igrid) + jj = INT((index - 1)/iim) + 1 + ij = index - (jj - 1) * iim + correspond(ij,jj) = igrid + ENDDO + + DO igrid = 1, knon_g + iglob = ktindex_g(igrid) + IF (MOD(iglob, iim) == 1) THEN + offset = off_ini(:,1) + ELSE IF(MOD(iglob, iim) == 0) THEN + offset = off_ini(:,3) + ELSE + offset = off_ini(:,2) + ENDIF + DO i = 1, 8 + index = iglob + offset(i) + ireal = (MIN(MAX(1, index - iim + 1), klon_glo)) + IF (pctsrf_g(ireal) > EPSFRA) THEN + jj = INT((index - 1)/iim) + 1 + ij = index - (jj - 1) * iim + neighbours_g(igrid, i) = correspond(ij, jj) + ENDIF + ENDDO + ENDDO + + ENDIF + + DO i=1,8 + IF (is_sequential) THEN + neighbours(:,i)=neighbours_g(:,i) + ELSE +#ifdef CPP_MPI + CALL MPI_SCATTERV(neighbours_g(:,i),knon_nb,displs,MPI_INTEGER,neighbours(:,i),knon,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr) +#endif + ENDIF + ENDDO + + END SUBROUTINE Init_neighbours +! +!**************************************************************************************** +! + +#endif +END MODULE surf_land_orchidee_noopenmp_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_landice_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_landice_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_landice_mod.F90 (revision 1280) @@ -0,0 +1,185 @@ +! +MODULE surf_landice_mod + + IMPLICIT NONE + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE surf_landice(itime, dtime, knon, knindex, & + swnet, lwnet, tsurf, p1lay, & + cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, rugoro, pctsrf, & + snow, qsurf, qsol, agesno, & + tsoil, z0_new, alb1, alb2, evap, fluxsens, fluxlat, & + tsurf_new, dflux_s, dflux_l, & + flux_u1, flux_v1) + + USE dimphy + USE surface_data, ONLY : type_ocean, calice, calsno + USE fonte_neige_mod, ONLY : fonte_neige, run_off_lic + USE cpl_mod, ONLY : cpl_send_landice_fields + USE calcul_fluxs_mod + + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + INCLUDE "YOMCST.h" + INCLUDE "clesphys.h" + +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, knon + INTEGER, DIMENSION(klon), INTENT(in) :: knindex + REAL, INTENT(in) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: swnet ! net shortwave radiance + REAL, DIMENSION(klon), INTENT(IN) :: lwnet ! net longwave radiance + REAL, DIMENSION(klon), INTENT(IN) :: tsurf + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + REAL, DIMENSION(klon), INTENT(IN) :: rugoro + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + +! In/Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow, qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil + +! Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: z0_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb1 ! new albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(OUT) :: alb2 ! new albedo in near IR interval + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + +! Local variables +!**************************************************************************************** + REAL, DIMENSION(klon) :: soilcap, soilflux + REAL, DIMENSION(klon) :: cal, beta, dif_grnd + REAL, DIMENSION(klon) :: zfra, alb_neig + REAL, DIMENSION(klon) :: radsol + REAL, DIMENSION(klon) :: u0, v0, u1_lay, v1_lay + +! End definition +!**************************************************************************************** +! +! Initialize output variables + alb2(:) = 999999. + alb1(:) = 999999. + +!**************************************************************************************** +! Calculate total absorbed radiance at surface +! +!**************************************************************************************** + radsol(:) = 0.0 + radsol(1:knon) = swnet(1:knon) + lwnet(1:knon) + +!**************************************************************************************** +! Soil calculations +! +!**************************************************************************************** + IF (soil_model) THEN + CALL soil(dtime, is_lic, knon, snow, tsurf, tsoil, soilcap, soilflux) + cal(1:knon) = RCPD / soilcap(1:knon) + radsol(1:knon) = radsol(1:knon) + soilflux(1:knon) + ELSE + cal = RCPD * calice + WHERE (snow > 0.0) cal = RCPD * calsno + ENDIF + + +!**************************************************************************************** +! Calulate fluxes +! +!**************************************************************************************** + beta(:) = 1.0 + dif_grnd(:) = 0.0 + +! Suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + u1_lay(:) = u1(:) - u0(:) + v1_lay(:) = v1(:) - v0(:) + + CALL calcul_fluxs(knon, is_lic, dtime, & + tsurf, p1lay, cal, beta, cdragh, ps, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + + CALL calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + +!**************************************************************************************** +! Calculate snow height, age, run-off,.. +! +!**************************************************************************************** + CALL fonte_neige( knon, is_lic, knindex, dtime, & + tsurf, precip_rain, precip_snow, & + snow, qsol, tsurf_new, evap) + + +!**************************************************************************************** +! Calculate albedo +! +!**************************************************************************************** + CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:)) + WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0. + zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/(snow(1:knon)+10.0))) + alb1(1:knon) = alb_neig(1:knon)*zfra(1:knon) + & + 0.6 * (1.0-zfra(1:knon)) +! +!IM: plusieurs choix/tests sur l'albedo des "glaciers continentaux" +! alb1(1 : knon) = 0.6 !IM cf FH/GK +! alb1(1 : knon) = 0.82 +! alb1(1 : knon) = 0.77 !211003 Ksta0.77 +! alb1(1 : knon) = 0.8 !KstaTER0.8 & LMD_ARMIP5 +!IM: KstaTER0.77 & LMD_ARMIP6 + +! Attantion: alb1 and alb2 are the same! + alb1(1:knon) = 0.77 + alb2(1:knon) = alb1(1:knon) + + +!**************************************************************************************** +! Rugosity +! +!**************************************************************************************** + z0_new(:) = MAX(1.E-3,rugoro(:)) + +!**************************************************************************************** +! Send run-off on land-ice to coupler if coupled ocean. +! run_off_lic has been calculated in fonte_neige +! +!**************************************************************************************** + IF (type_ocean=='couple') THEN + CALL cpl_send_landice_fields(itime, knon, knindex, run_off_lic) + ENDIF + + + END SUBROUTINE surf_landice +! +!**************************************************************************************** +! +END MODULE surf_landice_mod + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_ocean_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_ocean_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_ocean_mod.F90 (revision 1280) @@ -0,0 +1,170 @@ +! +MODULE surf_ocean_mod + + IMPLICIT NONE + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE surf_ocean(rlon, rlat, swnet, lwnet, alb1, & + rugos, windsp, rmu0, fder, tsurf_in, & + itime, dtime, jour, knon, knindex, & + p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, rugoro, pctsrf, & + snow, qsurf, agesno, & + z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, & + tsurf_new, dflux_s, dflux_l, lmt_bils, & + flux_u1, flux_v1) + + USE dimphy + USE surface_data, ONLY : type_ocean + USE ocean_forced_mod, ONLY : ocean_forced_noice + USE ocean_slab_mod, ONLY : ocean_slab_noice + USE ocean_cpl_mod, ONLY : ocean_cpl_noice +! +! This subroutine will make a call to ocean_XXX_noice according to the ocean mode (force, +! slab or couple). The calculations of albedo and rugosity for the ocean surface are +! done in here because they are identical for the different modes of ocean. +! + INCLUDE "indicesol.h" + INCLUDE "YOMCST.h" + +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(IN) :: swnet ! net shortwave radiation at surface + REAL, DIMENSION(klon), INTENT(IN) :: lwnet ! net longwave radiation at surface + REAL, DIMENSION(klon), INTENT(IN) :: alb1 ! albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(IN) :: rugos + REAL, DIMENSION(klon), INTENT(IN) :: windsp + REAL, DIMENSION(klon), INTENT(IN) :: rmu0 + REAL, DIMENSION(klon), INTENT(IN) :: fder + REAL, DIMENSION(klon), INTENT(IN) :: tsurf_in + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh + REAL, DIMENSION(klon), INTENT(IN) :: cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + REAL, DIMENSION(klon), INTENT(IN) :: rugoro + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + +! In/Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow + REAL, DIMENSION(klon), INTENT(INOUT) :: qsurf + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + +! Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: z0_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new ! new albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(OUT) :: alb2_new ! new albedo in near IR interval + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + REAL, DIMENSION(klon), INTENT(OUT) :: lmt_bils + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + +! Local variables +!**************************************************************************************** + INTEGER :: i + REAL :: tmp + REAL, PARAMETER :: cepdu2=(0.1)**2 + REAL, DIMENSION(klon) :: alb_eau + REAL, DIMENSION(klon) :: radsol + +! End definition +!**************************************************************************************** + + +!**************************************************************************************** +! Calculate total net radiance at surface +! +!**************************************************************************************** + radsol(:) = 0.0 + radsol(1:knon) = swnet(1:knon) + lwnet(1:knon) + +!**************************************************************************************** +! Switch according to type of ocean (couple, slab or forced) +!**************************************************************************************** + SELECT CASE(type_ocean) + CASE('couple') + CALL ocean_cpl_noice( & + swnet, lwnet, alb1, & + windsp, fder, & + itime, dtime, knon, knindex, & + p1lay, cdragh, cdragm, precip_rain, precip_snow,temp_air,spechum,& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, & + radsol, snow, agesno, & + qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l) + + CASE('slab') + CALL ocean_slab_noice( & + itime, dtime, jour, knon, knindex, & + p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum,& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, tsurf_in, & + radsol, snow, agesno, & + qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l, lmt_bils) + + CASE('force') + CALL ocean_forced_noice( & + itime, dtime, jour, knon, knindex, & + p1lay, cdragh, cdragm, precip_rain, precip_snow, & + temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, & + radsol, snow, agesno, & + qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l) + END SELECT + +!**************************************************************************************** +! Calculate albedo +! +!**************************************************************************************** + IF ( MINVAL(rmu0) == MAXVAL(rmu0) .AND. MINVAL(rmu0) == -999.999 ) THEN + CALL alboc(FLOAT(jour),rlat,alb_eau) + ELSE ! diurnal cycle + CALL alboc_cd(rmu0,alb_eau) + ENDIF + + DO i =1, knon + alb1_new(i) = alb_eau(knindex(i)) + ENDDO + alb2_new(1:knon) = alb1_new(1:knon) + +!**************************************************************************************** +! Calculate the rugosity +! +!**************************************************************************************** + DO i = 1, knon + tmp = MAX(cepdu2,u1(i)**2+v1(i)**2) + z0_new(i) = 0.018*cdragm(i) * (u1(i)**2+v1(i)**2)/RG & + + 0.11*14e-6 / SQRT(cdragm(i) * tmp) + z0_new(i) = MAX(1.5e-05,z0_new(i)) + ENDDO +! +!**************************************************************************************** +! + END SUBROUTINE surf_ocean +! +!**************************************************************************************** +! +END MODULE surf_ocean_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_seaice_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_seaice_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surf_seaice_mod.F90 (revision 1280) @@ -0,0 +1,146 @@ +! +MODULE surf_seaice_mod + + IMPLICIT NONE + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE surf_seaice( & + rlon, rlat, swnet, lwnet, alb1, fder, & + itime, dtime, jour, knon, knindex, & + lafin, & + tsurf, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, rugoro, pctsrf, & + snow, qsurf, qsol, agesno, tsoil, & + z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, & + tsurf_new, dflux_s, dflux_l, & + flux_u1, flux_v1) + + USE dimphy + USE surface_data + USE ocean_forced_mod, ONLY : ocean_forced_ice + USE ocean_cpl_mod, ONLY : ocean_cpl_ice + +! +! This subroutine will make a call to ocean_XXX_ice according to the ocean mode (force, +! slab or couple). The calculation of rugosity for the sea-ice surface is also done +! in here because it is the same calculation for the different modes of ocean. +! + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + LOGICAL, INTENT(IN) :: lafin + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(IN) :: swnet ! net shortwave radiation at surface + REAL, DIMENSION(klon), INTENT(IN) :: lwnet ! net longwave radiation at surface + REAL, DIMENSION(klon), INTENT(IN) :: alb1 ! albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(IN) :: fder + REAL, DIMENSION(klon), INTENT(IN) :: tsurf + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + REAL, DIMENSION(klon), INTENT(IN) :: rugoro + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + +! In/Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow, qsurf, qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: z0_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new ! new albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(OUT) :: alb2_new ! new albedo in near IR interval + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + +! Local arguments +!**************************************************************************************** + REAL, DIMENSION(klon) :: radsol + +! +! End definitions +!**************************************************************************************** + + +!**************************************************************************************** +! Calculate total net radiance at surface +! +!**************************************************************************************** + radsol(:) = 0.0 + radsol(1:knon) = swnet(1:knon) + lwnet(1:knon) + +!**************************************************************************************** +! Switch according to type of ocean (couple, slab or forced) +! +!**************************************************************************************** + IF (type_ocean == 'couple') THEN + + CALL ocean_cpl_ice( & + rlon, rlat, swnet, lwnet, alb1, & + fder, & + itime, dtime, knon, knindex, & + lafin,& + p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum,& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, pctsrf, & + radsol, snow, qsurf, & + alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l) + + ELSE IF (type_ocean == 'force' .OR. (type_ocean == 'slab' .AND. version_ocean=='sicOBS')) THEN + CALL ocean_forced_ice( & + itime, dtime, jour, knon, knindex, & + tsurf, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum,& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, & + radsol, snow, qsol, agesno, tsoil, & + qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l) + + ELSE IF (type_ocean == 'slab') THEN +!!$ CALL ocean_slab_ice( & +!!$ itime, dtime, jour, knon, knindex, & +!!$ debut, & +!!$ tsurf, p1lay, cdragh, precip_rain, precip_snow, temp_air, spechum,& +!!$ AcoefH, AcoefQ, BcoefH, BcoefQ, & +!!$ ps, u1, v1, pctsrf, & +!!$ radsol, snow, qsurf, qsol, agesno, tsoil, & +!!$ alb1_new, alb2_new, evap, fluxsens, fluxlat, & +!!$ tsurf_new, dflux_s, dflux_l) + + END IF + +!**************************************************************************************** +! Calculate rugosity +! +!**************************************************************************************** + z0_new = 0.002 + z0_new = SQRT(z0_new**2+rugoro**2) + + END SUBROUTINE surf_seaice +! +!**************************************************************************************** +! +END MODULE surf_seaice_mod + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surface_data.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surface_data.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/surface_data.F90 (revision 1280) @@ -0,0 +1,21 @@ +! +! $Header$ +! +MODULE surface_data + + REAL, PARAMETER :: calice=1.0/(5.1444e+06*0.15) + REAL, PARAMETER :: tau_gl=86400.*5. + REAL, PARAMETER :: calsno=1./(2.3867e+06*.15) + + LOGICAL, SAVE :: ok_veget ! true for use of vegetation model ORCHIDEE + !$OMP THREADPRIVATE(ok_veget) + + CHARACTER(len=6), SAVE :: type_ocean ! force/slab/couple + !$OMP THREADPRIVATE(type_ocean) + + ! if type_ocean=couple : version_ocean=opa8 ou nemo + ! if type_ocean=slab : version_ocean=sicOBS + CHARACTER(len=6), SAVE :: version_ocean + !$OMP THREADPRIVATE(version_ocean) + +END MODULE surface_data Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/sw_aeroAR4.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/sw_aeroAR4.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/sw_aeroAR4.F90 (revision 1280) @@ -0,0 +1,565 @@ +! +! $Id$ +! +SUBROUTINE SW_AEROAR4(PSCT, PRMU0, PFRAC, & + PPMB, PDP, & + PPSOL, PALBD, PALBP,& + PTAVE, PWV, PQS, POZON, PAER,& + PCLDSW, PTAU, POMEGA, PCG,& + PHEAT, PHEAT0,& + PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0,& + ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,& + tauaero, pizaero, cgaero,& + PTAUA, POMEGAA,& + PTOPSWADAERO,PSOLSWADAERO,& + PTOPSWAD0AERO,PSOLSWAD0AERO,& + PTOPSWAIAERO,PSOLSWAIAERO,& + PTOPSWAERO,PTOPSW0AERO,& + PSOLSWAERO,PSOLSW0AERO,& + PTOPSWCFAERO,PSOLSWCFAERO,& + ok_ade, ok_aie ) + + USE dimphy + + IMPLICIT NONE + +#include "YOMCST.h" +#include "clesphys.h" + ! + ! ------------------------------------------------------------------ + ! + ! PURPOSE. + ! -------- + ! + ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO + ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980). + ! + ! METHOD. + ! ------- + ! + ! 1. COMPUTES ABSORBER AMOUNTS (SWU) + ! 2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL (SW1S) + ! 3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL (SW2S) + ! + ! REFERENCE. + ! ---------- + ! + ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT + ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980) + ! + ! AUTHOR. + ! ------- + ! JEAN-JACQUES MORCRETTE *ECMWF* + ! + ! MODIFICATIONS. + ! -------------- + ! ORIGINAL : 89-07-14 + ! 95-01-01 J.-J. MORCRETTE Direct/Diffuse Albedo + ! 03-11-27 J. QUAAS Introduce aerosol forcings (based on BOUCHER) + ! 09-04 A. COZIC - C.DEANDREIS Indroduce NAT/BC/POM/DUST/SS aerosol forcing + ! ------------------------------------------------------------------ + ! + !* ARGUMENTS: + ! + REAL(KIND=8) PSCT ! constante solaire (valeur conseillee: 1370) + + REAL(KIND=8) PPSOL(KDLON) ! SURFACE PRESSURE (PA) + REAL(KIND=8) PDP(KDLON,KFLEV) ! LAYER THICKNESS (PA) + REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB) + + REAL(KIND=8) PRMU0(KDLON) ! COSINE OF ZENITHAL ANGLE + REAL(KIND=8) PFRAC(KDLON) ! fraction de la journee + + REAL(KIND=8) PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K) + REAL(KIND=8) PWV(KDLON,KFLEV) ! SPECIFI! HUMIDITY (KG/KG) + REAL(KIND=8) PQS(KDLON,KFLEV) ! SATURATED WATER VAPOUR (KG/KG) + REAL(KIND=8) POZON(KDLON,KFLEV) ! OZONE CONCENTRATION (KG/KG) + REAL(KIND=8) PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS + + REAL(KIND=8) PALBD(KDLON,2) ! albedo du sol (lumiere diffuse) + REAL(KIND=8) PALBP(KDLON,2) ! albedo du sol (lumiere parallele) + + REAL(KIND=8) PCLDSW(KDLON,KFLEV) ! CLOUD FRACTION + REAL(KIND=8) PTAU(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS + REAL(KIND=8) PCG(KDLON,2,KFLEV) ! ASYMETRY FACTOR + REAL(KIND=8) POMEGA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO + + REAL(KIND=8) PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY) + REAL(KIND=8) PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky + REAL(KIND=8) PALBPLA(KDLON) ! PLANETARY ALBEDO + REAL(KIND=8) PTOPSW(KDLON) ! SHORTWAVE FLUX AT T.O.A. + REAL(KIND=8) PSOLSW(KDLON) ! SHORTWAVE FLUX AT SURFACE + REAL(KIND=8) PTOPSW0(KDLON) ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY) + REAL(KIND=8) PSOLSW0(KDLON) ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY) + ! + !* LOCAL VARIABLES: + ! + real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2 + + REAL(KIND=8) ZOZ(KDLON,KFLEV) + ! column-density of ozone in layer, in kilo-Dobsons + + REAL(KIND=8) ZAKI(KDLON,2) + REAL(KIND=8) ZCLD(KDLON,KFLEV) + REAL(KIND=8) ZCLEAR(KDLON) + REAL(KIND=8) ZDSIG(KDLON,KFLEV) + REAL(KIND=8) ZFACT(KDLON) + REAL(KIND=8) ZFD(KDLON,KFLEV+1) + REAL(KIND=8) ZFDOWN(KDLON,KFLEV+1) + REAL(KIND=8) ZFU(KDLON,KFLEV+1) + REAL(KIND=8) ZFUP(KDLON,KFLEV+1) + REAL(KIND=8) ZRMU(KDLON) + REAL(KIND=8) ZSEC(KDLON) + REAL(KIND=8) ZUD(KDLON,5,KFLEV+1) + REAL(KIND=8) ZCLDSW0(KDLON,KFLEV) + + REAL(KIND=8) ZFSUP(KDLON,KFLEV+1) + REAL(KIND=8) ZFSDN(KDLON,KFLEV+1) + REAL(KIND=8) ZFSUP0(KDLON,KFLEV+1) + REAL(KIND=8) ZFSDN0(KDLON,KFLEV+1) + + INTEGER inu, jl, jk, i, k, kpl1 + + INTEGER swpas ! Every swpas steps, sw is calculated + PARAMETER(swpas=1) + + INTEGER, SAVE :: itapsw = 0 + !$OMP THREADPRIVATE(itapsw) + LOGICAL, SAVE :: appel1er = .TRUE. + !$OMP THREADPRIVATE(appel1er) + LOGICAL, SAVE :: initialized = .FALSE. + !$OMP THREADPRIVATE(initialized) + + !jq-Introduced for aerosol forcings + REAL(KIND=8), SAVE :: flag_aer + !$OMP THREADPRIVATE(flag_aer) + + LOGICAL ok_ade, ok_aie ! use aerosol forcings or not? + REAL(KIND=8) tauaero(kdlon,kflev,9,2) ! aerosol optical properties + REAL(KIND=8) pizaero(kdlon,kflev,9,2) ! (see aeropt.F) + REAL(KIND=8) cgaero(kdlon,kflev,9,2) ! -"- + REAL(KIND=8) PTAUA(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS (pre-industrial value) + REAL(KIND=8) POMEGAA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO + REAL(KIND=8) PTOPSWADAERO(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR) + REAL(KIND=8) PSOLSWADAERO(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR) + REAL(KIND=8) PTOPSWAD0AERO(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR) + REAL(KIND=8) PSOLSWAD0AERO(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR) + REAL(KIND=8) PTOPSWAIAERO(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND) + REAL(KIND=8) PSOLSWAIAERO(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND) + REAL(KIND=8) PTOPSWAERO(KDLON,9) ! SW TOA AS DRF nat & ant + REAL(KIND=8) PTOPSW0AERO(KDLON,9) ! SW SRF AS DRF nat & ant + REAL(KIND=8) PSOLSWAERO(KDLON,9) ! SW TOA CS DRF nat & ant + REAL(KIND=8) PSOLSW0AERO(KDLON,9) ! SW SRF CS DRF nat & ant + REAL(KIND=8) PTOPSWCFAERO(KDLON,3) ! SW TOA AS cloudRF nat & ant + REAL(KIND=8) PSOLSWCFAERO(KDLON,3) ! SW SRF AS cloudRF nat & ant + + !jq - Fluxes including aerosol effects + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUPAD_AERO(:,:) + !$OMP THREADPRIVATE(ZFSUPAD_AERO) + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDNAD_AERO(:,:) + !$OMP THREADPRIVATE(ZFSDNAD_AERO) + !jq - Fluxes including aerosol effects + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUPAD0_AERO(:,:) + !$OMP THREADPRIVATE(ZFSUPAD0_AERO) + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDNAD0_AERO(:,:) + !$OMP THREADPRIVATE(ZFSDNAD0_AERO) + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUPAI_AERO(:,:) + !$OMP THREADPRIVATE(ZFSUPAI_AERO) + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDNAI_AERO(:,:) + !$OMP THREADPRIVATE(ZFSDNAI_AERO) + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUP_AERO(:,:,:) + !$OMP THREADPRIVATE(ZFSUP_AERO) + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDN_AERO(:,:,:) + !$OMP THREADPRIVATE(ZFSDN_AERO) + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUP0_AERO(:,:,:) + !$OMP THREADPRIVATE(ZFSUP0_AERO) + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDN0_AERO(:,:,:) + !$OMP THREADPRIVATE(ZFSDN0_AERO) + +! Key to define the aerosol effect acting on climate +! 0: aerosol feedback active according to ok_ade, ok_aie DEFAULT +! 1: no feedback , zero aerosol fluxes are used for climate, diagnostics according to ok_ade_ok_aie +! 2: feedback according to total aerosol direct effect used for climate, diagnostics according to ok_ade, ok_aie +! 3: feedback according to natural aerosol direct effect used for climate, diagnostics according to ok_ade_ok_aie + + INTEGER,SAVE :: AEROSOLFEEDBACK_ACTIVE = 0 +!$OMP THREADPRIVATE(AEROSOLFEEDBACK_ACTIVE) + + IF ((.not. ok_ade) .and. (AEROSOLFEEDBACK_ACTIVE .ge. 2)) THEN + print*,'Error: direct effect is not activated but assumed to be active - see sw_aeroAR4.F90' + stop + ENDIF + AEROSOLFEEDBACK_ACTIVE=MIN(MAX(AEROSOLFEEDBACK_ACTIVE,0),3) + IF (AEROSOLFEEDBACK_ACTIVE .gt. 3) THEN + print*,'Error: AEROSOLFEEDBACK_ACTIVE options go only until 3' + stop + ENDIF + + IF(.NOT.initialized) THEN + flag_aer=0. + initialized=.TRUE. + ALLOCATE(ZFSUPAD_AERO(KDLON,KFLEV+1)) + ALLOCATE(ZFSDNAD_AERO(KDLON,KFLEV+1)) + ALLOCATE(ZFSUPAD0_AERO(KDLON,KFLEV+1)) + ALLOCATE(ZFSDNAD0_AERO(KDLON,KFLEV+1)) + ALLOCATE(ZFSUPAI_AERO(KDLON,KFLEV+1)) + ALLOCATE(ZFSDNAI_AERO(KDLON,KFLEV+1)) + ALLOCATE(ZFSUP_AERO (KDLON,KFLEV+1,9)) + ALLOCATE(ZFSDN_AERO (KDLON,KFLEV+1,9)) + ALLOCATE(ZFSUP0_AERO(KDLON,KFLEV+1,9)) + ALLOCATE(ZFSDN0_AERO(KDLON,KFLEV+1,9)) + ZFSUPAD_AERO(:,:)=0. + ZFSDNAD_AERO(:,:)=0. + ZFSUPAD0_AERO(:,:)=0. + ZFSDNAD0_AERO(:,:)=0. + ZFSUPAI_AERO(:,:)=0. + ZFSDNAI_AERO(:,:)=0. + ZFSUP_AERO (:,:,:)=0. + ZFSDN_AERO (:,:,:)=0. + ZFSUP0_AERO(:,:,:)=0. + ZFSDN0_AERO(:,:,:)=0. + ENDIF + + IF (appel1er) THEN + PRINT*, 'SW calling frequency : ', swpas + PRINT*, " In general, it should be 1" + appel1er = .FALSE. + ENDIF + ! ------------------------------------------------------------------ + IF (MOD(itapsw,swpas).EQ.0) THEN + + DO JK = 1 , KFLEV + DO JL = 1, KDLON + ZCLDSW0(JL,JK) = 0.0 + ZOZ(JL,JK) = POZON(JL,JK)*46.6968/RG & + *PDP(JL,JK)*(101325.0/PPSOL(JL)) + ENDDO + ENDDO + +! clear sky is either computed IF no direct effect is asked for, or for extended diag) + IF (( lev_histmth .eq. 4 ) .or. ( .not. ok_ade )) THEN + + ! clear-sky: zero aerosol effect + flag_aer=0.0 + CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,& + PRMU0,PFRAC,PTAVE,PWV,& + ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU,PAER, flag_aer, & + tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),& + PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, PAER, flag_aer, & + tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),& + ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + PWV, PQS,& + ZFDOWN, ZFUP) + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP0_AERO(JL,JK,1) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN0_AERO(JL,JK,1) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + ENDIF + +! cloudy sky is either computed IF no indirect effect is asked for, or for extended diag) + IF (( lev_histmth .eq. 4 ) .or. ( .not. ok_aie )) THEN + ! cloudy-sky: zero aerosol effect + flag_aer=0.0 + CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,& + PRMU0,PFRAC,PTAVE,PWV,& + ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, PAER, flag_aer, & + tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),& + PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, PAER, flag_aer, & + tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),& + ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + PWV, PQS,& + ZFDOWN, ZFUP) + + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP_AERO(JL,JK,1) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN_AERO(JL,JK,1) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + ENDIF + + + IF (ok_ade) THEN + + ! clear sky (Anne Cozic 03/07/2007) direct effect of total aerosol + ! CAS AER (2) + flag_aer=1.0 + CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,& + PRMU0,PFRAC,PTAVE,PWV,& + ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),& + PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),& + ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + PWV, PQS,& + ZFDOWN, ZFUP) + + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP0_AERO(JL,JK,2) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN0_AERO(JL,JK,2) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + +! cloudy sky is either computed IF no indirect effect is asked for, or for extended diag) + IF (( lev_histmth .eq. 4 ) .or. (.not. ok_aie)) THEN + ! cloudy-sky aerosol direct effect of total aerosol + flag_aer=1.0 + CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,& + PRMU0,PFRAC,PTAVE,PWV,& + ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),& + PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),& + ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + PWV, PQS,& + ZFDOWN, ZFUP) + + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP_AERO(JL,JK,2) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN_AERO(JL,JK,2) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + ENDIF + +! natural aeroosl clear sky is computed for extended diag) + IF ( lev_histmth .eq. 4 ) THEN + ! clear sky direct effect natural aerosol + flag_aer=1.0 + CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,& + PRMU0,PFRAC,PTAVE,PWV,& + ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),& + PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),& + ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + PWV, PQS,& + ZFDOWN, ZFUP) + + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP0_AERO(JL,JK,3) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN0_AERO(JL,JK,3) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + ENDIF + +! cloud sky natural is for extended diagnostics + IF ( lev_histmth .eq. 4 ) THEN + ! cloudy-sky direct effect natural aerosol + flag_aer=1.0 + CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,& + PRMU0,PFRAC,PTAVE,PWV,& + ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),& + PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),& + ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + PWV, PQS,& + ZFDOWN, ZFUP) + + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP_AERO(JL,JK,3) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN_AERO(JL,JK,3) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + ENDIF + + ENDIF ! ok_ade + +! cloudy sky needs to be computed in all cases IF ok_aie is activated + IF (ok_aie) THEN + !jq cloudy-sky + aerosol direct + aerosol indirect of total aerosol + flag_aer=1.0 + CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,& + PRMU0,PFRAC,PTAVE,PWV,& + ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),& + PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,& + ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),& + ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,& + PWV, PQS,& + ZFDOWN, ZFUP) + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP_AERO(JL,JK,4) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN_AERO(JL,JK,4) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + ENDIF ! ok_aie + + itapsw = 0 + ENDIF + itapsw = itapsw + 1 + + IF ( AEROSOLFEEDBACK_ACTIVE .eq. 0) THEN + IF ( ok_ade .and. ok_aie ) THEN + ZFSUP(:,:) = ZFSUP_AERO(:,:,4) + ZFSDN(:,:) = ZFSDN_AERO(:,:,4) + ZFSUP0(:,:) = ZFSUP0_AERO(:,:,2) + ZFSDN0(:,:) = ZFSDN0_AERO(:,:,2) + ENDIF + IF ( ok_ade .and. (.not. ok_aie) ) THEN + ZFSUP(:,:) = ZFSUP_AERO(:,:,2) + ZFSDN(:,:) = ZFSDN_AERO(:,:,2) + ZFSUP0(:,:) = ZFSUP0_AERO(:,:,2) + ZFSDN0(:,:) = ZFSDN0_AERO(:,:,2) + ENDIF + + IF ( (.not. ok_ade) .and. ok_aie ) THEN + print*,'Warning: indirect effect in cloudy regions includes direct aerosol effect' + ZFSUP(:,:) = ZFSUP_AERO(:,:,4) + ZFSDN(:,:) = ZFSDN_AERO(:,:,4) + ZFSUP0(:,:) = ZFSUP0_AERO(:,:,1) + ZFSDN0(:,:) = ZFSDN0_AERO(:,:,1) + ENDIF + IF ((.not. ok_ade) .and. (.not. ok_aie)) THEN + ZFSUP(:,:) = ZFSUP_AERO(:,:,1) + ZFSDN(:,:) = ZFSDN_AERO(:,:,1) + ZFSUP0(:,:) = ZFSUP0_AERO(:,:,1) + ZFSDN0(:,:) = ZFSDN0_AERO(:,:,1) + ENDIF + +! MS the following allows to compute the forcing diagostics without +! letting the aerosol forcing act on the meteorology +! SEE logic above + ELSEIF ( AEROSOLFEEDBACK_ACTIVE .gt. 0) THEN + ZFSUP(:,:) = ZFSUP_AERO(:,:,AEROSOLFEEDBACK_ACTIVE) + ZFSDN(:,:) = ZFSDN_AERO(:,:,AEROSOLFEEDBACK_ACTIVE) + ZFSUP0(:,:) = ZFSUP0_AERO(:,:,AEROSOLFEEDBACK_ACTIVE) + ZFSDN0(:,:) = ZFSDN0_AERO(:,:,AEROSOLFEEDBACK_ACTIVE) + ENDIF + + + DO k = 1, KFLEV + kpl1 = k+1 + DO i = 1, KDLON + PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k))-(ZFSDN(i,k)-ZFSDN(i,kpl1)) + PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k) + PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k))-(ZFSDN0(i,k)-ZFSDN0(i,kpl1)) + PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k) + ENDDO + ENDDO + + DO i = 1, KDLON +! effective SW surface albedo calculation + PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20) + +! clear sky net fluxes at TOA and SRF + PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1) + PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1) + +! cloudy sky net fluxes at TOA and SRF + PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1) + PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1) + + +! net anthropogenic forcing direct and 1st indirect effect diagnostics +! requires a natural aerosol field read and used +! Difference of net fluxes from double call to radiation + + +IF (ok_ade) THEN + +! indices 1: natural; 2 anthropogenic +! TOA/SRF all sky natural forcing + PSOLSWAERO(i,1) = (ZFSDN_AERO(i,1,3) - ZFSUP_AERO(i,1,3))-(ZFSDN_AERO(i,1,1) - ZFSUP_AERO(i,1,1)) + PTOPSWAERO(i,1) = (ZFSDN_AERO(i,KFLEV+1,3) - ZFSUP_AERO(i,KFLEV+1,3))- (ZFSDN_AERO(i,KFLEV+1,1) - ZFSUP_AERO(i,KFLEV+1,1)) + +! TOA/SRF all sky anthropogenic forcing + PSOLSWAERO(i,2) = (ZFSDN_AERO(i,1,2) - ZFSUP_AERO(i,1,2))-(ZFSDN_AERO(i,1,3) - ZFSUP_AERO(i,1,3)) + PTOPSWAERO(i,2) = (ZFSDN_AERO(i,KFLEV+1,2) - ZFSUP_AERO(i,KFLEV+1,2))- (ZFSDN_AERO(i,KFLEV+1,3) - ZFSUP_AERO(i,KFLEV+1,3)) + +! TOA/SRF clear sky natural forcing + PSOLSW0AERO(i,1) = (ZFSDN0_AERO(i,1,3) - ZFSUP0_AERO(i,1,3))-(ZFSDN0_AERO(i,1,1) - ZFSUP0_AERO(i,1,1)) + PTOPSW0AERO(i,1) = (ZFSDN0_AERO(i,KFLEV+1,3) - ZFSUP0_AERO(i,KFLEV+1,3))-(ZFSDN0_AERO(i,KFLEV+1,1) - ZFSUP0_AERO(i,KFLEV+1,1)) + +! TOA/SRF clear sky anthropogenic forcing + PSOLSW0AERO(i,2) = (ZFSDN0_AERO(i,1,2) - ZFSUP0_AERO(i,1,2))-(ZFSDN0_AERO(i,1,3) - ZFSUP0_AERO(i,1,3)) + PTOPSW0AERO(i,2) = (ZFSDN0_AERO(i,KFLEV+1,2) - ZFSUP0_AERO(i,KFLEV+1,2))-(ZFSDN0_AERO(i,KFLEV+1,3) - ZFSUP0_AERO(i,KFLEV+1,3)) + +! Cloud forcing indices 1: natural; 2 anthropogenic; 3: zero aerosol direct effect +! Instantaneously computed cloudy sky direct aerosol effect, cloud forcing due to aerosols above clouds +! natural + PSOLSWCFAERO(i,1) = PSOLSWAERO(i,1) - PSOLSW0AERO(i,1) + PTOPSWCFAERO(i,1) = PTOPSWAERO(i,1) - PTOPSW0AERO(i,1) + +! Instantaneously computed cloudy SKY DIRECT aerosol effect, cloud forcing due to aerosols above clouds +! anthropogenic + PSOLSWCFAERO(i,2) = PSOLSWAERO(i,2) - PSOLSW0AERO(i,2) + PTOPSWCFAERO(i,2) = PTOPSWAERO(i,2) - PTOPSW0AERO(i,2) + +! Cloudforcing without aerosol +! zero + PSOLSWCFAERO(i,3) = (ZFSDN_AERO(i,1,1) - ZFSUP_AERO(i,1,1))-(ZFSDN0_AERO(i,1,1) - ZFSUP0_AERO(i,1,1)) + PTOPSWCFAERO(i,3) = (ZFSDN_AERO(i,KFLEV+1,1) - ZFSUP_AERO(i,KFLEV+1,1))- (ZFSDN0_AERO(i,KFLEV+1,1) - ZFSUP0_AERO(i,KFLEV+1,1)) + +! direct anthropogenic forcing , as in old LMDzT, however differences of net fluxes + PSOLSWADAERO(i) = PSOLSWAERO(i,2) + PTOPSWADAERO(i) = PTOPSWAERO(i,2) + PSOLSWAD0AERO(i) = PSOLSW0AERO(i,2) + PTOPSWAD0AERO(i) = PTOPSW0AERO(i,2) + +ENDIF + + +IF (ok_aie) THEN + PSOLSWAIAERO(i) = (ZFSDN_AERO(i,1,4) - ZFSUP_AERO(i,1,4))-(ZFSDN_AERO(i,1,2) - ZFSUP_AERO(i,1,2)) + PTOPSWAIAERO(i) = (ZFSDN_AERO(i,KFLEV+1,4) - ZFSUP_AERO(i,KFLEV+1,4))-(ZFSDN_AERO(i,KFLEV+1,2) - ZFSUP_AERO(i,KFLEV+1,2)) +ENDIF + + ENDDO +END SUBROUTINE SW_AEROAR4 Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/tetalevel.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/tetalevel.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/tetalevel.F (revision 1280) @@ -0,0 +1,141 @@ +! +! $Header$ +! +c================================================================ +c================================================================ + SUBROUTINE tetalevel(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres) +c================================================================ +c================================================================ + USE dimphy + IMPLICIT none + +cym#include "dimensions.h" +cym#include "dimphy.h" + +c================================================================ +c +c Interpoler des champs 3-D u, v et g du modele a un niveau de +c pression donnee (pres) +c +c INPUT: ilon ----- nombre de points +c ilev ----- nombre de couches +c lnew ----- true si on doit reinitialiser les poids +c pgcm ----- pressions modeles +c pres ----- pression vers laquelle on interpolle +c Qgcm ----- champ GCM +c Qpres ---- champ interpolle au niveau pres +c +c================================================================ +c +c arguments : +c ----------- + + INTEGER ilon, ilev + logical lnew + + REAL pgcm(ilon,ilev) + REAL Qgcm(ilon,ilev) + real pres + REAL Qpres(ilon) + +c local : +c ------- +c +cym#include "paramet.h" +c + INTEGER,ALLOCATABLE,SAVE :: lt(:), lb(:) + REAL,ALLOCATABLE,SAVE :: aist(:), aisb(:) + REAL,SAVE :: ptop, pbot + LOGICAL,SAVE :: first = .TRUE. +c$OMP THREADPRIVATE(lt,lb,aist,aisb,ptop, pbot,first) + + INTEGER i, k +c +c PRINT*,'tetalevel pres=',pres + IF (first) THEN + ALLOCATE(lt(ilon), lb(ilon)) + ALLOCATE(aist(ilon), aisb(ilon)) + + first=.FALSE. + ENDIF +c===================================================================== + if (lnew) then +c on r�nitialise les r�ndicages et les poids +c===================================================================== + + +c Chercher les 2 couches les plus proches du niveau a obtenir +c +c Eventuellement, faire l'extrapolation a partir des deux couches +c les plus basses ou les deux couches les plus hautes: + DO 130 i = 1, ilon +cIM IF ( ABS(pres-pgcm(i,ilev) ) .LT. + IF ( ABS(pres-pgcm(i,ilev) ) .GT. + . ABS(pres-pgcm(i,1)) ) THEN + lt(i) = ilev ! 2 + lb(i) = ilev-1 ! 1 + ELSE + lt(i) = 2 + lb(i) = 1 + ENDIF +cIM PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)', +cIM .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1)) + 130 CONTINUE + DO 150 k = 1, ilev-1 + DO 140 i = 1, ilon + pbot = pgcm(i,k) + ptop = pgcm(i,k+1) +cIM IF (ptop.LE.pres .AND. pbot.GE.pres) THEN + IF (ptop.GE.pres .AND. pbot.LE.pres) THEN + lt(i) = k+1 + lb(i) = k + ENDIF + 140 CONTINUE + 150 CONTINUE +c +c Interpolation lineaire: +c + DO i = 1, ilon +c interpolation en logarithme de pression: +c +c ... Modif . P. Le Van ( 20/01/98) .... +c Modif Fr��ic Hourdin (3/01/02) + +c IF(pgcm(i,lb(i)).NE.0.OR. +c $ pgcm(i,lt(i)).NE.0.) THEN +c +c PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i), +c . lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres +c + aist(i) = LOG( pgcm(i,lb(i))/ pres ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) ) + aisb(i) = LOG( pres / pgcm(i,lt(i)) ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i))) + enddo + + + endif ! lnew + +c====================================================================== +c inteprollation +c====================================================================== + + do i=1,ilon + Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i) +cIM PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i), +cIM $ Qgcm(i,lt(i)),aist(i),Qpres(i) + enddo +c +c Je mets les vents a zero quand je rencontre une montagne + do i = 1, ilon +cIM if (pgcm(i,1).LT.pres) THEN + if (pgcm(i,1).GT.pres) THEN +c Qpres(i)=1e33 + Qpres(i)=1e+20 +cIM PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres + endif + enddo + +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell.F (revision 1280) @@ -0,0 +1,1274 @@ + SUBROUTINE calcul_sec(ngrid,nlay,ptimestep + s ,pplay,pplev,pphi,zlev + s ,pu,pv,pt,po + s ,zmax,wmax,zw2,lmix +c s ,pu_therm,pv_therm + s ,r_aspect,l_mix,w2di,tho) + + USE dimphy + IMPLICIT NONE + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c +c Réécriture à partir d'un listing papier à Habas, le 14/02/00 +c +c le thermique est supposé homogène et dissipé par mélange avec +c son environnement. la longueur l_mix contrôle l'efficacité du +c mélange +c +c Le calcul du transport des différentes espèces se fait en prenant +c en compte: +c 1. un flux de masse montant +c 2. un flux de masse descendant +c 3. un entrainement +c 4. un detrainement +c +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" + +c arguments: +c ---------- + + INTEGER ngrid,nlay,w2di,tho + real ptimestep,l_mix,r_aspect + REAL pt(ngrid,nlay),pdtadj(ngrid,nlay) + REAL pu(ngrid,nlay),pduadj(ngrid,nlay) + REAL pv(ngrid,nlay),pdvadj(ngrid,nlay) + REAL po(ngrid,nlay),pdoadj(ngrid,nlay) + REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1) + real pphi(ngrid,nlay) + + integer idetr + save idetr + data idetr/3/ +c$OMP THREADPRIVATE(idetr) +c local: +c ------ + + INTEGER ig,k,l,lmaxa(klon),lmix(klon) + real zsortie1d(klon) +c CR: on remplace lmax(klon,klev+1) + INTEGER lmax(klon),lmin(klon),lentr(klon) + real linter(klon) + real zmix(klon), fracazmix(klon) +c RC + real zmax(klon),zw,zw2(klon,klev+1),ztva(klon,klev) + + real zlev(klon,klev+1),zlay(klon,klev) + REAL zh(klon,klev),zdhadj(klon,klev) + REAL ztv(klon,klev) + real zu(klon,klev),zv(klon,klev),zo(klon,klev) + REAL wh(klon,klev+1) + real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1) + real zla(klon,klev+1) + real zwa(klon,klev+1) + real zld(klon,klev+1) +! real zwd(klon,klev+1) + real zsortie(klon,klev) + real zva(klon,klev) + real zua(klon,klev) + real zoa(klon,klev) + + real zha(klon,klev) + real wa_moy(klon,klev+1) + real fraca(klon,klev+1) + real fracc(klon,klev+1) + real zf,zf2 + real thetath2(klon,klev),wth2(klon,klev) +! common/comtherm/thetath2,wth2 + + real count_time +! integer isplit,nsplit + integer isplit,nsplit,ialt + parameter (nsplit=10) + data isplit/0/ + save isplit +c$OMP THREADPRIVATE(isplit) + + logical sorties + real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev) + real zpspsk(klon,klev) + +c real wmax(klon,klev),wmaxa(klon) + real wmax(klon),wmaxa(klon) + real wa(klon,klev,klev+1) + real wd(klon,klev+1) + real larg_part(klon,klev,klev+1) + real fracd(klon,klev+1) + real xxx(klon,klev+1) + real larg_cons(klon,klev+1) + real larg_detr(klon,klev+1) + real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev) + real pu_therm(klon,klev),pv_therm(klon,klev) + real fm(klon,klev+1),entr(klon,klev) + real fmc(klon,klev+1) + +cCR:nouvelles variables + real f_star(klon,klev+1),entr_star(klon,klev) + real entr_star_tot(klon),entr_star2(klon) + real zalim(klon) + integer lalim(klon) + real norme(klon) + real f(klon), f0(klon) + real zlevinter(klon) + logical therm + logical first + data first /.false./ + save first +c$OMP THREADPRIVATE(first) +cRC + + character*2 str2 + character*10 str10 + +! LOGICAL vtest(klon),down + + EXTERNAL SCOPY + + integer ncorrec + save ncorrec + data ncorrec/0/ +c$OMP THREADPRIVATE(ncorrec) + +c +c----------------------------------------------------------------------- +c initialisation: +c --------------- +c + sorties=.true. + IF(ngrid.NE.klon) THEN + PRINT* + PRINT*,'STOP dans convadj' + PRINT*,'ngrid =',ngrid + PRINT*,'klon =',klon + ENDIF +c +c----------------------------------------------------------------------- +c incrementation eventuelle de tendances precedentes: +c --------------------------------------------------- + +c print*,'0 OK convect8' + + DO 1010 l=1,nlay + DO 1015 ig=1,ngrid + zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA + zh(ig,l)=pt(ig,l)/zpspsk(ig,l) + zu(ig,l)=pu(ig,l) + zv(ig,l)=pv(ig,l) + zo(ig,l)=po(ig,l) + ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l)) +1015 CONTINUE +1010 CONTINUE + +c print*,'1 OK convect8' +c -------------------- +c +c +c + + + + + + + + + + + +c +c +c wa, fraca, wd, fracd -------------------- zlev(2), rhobarz +c wh,wt,wo ... +c +c + + + + + + + + + + + zh,zu,zv,zo,rho +c +c +c -------------------- zlev(1) +c \\\\\\\\\\\\\\\\\\\\ +c +c + +c----------------------------------------------------------------------- +c Calcul des altitudes des couches +c----------------------------------------------------------------------- + + do l=2,nlay + do ig=1,ngrid + zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG + enddo + enddo + do ig=1,ngrid + zlev(ig,1)=0. + zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG + enddo + do l=1,nlay + do ig=1,ngrid + zlay(ig,l)=pphi(ig,l)/RG + enddo + enddo + +c print*,'2 OK convect8' +c----------------------------------------------------------------------- +c Calcul des densites +c----------------------------------------------------------------------- + + do l=1,nlay + do ig=1,ngrid + rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l)) + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1)) + enddo + enddo + + do k=1,nlay + do l=1,nlay+1 + do ig=1,ngrid + wa(ig,k,l)=0. + enddo + enddo + enddo + +c print*,'3 OK convect8' +c------------------------------------------------------------------ +c Calcul de w2, quarre de w a partir de la cape +c a partir de w2, on calcule wa, vitesse de l'ascendance +c +c ATTENTION: Dans cette version, pour cause d'economie de memoire, +c w2 est stoke dans wa +c +c ATTENTION: dans convect8, on n'utilise le calcule des wa +c independants par couches que pour calculer l'entrainement +c a la base et la hauteur max de l'ascendance. +c +c Indicages: +c l'ascendance provenant du niveau k traverse l'interface l avec +c une vitesse wa(k,l). +c +c -------------------- +c +c + + + + + + + + + + +c +c wa(k,l) ---- -------------------- l +c /\ +c /||\ + + + + + + + + + + +c || +c || -------------------- +c || +c || + + + + + + + + + + +c || +c || -------------------- +c ||__ +c |___ + + + + + + + + + + k +c +c -------------------- +c +c +c +c------------------------------------------------------------------ + +cCR: ponderation entrainement des couches instables +cdef des entr_star tels que entr=f*entr_star + do l=1,klev + do ig=1,ngrid + entr_star(ig,l)=0. + enddo + enddo +c determination de la longueur de la couche d entrainement + do ig=1,ngrid + lentr(ig)=1 + enddo + +con ne considere que les premieres couches instables + therm=.false. + do k=nlay-2,1,-1 + do ig=1,ngrid + if (ztv(ig,k).gt.ztv(ig,k+1).and. + s ztv(ig,k+1).le.ztv(ig,k+2)) then + lentr(ig)=k+1 + therm=.true. + endif + enddo + enddo +climitation de la valeur du lentr +c do ig=1,ngrid +c lentr(ig)=min(5,lentr(ig)) +c enddo +c determination du lmin: couche d ou provient le thermique + do ig=1,ngrid + lmin(ig)=1 + enddo + do ig=1,ngrid + do l=nlay,2,-1 + if (ztv(ig,l-1).gt.ztv(ig,l)) then + lmin(ig)=l-1 + endif + enddo + enddo +cinitialisations + do ig=1,ngrid + zalim(ig)=0. + norme(ig)=0. + lalim(ig)=1 + enddo + do k=1,klev-1 + do ig=1,ngrid + zalim(ig)=zalim(ig)+zlev(ig,k)*MAX(0.,(ztv(ig,k)-ztv(ig,k+1)) + s /(zlev(ig,k+1)-zlev(ig,k))) +c s *(zlev(ig,k+1)-zlev(ig,k)) + norme(ig)=norme(ig)+MAX(0.,(ztv(ig,k)-ztv(ig,k+1)) + s /(zlev(ig,k+1)-zlev(ig,k))) +c s *(zlev(ig,k+1)-zlev(ig,k)) + enddo + enddo + do ig=1,ngrid + if (norme(ig).gt.1.e-10) then + zalim(ig)=max(10.*zalim(ig)/norme(ig),zlev(ig,2)) +c zalim(ig)=min(zalim(ig),zlev(ig,lentr(ig))) + endif + enddo +cdétermination du lalim correspondant + do k=1,klev-1 + do ig=1,ngrid + if ((zalim(ig).gt.zlev(ig,k)).and.(zalim(ig).le.zlev(ig,k+1))) + s then + lalim(ig)=k + endif + enddo + enddo +c +c definition de l'entrainement des couches + do l=1,klev-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. + s l.ge.lmin(ig).and.l.lt.lentr(ig)) then + entr_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.) +c s *(zlev(ig,l+1)-zlev(ig,l)) + s *sqrt(zlev(ig,l+1)) +cautre def +c entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1) +c s /zlev(ig,lentr(ig)+2)))**(3./2.) + endif + enddo + enddo +cnouveau test +c if (therm) then + do l=1,klev-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. + s l.ge.lmin(ig).and.l.le.lalim(ig) + s .and.zalim(ig).gt.1.e-10) then +c if (l.le.lentr(ig)) then +c entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1) +c s /zalim(ig)))**(3./2.) +c write(10,*)zlev(ig,l),entr_star(ig,l) + endif + enddo + enddo +c endif +c pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.5) then + do l=1,klev + entr_star(ig,l)=0. + enddo + endif + enddo +c calcul de l entrainement total + do ig=1,ngrid + entr_star_tot(ig)=0. + enddo + do ig=1,ngrid + do k=1,klev + entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k) + enddo + enddo +c Calcul entrainement normalise + do ig=1,ngrid + if (entr_star_tot(ig).gt.1.e-10) then +c do l=1,lentr(ig) + do l=1,klev +cdef possibles pour entr_star: zdthetadz, dthetadz, zdtheta + entr_star(ig,l)=entr_star(ig,l)/entr_star_tot(ig) + enddo + endif + enddo +c +c print*,'fin calcul entr_star' + do k=1,klev + do ig=1,ngrid + ztva(ig,k)=ztv(ig,k) + enddo + enddo +cRC +c print*,'7 OK convect8' + do k=1,klev+1 + do ig=1,ngrid + zw2(ig,k)=0. + fmc(ig,k)=0. +cCR + f_star(ig,k)=0. +cRC + larg_cons(ig,k)=0. + larg_detr(ig,k)=0. + wa_moy(ig,k)=0. + enddo + enddo + +c print*,'8 OK convect8' + do ig=1,ngrid + linter(ig)=1. + lmaxa(ig)=1 + lmix(ig)=1 + wmaxa(ig)=0. + enddo + +cCR: + do l=1,nlay-2 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1) + s .and.entr_star(ig,l).gt.1.e-10 + s .and.zw2(ig,l).lt.1e-10) then + f_star(ig,l+1)=entr_star(ig,l) +ctest:calcul de dteta + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) + s *(zlev(ig,l+1)-zlev(ig,l)) + s *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + larg_detr(ig,l)=0. + else if ((zw2(ig,l).ge.1e-10).and. + s (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then + f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l) + ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l) + s *ztv(ig,l))/f_star(ig,l+1) + zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+ + s 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + endif +c determination de zmax continu par interpolation lineaire + if (zw2(ig,l+1).lt.0.) then +ctest + if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then +c print*,'pb linter' + endif + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) + s -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. + lmaxa(ig)=l + else + if (zw2(ig,l+1).lt.0.) then +c print*,'pb1 zw2<0' + endif + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + endif + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +c lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo +c print*,'fin calcul zw2' +c +c Calcul de la couche correspondant a la hauteur du thermique + do ig=1,ngrid + lmax(ig)=lentr(ig) +c lmax(ig)=lalim(ig) + enddo + do ig=1,ngrid + do l=nlay,lentr(ig)+1,-1 +c do l=nlay,lalim(ig)+1,-1 + if (zw2(ig,l).le.1.e-10) then + lmax(ig)=l-1 + endif + enddo + enddo +c pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.5) then + lmax(ig)=1 + lmin(ig)=1 + lentr(ig)=1 + lalim(ig)=1 + endif + enddo +c +c Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (zw2(ig,l).lt.0.)then +c print*,'pb2 zw2<0' + endif + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +c Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=0. + zlevinter(ig)=zlev(ig,1) + enddo + do ig=1,ngrid +c calcul de zlevinter + zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* + s linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) + s -zlev(ig,lmax(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + enddo + do ig=1,ngrid +c write(8,*)zmax(ig),lmax(ig),lentr(ig),lmin(ig) + enddo +con stoppe après les calculs de zmax et wmax + RETURN + +c print*,'avant fermeture' +c Fermeture,determination de f +cAttention! entrainement normalisé ou pas? + do ig=1,ngrid + entr_star2(ig)=0. + enddo + do ig=1,ngrid + if (entr_star_tot(ig).LT.1.e-10) then + f(ig)=0. + else + do k=lmin(ig),lentr(ig) +c do k=lmin(ig),lalim(ig) + entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2 + s /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))) + enddo +c Nouvelle fermeture + f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect + s *entr_star2(ig)) +c s *entr_star_tot(ig) +ctest +c if (first) then + f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig) + s *wmax(ig)) +c endif + endif + f0(ig)=f(ig) +c first=.true. + enddo +c print*,'apres fermeture' +con stoppe après la fermeture + RETURN +c Calcul de l'entrainement + do k=1,klev + do ig=1,ngrid + entr(ig,k)=f(ig)*entr_star(ig,k) + enddo + enddo +con stoppe après le calcul de entr +c RETURN +cCR:test pour entrainer moins que la masse +c do ig=1,ngrid +c do l=1,lentr(ig) +c if ((entr(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then +c entr(ig,l+1)=entr(ig,l+1)+entr(ig,l) +c s -0.9*masse(ig,l)/ptimestep +c entr(ig,l)=0.9*masse(ig,l)/ptimestep +c endif +c enddo +c enddo +cCR: fin test +c Calcul des flux + do ig=1,ngrid + do l=1,lmax(ig)-1 + fmc(ig,l+1)=fmc(ig,l)+entr(ig,l) + enddo + enddo + +cRC + + +c print*,'9 OK convect8' +c print*,'WA1 ',wa_moy + +c determination de l'indice du debut de la mixed layer ou w decroit + +c calcul de la largeur de chaque ascendance dans le cas conservatif. +c dans ce cas simple, on suppose que la largeur de l'ascendance provenant +c d'une couche est égale à la hauteur de la couche alimentante. +c La vitesse maximale dans l'ascendance est aussi prise comme estimation +c de la vitesse d'entrainement horizontal dans la couche alimentante. + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then + zw=max(wa_moy(ig,l),1.e-10) + larg_cons(ig,l)=zmax(ig)*r_aspect + s *fmc(ig,l)/(rhobarz(ig,l)*zw) + endif + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then +c if (idetr.eq.0) then +c cette option est finalement en dur. + if ((l_mix*zlev(ig,l)).lt.0.)then +c print*,'pb l_mix*zlev<0' + endif +cCR: test: nouvelle def de lambda +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + if (zw2(ig,l).gt.1.e-10) then + larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l)) + else + larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + endif +cRC +c else if (idetr.eq.1) then +c larg_detr(ig,l)=larg_cons(ig,l) +c s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) +c else if (idetr.eq.2) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *sqrt(wa_moy(ig,l)) +c else if (idetr.eq.4) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *wa_moy(ig,l) +c endif + endif + enddo + enddo + +c print*,'10 OK convect8' +c print*,'WA2 ',wa_moy +c calcul de la fraction de la maille concernée par l'ascendance en tenant +c compte de l'epluchage du thermique. +c +cCR def de zmix continu (profil parabolique des vitesses) + do ig=1,ngrid + if (lmix(ig).gt.1.) then +c test + if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10) + s then +c + zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2)) + s /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + else + zmix(ig)=zlev(ig,lmix(ig)) +c print*,'pb zmix' + endif + else + zmix(ig)=0. + endif +ctest + if ((zmax(ig)-zmix(ig)).lt.0.) then + zmix(ig)=0.99*zmax(ig) +c print*,'pb zmix>zmax' + endif + enddo +c +c calcul du nouveau lmix correspondant + do ig=1,ngrid + do l=1,klev + if (zmix(ig).ge.zlev(ig,l).and. + s zmix(ig).lt.zlev(ig,l+1)) then + lmix(ig)=l + endif + enddo + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then +c print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l)) + s /(r_aspect*zmax(ig)) +c test + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + else +c wa_moy(ig,l)=0. + fraca(ig,l)=0. + fracc(ig,l)=0. + fracd(ig,l)=1. + endif + enddo + enddo +cCR: calcul de fracazmix + do ig=1,ngrid + fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ + s (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + s +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1) + s -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then + if (l.gt.lmix(ig)) then +ctest + if (zmax(ig)-zmix(ig).lt.1.e-10) then +c print*,'pb xxx' + xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig)) + else + xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) + endif + if (idetr.eq.0) then + fraca(ig,l)=fracazmix(ig) + else if (idetr.eq.1) then + fraca(ig,l)=fracazmix(ig)*xxx(ig,l) + else if (idetr.eq.2) then + fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) + else + fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2 + endif +c print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + endif + endif + enddo + enddo + +c print*,'fin calcul fraca' +c print*,'11 OK convect8' +c print*,'Ea3 ',wa_moy +c------------------------------------------------------------------ +c Calcul de fracd, wd +c somme wa - wd = 0 +c------------------------------------------------------------------ + + + do ig=1,ngrid + fm(ig,1)=0. + fm(ig,nlay+1)=0. + enddo + + do l=2,nlay + do ig=1,ngrid + fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l) +cCR:test + if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1) + s .and.l.gt.lmix(ig)) then + fm(ig,l)=fm(ig,l-1) +c write(1,*)'ajustement fm, l',l + endif +c write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) +cRC + enddo + do ig=1,ngrid + if(fracd(ig,l).lt.0.1) then + stop'fracd trop petit' + else +c vitesse descendante "diagnostique" + wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l)) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid +c masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG + enddo + enddo + +c print*,'12 OK convect8' +c print*,'WA4 ',wa_moy +cc------------------------------------------------------------------ +c calcul du transport vertical +c------------------------------------------------------------------ + + go to 4444 +c print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + do l=2,nlay-1 + do ig=1,ngrid + if(fm(ig,l+1)*ptimestep.gt.masse(ig,l) + s .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then +c print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' +c s ,fm(ig,l+1)*ptimestep +c s ,' M=',masse(ig,l),masse(ig,l+1) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then +c print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' +c s ,entr(ig,l)*ptimestep +c s ,' M=',masse(ig,l) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then +c print*,'WARN!!! fm exagere ig=',ig,' l=',l +c s ,' FM=',fm(ig,l) + endif + if(.not.masse(ig,l).ge.1.e-10 + s .or..not.masse(ig,l).le.1.e4) then +c print*,'WARN!!! masse exagere ig=',ig,' l=',l +c s ,' M=',masse(ig,l) +c print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', +c s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) +c print*,'zlev(ig,l+1),zlev(ig,l)' +c s ,zlev(ig,l+1),zlev(ig,l) +c print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' +c s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + endif + if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then +c print*,'WARN!!! entr exagere ig=',ig,' l=',l +c s ,' E=',entr(ig,l) + endif + enddo + enddo + +4444 continue + +cCR:redefinition du entr + do l=1,nlay + do ig=1,ngrid + detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) + if (detr(ig,l).lt.0.) then +c entr(ig,l)=entr(ig,l)-detr(ig,l) + fm(ig,l+1)=fm(ig,l)+entr(ig,l) + detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l + endif + enddo + enddo +cRC + if (w2di.eq.1) then + fm0=fm0+ptimestep*(fm-fm0)/float(tho) + entr0=entr0+ptimestep*(entr-entr0)/float(tho) + else + fm0=fm + entr0=entr + endif + + if (1.eq.1) then + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zh,zdhadj,zha) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zo,pdoadj,zoa) + else + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zh,zdhadj,zha) + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zo,pdoadj,zoa) + endif + + if (1.eq.0) then + call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,fraca,zmax + . ,zu,zv,pduadj,pdvadj,zua,zva) + else + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zu,pduadj,zua) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zv,pdvadj,zva) + endif + + do l=1,nlay + do ig=1,ngrid + zf=0.5*(fracc(ig,l)+fracc(ig,l+1)) + zf2=zf/(1.-zf) + thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2 + wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 + enddo + enddo + + + +c print*,'13 OK convect8' +c print*,'WA5 ',wa_moy + do l=1,nlay + do ig=1,ngrid + pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l) + enddo + enddo + + +c do l=1,nlay +c do ig=1,ngrid +c if(abs(pdtadj(ig,l))*86400..gt.500.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdtadj=',pdtadj(ig,l) +c endif +c if(abs(pdoadj(ig,l))*86400..gt.1.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdoadj=',pdoadj(ig,l) +c endif +c enddo +c enddo + +c print*,'14 OK convect8' +c------------------------------------------------------------------ +c Calculs pour les sorties +c------------------------------------------------------------------ + + if(sorties) then + do l=1,nlay + do ig=1,ngrid + zla(ig,l)=(1.-fracd(ig,l))*zmax(ig) + zld(ig,l)=fracd(ig,l)*zmax(ig) + if(1.-fracd(ig,l).gt.1.e-10) + s zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l)) + enddo + enddo + +cdeja fait +c do l=1,nlay +c do ig=1,ngrid +c detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) +c if (detr(ig,l).lt.0.) then +c entr(ig,l)=entr(ig,l)-detr(ig,l) +c detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l +c endif +c enddo +c enddo + +c print*,'15 OK convect8' + + isplit=isplit+1 + + +c #define und + goto 123 +#ifdef und + CALL writeg1d(1,nlay,wd,'wd ','wd ') + CALL writeg1d(1,nlay,zwa,'wa ','wa ') + CALL writeg1d(1,nlay,fracd,'fracd ','fracd ') + CALL writeg1d(1,nlay,fraca,'fraca ','fraca ') + CALL writeg1d(1,nlay,wa_moy,'wam ','wam ') + CALL writeg1d(1,nlay,zla,'la ','la ') + CALL writeg1d(1,nlay,zld,'ld ','ld ') + CALL writeg1d(1,nlay,pt,'pt ','pt ') + CALL writeg1d(1,nlay,zh,'zh ','zh ') + CALL writeg1d(1,nlay,zha,'zha ','zha ') + CALL writeg1d(1,nlay,zu,'zu ','zu ') + CALL writeg1d(1,nlay,zv,'zv ','zv ') + CALL writeg1d(1,nlay,zo,'zo ','zo ') + CALL writeg1d(1,nlay,wh,'wh ','wh ') + CALL writeg1d(1,nlay,wu,'wu ','wu ') + CALL writeg1d(1,nlay,wv,'wv ','wv ') + CALL writeg1d(1,nlay,wo,'w15uo ','wXo ') + CALL writeg1d(1,nlay,zdhadj,'zdhadj ','zdhadj ') + CALL writeg1d(1,nlay,pduadj,'pduadj ','pduadj ') + CALL writeg1d(1,nlay,pdvadj,'pdvadj ','pdvadj ') + CALL writeg1d(1,nlay,pdoadj,'pdoadj ','pdoadj ') + CALL writeg1d(1,nlay,entr ,'entr ','entr ') + CALL writeg1d(1,nlay,detr ,'detr ','detr ') + CALL writeg1d(1,nlay,fm ,'fm ','fm ') + + CALL writeg1d(1,nlay,pdtadj,'pdtadj ','pdtadj ') + CALL writeg1d(1,nlay,pplay,'pplay ','pplay ') + CALL writeg1d(1,nlay,pplev,'pplev ','pplev ') + +c recalcul des flux en diagnostique... +c print*,'PAS DE TEMPS ',ptimestep + call dt2F(pplev,pplay,pt,pdtadj,wh) + CALL writeg1d(1,nlay,wh,'wh2 ','wh2 ') +#endif +123 continue +#define troisD +#ifdef troisD +c if (sorties) then +c print*,'Debut des wrgradsfi' + +c print*,'16 OK convect8' + call wrgradsfi(1,nlay,wd,'wd ','wd ') + call wrgradsfi(1,nlay,zwa,'wa ','wa ') + call wrgradsfi(1,nlay,fracd,'fracd ','fracd ') + call wrgradsfi(1,nlay,fraca,'fraca ','fraca ') + call wrgradsfi(1,nlay,xxx,'xxx ','xxx ') + call wrgradsfi(1,nlay,wa_moy,'wam ','wam ') +c print*,'WA6 ',wa_moy + call wrgradsfi(1,nlay,zla,'la ','la ') + call wrgradsfi(1,nlay,zld,'ld ','ld ') + call wrgradsfi(1,nlay,pt,'pt ','pt ') + call wrgradsfi(1,nlay,zh,'zh ','zh ') + call wrgradsfi(1,nlay,zha,'zha ','zha ') + call wrgradsfi(1,nlay,zua,'zua ','zua ') + call wrgradsfi(1,nlay,zva,'zva ','zva ') + call wrgradsfi(1,nlay,zu,'zu ','zu ') + call wrgradsfi(1,nlay,zv,'zv ','zv ') + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,wh,'wh ','wh ') + call wrgradsfi(1,nlay,wu,'wu ','wu ') + call wrgradsfi(1,nlay,wv,'wv ','wv ') + call wrgradsfi(1,nlay,wo,'wo ','wo ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,nlay,zdhadj,'zdhadj ','zdhadj ') + call wrgradsfi(1,nlay,pduadj,'pduadj ','pduadj ') + call wrgradsfi(1,nlay,pdvadj,'pdvadj ','pdvadj ') + call wrgradsfi(1,nlay,pdoadj,'pdoadj ','pdoadj ') + call wrgradsfi(1,nlay,entr,'entr ','entr ') + call wrgradsfi(1,nlay,detr,'detr ','detr ') + call wrgradsfi(1,nlay,fm,'fm ','fm ') + call wrgradsfi(1,nlay,fmc,'fmc ','fmc ') + call wrgradsfi(1,nlay,zw2,'zw2 ','zw2 ') + call wrgradsfi(1,nlay,ztva,'ztva ','ztva ') + call wrgradsfi(1,nlay,ztv,'ztv ','ztv ') + + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,larg_cons,'Lc ','Lc ') + call wrgradsfi(1,nlay,larg_detr,'Ldetr ','Ldetr ') + +cCR:nouveaux diagnostiques + call wrgradsfi(1,nlay,entr_star ,'entr_star ','entr_star ') + call wrgradsfi(1,nlay,f_star ,'f_star ','f_star ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,1,zmix,'zmix ','zmix ') + zsortie1d(:)=lmax(:) + call wrgradsfi(1,1,zsortie1d,'lmax ','lmax ') + call wrgradsfi(1,1,wmax,'wmax ','wmax ') + zsortie1d(:)=lmix(:) + call wrgradsfi(1,1,zsortie1d,'lmix ','lmix ') + zsortie1d(:)=lentr(:) + call wrgradsfi(1,1,zsortie1d,'lentr ','lentr ') + +c print*,'17 OK convect8' + + do k=1,klev/10 + write(str2,'(i2.2)') k + str10='wa'//str2 + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=wa(ig,k,l) + enddo + enddo + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=larg_part(ig,k,l) + enddo + enddo + str10='la'//str2 + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + enddo + + +c print*,'18 OK convect8' +c endif +c print*,'Fin des wrgradsfi' +#endif + + endif + +c if(wa_moy(1,4).gt.1.e-10) stop + +c print*,'19 OK convect8' + return + end + + SUBROUTINE fermeture_seche(ngrid,nlay + s ,pplay,pplev,pphi,zlev,rhobarz,f0,zpspsk + s ,alim_star,zh,zo,lentr,lmin,nu_min,nu_max,r_aspect + s ,zmax,wmax) + + USE dimphy + IMPLICIT NONE + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" + + INTEGER ngrid,nlay + REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1) + real pphi(ngrid,nlay) + real zlev(klon,klev+1) + real alim_star(klon,klev) + real f0(klon) + integer lentr(klon) + integer lmin(klon) + real zmax(klon) + real wmax(klon) + real nu_min + real nu_max + real r_aspect + real rhobarz(klon,klev+1) + REAL zh(klon,klev) + real zo(klon,klev) + real zpspsk(klon,klev) + + integer ig,l + + real f_star(klon,klev+1) + real detr_star(klon,klev) + real entr_star(klon,klev) + real zw2(klon,klev+1) + real linter(klon) + integer lmix(klon) + integer lmax(klon) + real zlevinter(klon) + real wa_moy(klon,klev+1) + real wmaxa(klon) + REAL ztv(klon,klev) + REAL ztva(klon,klev) + real nu(klon,klev) +! real zmax0_sec(klon) +! save zmax0_sec + REAL, SAVE, ALLOCATABLE :: zmax0_sec(:) +c$OMP THREADPRIVATE(zmax0_sec) + logical, save :: first = .true. +c$OMP THREADPRIVATE(first) + + if (first) then + allocate(zmax0_sec(klon)) + first=.false. + endif + + do l=1,nlay + do ig=1,ngrid + ztv(ig,l)=zh(ig,l)/zpspsk(ig,l) + ztv(ig,l)=ztv(ig,l)*(1.+RETV*zo(ig,l)) + enddo + enddo + do l=1,nlay-2 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1) + s .and.alim_star(ig,l).gt.1.e-10 + s .and.zw2(ig,l).lt.1e-10) then + f_star(ig,l+1)=alim_star(ig,l) +ctest:calcul de dteta + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) + s *(zlev(ig,l+1)-zlev(ig,l)) + s *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + else if ((zw2(ig,l).ge.1e-10).and. + s (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then +cestimation du detrainement a partir de la geometrie du pas precedent +ctests sur la definition du detr + nu(ig,l)=(nu_min+nu_max)/2. + s *(1.-(nu_max-nu_min)/(nu_max+nu_min) + s *tanh((((ztva(ig,l-1)-ztv(ig,l))/ztv(ig,l))/0.0005))) + + detr_star(ig,l)=rhobarz(ig,l) + s *sqrt(zw2(ig,l)) + s /(r_aspect*zmax0_sec(ig))* +c s /(r_aspect*zmax0(ig))* + s (sqrt(nu(ig,l)*zlev(ig,l+1) + s /sqrt(zw2(ig,l))) + s -sqrt(nu(ig,l)*zlev(ig,l) + s /sqrt(zw2(ig,l)))) + detr_star(ig,l)=detr_star(ig,l)/f0(ig) + if ((detr_star(ig,l)).gt.f_star(ig,l)) then + detr_star(ig,l)=f_star(ig,l) + endif + entr_star(ig,l)=0.9*detr_star(ig,l) + if ((l.lt.lentr(ig))) then + entr_star(ig,l)=0. +c detr_star(ig,l)=0. + endif +c print*,'ok detr_star' +cprise en compte du detrainement dans le calcul du flux + f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l) + s -detr_star(ig,l) +ctest sur le signe de f_star + if ((f_star(ig,l+1)+detr_star(ig,l)).gt.1.e-10) then +cAM on melange Tl et qt du thermique + ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+(entr_star(ig,l) + s +alim_star(ig,l)) + s *ztv(ig,l))/(f_star(ig,l+1)+detr_star(ig,l)) + zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l) + s /(f_star(ig,l+1)+detr_star(ig,l)))**2+ + s 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + endif + endif +c + if (zw2(ig,l+1).lt.0.) then + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) + s -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. +c print*,'linter=',linter(ig) + else + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + endif + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +c lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo +c print*,'fin calcul zw2' +c +c Calcul de la couche correspondant a la hauteur du thermique + do ig=1,ngrid + lmax(ig)=lentr(ig) + enddo + do ig=1,ngrid + do l=nlay,lentr(ig)+1,-1 + if (zw2(ig,l).le.1.e-10) then + lmax(ig)=l-1 + endif + enddo + enddo +c pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.1) then + lmax(ig)=1 + lmin(ig)=1 + lentr(ig)=1 + endif + enddo +c +c Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (zw2(ig,l).lt.0.)then +c print*,'pb2 zw2<0' + endif + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +c Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=0. + zlevinter(ig)=zlev(ig,1) + enddo + do ig=1,ngrid +c calcul de zlevinter + zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* + s linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) + s -zlev(ig,lmax(ig))) +cpour le cas ou on prend tjs lmin=1 +c zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1)) + zmax0_sec(ig)=zmax(ig) + enddo + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell.h (revision 1280) @@ -0,0 +1,15 @@ + integer :: iflag_thermals,nsplit_thermals + real,parameter :: r_aspect_thermals=2.,l_mix_thermals=30. + real :: tau_thermals + integer,parameter :: w2di_thermals=1 + integer :: isplit + + integer :: iflag_coupl,iflag_clos,iflag_wake + integer :: iflag_thermals_ed,iflag_thermals_optflux + + common/ctherm1/iflag_thermals,nsplit_thermals + common/ctherm2/tau_thermals + common/ctherm4/iflag_coupl,iflag_clos,iflag_wake + common/ctherm5/iflag_thermals_ed,iflag_thermals_optflux + +!$OMP THREADPRIVATE(/ctherm1/,/ctherm2/,/ctherm4/,/ctherm5/) Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_closure.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_closure.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_closure.F90 (revision 1280) @@ -0,0 +1,71 @@ + SUBROUTINE thermcell_closure(ngrid,nlay,r_aspect,ptimestep,rho, & + & zlev,lalim,alim_star,alim_star_tot,zmax_sec,wmax_sec,zmax,wmax,f,lev_out) + +!------------------------------------------------------------------------- +!thermcell_closure: fermeture, determination de f +!------------------------------------------------------------------------- + IMPLICIT NONE + +#include "iniprint.h" +#include "thermcell.h" + INTEGER ngrid,nlay + INTEGER ig,k + REAL r_aspect,ptimestep + integer lev_out ! niveau pour les print + + INTEGER lalim(ngrid) + REAL alim_star(ngrid,nlay) + REAL alim_star_tot(ngrid) + REAL rho(ngrid,nlay) + REAL zlev(ngrid,nlay) + REAL zmax(ngrid),zmax_sec(ngrid) + REAL wmax(ngrid),wmax_sec(ngrid) + real zdenom + + REAL alim_star2(ngrid) + + REAL f(ngrid) + + do ig=1,ngrid + alim_star2(ig)=0. + enddo + do ig=1,ngrid + if (alim_star(ig,1).LT.1.e-10) then + f(ig)=0. + else + do k=1,lalim(ig) + alim_star2(ig)=alim_star2(ig)+alim_star(ig,k)**2 & + & /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))) + enddo + zdenom=max(500.,zmax(ig))*r_aspect*alim_star2(ig) + if (zdenom<1.e-14) then + print*,'ig=',ig + print*,'alim_star2',alim_star2(ig) + print*,'zmax',zmax(ig) + print*,'r_aspect',r_aspect + print*,'zdenom',zdenom + print*,'alim_star',alim_star(ig,:) + print*,'zmax_sec',zmax_sec(ig) + print*,'wmax_sec',wmax_sec(ig) + stop + endif + if ((zmax_sec(ig).gt.1.e-10).and.(iflag_thermals_ed.eq.0)) then + f(ig)=wmax_sec(ig)*alim_star_tot(ig)/(max(500.,zmax_sec(ig))*r_aspect & + & *alim_star2(ig)) +! f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/ & +! & zmax_sec(ig))*wmax_sec(ig)) + if(prt_level.GE.10) write(lunout,*)'closure dry',f(ig),wmax_sec(ig),alim_star_tot(ig),zmax_sec(ig) + else + f(ig)=wmax(ig)*alim_star_tot(ig)/zdenom +! f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/ & +! & zmax(ig))*wmax(ig)) + if(prt_level.GE.10) print*,'closure moist',f(ig),wmax(ig),alim_star_tot(ig),zmax(ig) + endif + endif +! f0(ig)=f(ig) + enddo + if (prt_level.ge.1) print*,'apres fermeture' + +! + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_dq.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_dq.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_dq.F90 (revision 1280) @@ -0,0 +1,169 @@ + subroutine thermcell_dq(ngrid,nlay,ptimestep,fm,entr, & + & masse,q,dq,qa,lev_out) + implicit none + +#include "iniprint.h" +!======================================================================= +! +! Calcul du transport verticale dans la couche limite en presence +! de "thermiques" explicitement representes +! calcul du dq/dt une fois qu'on connait les ascendances +! +!======================================================================= + + integer ngrid,nlay + + real ptimestep + real masse(ngrid,nlay),fm(ngrid,nlay+1) + real entr(ngrid,nlay) + real q(ngrid,nlay) + real dq(ngrid,nlay) + integer lev_out ! niveau pour les print + + real qa(ngrid,nlay),detr(ngrid,nlay),wqd(ngrid,nlay+1) + + real zzm + + integer ig,k + real cfl + + real qold(ngrid,nlay) + real ztimestep + integer niter,iter + + + +! Calcul du critere CFL pour l'advection dans la subsidence + cfl = 0. + do k=1,nlay + do ig=1,ngrid + zzm=masse(ig,k)/ptimestep + cfl=max(cfl,fm(ig,k)/zzm) + if (entr(ig,k).gt.zzm) then + print*,'entr dt > m ',entr(ig,k)*ptimestep,masse(ig,k) + stop + endif + enddo + enddo + +!IM 090508 print*,'CFL CFL CFL CFL ',cfl + +#undef CFL +#ifdef CFL +! On subdivise le calcul en niter pas de temps. + niter=int(cfl)+1 +#else + niter=1 +#endif + + ztimestep=ptimestep/niter + qold=q + + +do iter=1,niter + if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0' + +! calcul du detrainement + do k=1,nlay + do ig=1,ngrid + detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) +! print*,'Q2 DQ ',detr(ig,k),fm(ig,k),entr(ig,k) +!test + if (detr(ig,k).lt.0.) then + entr(ig,k)=entr(ig,k)-detr(ig,k) + detr(ig,k)=0. +! print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k), +! s 'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k) + endif + if (fm(ig,k+1).lt.0.) then +! print*,'fm2<0!!!' + endif + if (entr(ig,k).lt.0.) then +! print*,'entr2<0!!!' + endif + enddo + enddo + +! calcul de la valeur dans les ascendances + do ig=1,ngrid + qa(ig,1)=q(ig,1) + enddo + + do k=2,nlay + do ig=1,ngrid + if ((fm(ig,k+1)+detr(ig,k))*ztimestep.gt. & + & 1.e-5*masse(ig,k)) then + qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k)) & + & /(fm(ig,k+1)+detr(ig,k)) + else + qa(ig,k)=q(ig,k) + endif + if (qa(ig,k).lt.0.) then +! print*,'qa<0!!!' + endif + if (q(ig,k).lt.0.) then +! print*,'q<0!!!' + endif + enddo + enddo + +! Calcul du flux subsident + + do k=2,nlay + do ig=1,ngrid +#undef centre +#ifdef centre + wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k)) +#else + +#define plusqueun +#ifdef plusqueun +! Schema avec advection sur plus qu'une maille. + zzm=masse(ig,k)/ztimestep + if (fm(ig,k)>zzm) then + wqd(ig,k)=zzm*q(ig,k)+(fm(ig,k)-zzm)*q(ig,k+1) + else + wqd(ig,k)=fm(ig,k)*q(ig,k) + endif +#else + wqd(ig,k)=fm(ig,k)*q(ig,k) +#endif +#endif + + if (wqd(ig,k).lt.0.) then +! print*,'wqd<0!!!' + endif + enddo + enddo + do ig=1,ngrid + wqd(ig,1)=0. + wqd(ig,nlay+1)=0. + enddo + + +! Calcul des tendances + do k=1,nlay + do ig=1,ngrid + q(ig,k)=q(ig,k)+(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k) & + & -wqd(ig,k)+wqd(ig,k+1)) & + & *ztimestep/masse(ig,k) +! if (dq(ig,k).lt.0.) then +! print*,'dq<0!!!' +! endif + enddo + enddo + + +enddo + + +! Calcul des tendances + do k=1,nlay + do ig=1,ngrid + dq(ig,k)=(q(ig,k)-qold(ig,k))/ptimestep + q(ig,k)=qold(ig,k) + enddo + enddo + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_dry.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_dry.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_dry.F90 (revision 1280) @@ -0,0 +1,212 @@ + SUBROUTINE thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star, & + & lalim,lmin,zmax,wmax,lev_out) + +!-------------------------------------------------------------------------- +!thermcell_dry: calcul de zmax et wmax du thermique sec +!-------------------------------------------------------------------------- + IMPLICIT NONE +#include "YOMCST.h" +#include "iniprint.h" + INTEGER l,ig + + INTEGER ngrid,nlay + REAL zlev(ngrid,nlay+1) + REAL pphi(ngrid,nlay) + REAl ztv(ngrid,nlay) + REAL alim_star(ngrid,nlay) + INTEGER lalim(ngrid) + integer lev_out ! niveau pour les print + + REAL zmax(ngrid) + REAL wmax(ngrid) + +!variables locales + REAL zw2(ngrid,nlay+1) + REAL f_star(ngrid,nlay+1) + REAL ztva(ngrid,nlay+1) + REAL wmaxa(ngrid) + REAL wa_moy(ngrid,nlay+1) + REAL linter(ngrid),zlevinter(ngrid) + INTEGER lmix(ngrid),lmax(ngrid),lmin(ngrid) + +!initialisations + do ig=1,ngrid + do l=1,nlay+1 + zw2(ig,l)=0. + wa_moy(ig,l)=0. + enddo + enddo + do ig=1,ngrid + do l=1,nlay + ztva(ig,l)=ztv(ig,l) + enddo + enddo + do ig=1,ngrid + wmax(ig)=0. + wmaxa(ig)=0. + enddo +!calcul de la vitesse a partir de la CAPE en melangeant thetav + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! A eliminer +! Ce if complique etait fait pour reperer la premiere couche instable +! Ici, c'est lmin. +! +! do l=1,nlay-2 +! do ig=1,ngrid +! if (ztv(ig,l).gt.ztv(ig,l+1) & +! & .and.alim_star(ig,l).gt.1.e-10 & +! & .and.zw2(ig,l).lt.1e-10) then +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + +! Calcul des F^*, integrale verticale de E^* + f_star(:,1)=0. + do l=1,nlay + f_star(:,l+1)=f_star(:,l)+alim_star(:,l) + enddo + +! niveau (reel) auquel zw2 s'annule FH :n'etait pas initialise + linter(:)=0. + +! couche la plus haute concernee par le thermique. + lmax(:)=1 + +! Le niveau linter est une variable continue qui se trouve dans la couche +! lmax + + do l=1,nlay-2 + do ig=1,ngrid + if (l.eq.lmin(ig).and.lalim(ig).gt.1) then + +!------------------------------------------------------------------------ +! Calcul de la vitesse en haut de la premiere couche instable. +! Premiere couche du panache thermique +!------------------------------------------------------------------------ + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) & + & *(zlev(ig,l+1)-zlev(ig,l)) & + & *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + +!------------------------------------------------------------------------ +! Tant que la vitesse en bas de la couche et la somme du flux de masse +! et de l'entrainement (c'est a dire le flux de masse en haut) sont +! positifs, on calcul +! 1. le flux de masse en haut f_star(ig,l+1) +! 2. la temperature potentielle virtuelle dans la couche ztva(ig,l) +! 3. la vitesse au carré en haut zw2(ig,l+1) +!------------------------------------------------------------------------ + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! A eliminer : dans cette version, si zw2 est > 0 on a un therique. +! et donc, au dessus, f_star(ig,l+1) est forcement suffisamment +! grand puisque on n'a pas de detrainement. +! f_star est une fonction croissante. +! c'est donc vraiment sur zw2 uniquement qu'il faut faire le test. +! else if ((zw2(ig,l).ge.1e-10).and. & +! & (f_star(ig,l)+alim_star(ig,l).gt.1.e-10)) then +! f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + else if (zw2(ig,l).ge.1e-10) then + + ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+alim_star(ig,l) & + & *ztv(ig,l))/f_star(ig,l+1) + zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+ & + & 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) & + & *(zlev(ig,l+1)-zlev(ig,l)) + endif +! determination de zmax continu par interpolation lineaire +!------------------------------------------------------------------------ + + if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then +! stop'On tombe sur le cas particulier de thermcell_dry' +! print*,'On tombe sur le cas particulier de thermcell_dry' + zw2(ig,l+1)=0. + linter(ig)=l+1 + lmax(ig)=l + endif + + if (zw2(ig,l+1).lt.0.) then + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) & + & -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. + lmax(ig)=l + endif + + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +! lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo + if (prt_level.ge.1) print*,'fin calcul zw2' +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! A eliminer : +! Ce calcul de lmax est fait en meme temps que celui de linter, plus haut +! Calcul de la couche correspondant a la hauteur du thermique +! do ig=1,ngrid +! lmax(ig)=lalim(ig) +! enddo +! do ig=1,ngrid +! do l=nlay,lalim(ig)+1,-1 +! if (zw2(ig,l).le.1.e-10) then +! lmax(ig)=l-1 +! endif +! enddo +! enddo +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! +! Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +! Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=0. + zlevinter(ig)=zlev(ig,1) + enddo + do ig=1,ngrid +! calcul de zlevinter + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH A eliminer +! Simplification +! zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* & +! & linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) & +! & -zlev(ig,lmax(ig))) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + zlevinter(ig)=zlev(ig,lmax(ig)) + & + & (linter(ig)-lmax(ig))*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + enddo + +! Verification que lalim<=lmax + do ig=1,ngrid + if(lalim(ig)>lmax(ig)) then + if ( prt_level > 1 ) THEN + print*,'WARNING thermcell_dry ig=',ig,' lalim=',lalim(ig),' lmax(ig)=',lmax(ig) + endif + lmax(ig)=lalim(ig) + endif + enddo + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_dv2.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_dv2.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_dv2.F90 (revision 1280) @@ -0,0 +1,155 @@ + subroutine thermcell_dv2(ngrid,nlay,ptimestep,fm,entr,masse & + & ,fraca,larga & + & ,u,v,du,dv,ua,va,lev_out) + implicit none + +#include "iniprint.h" +!======================================================================= +! +! Calcul du transport verticale dans la couche limite en presence +! de "thermiques" explicitement representes +! calcul du dq/dt une fois qu'on connait les ascendances +! +!======================================================================= + + + integer ngrid,nlay + + real ptimestep + real masse(ngrid,nlay),fm(ngrid,nlay+1) + real fraca(ngrid,nlay+1) + real larga(ngrid) + real entr(ngrid,nlay) + real u(ngrid,nlay) + real ua(ngrid,nlay) + real du(ngrid,nlay) + real v(ngrid,nlay) + real va(ngrid,nlay) + real dv(ngrid,nlay) + integer lev_out ! niveau pour les print + + real qa(ngrid,nlay),detr(ngrid,nlay),zf,zf2 + real wvd(ngrid,nlay+1),wud(ngrid,nlay+1) + real gamma0,gamma(ngrid,nlay+1) + real ue(ngrid,nlay),ve(ngrid,nlay) + real dua,dva + integer iter + + integer ig,k + +! calcul du detrainement + + do k=1,nlay + do ig=1,ngrid + detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) + enddo + enddo + +! calcul de la valeur dans les ascendances + do ig=1,ngrid + ua(ig,1)=u(ig,1) + va(ig,1)=v(ig,1) + ue(ig,1)=u(ig,1) + ve(ig,1)=v(ig,1) + enddo + + IF(prt_level>9)WRITE(lunout,*) & + & 'WARNING on initialise gamma(1:ngrid,1)=0.' + gamma(1:ngrid,1)=0. + do k=2,nlay + do ig=1,ngrid + if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt. & + & 1.e-5*masse(ig,k)) then +! On itère sur la valeur du coeff de freinage. +! gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)) +!IM 060508 beg +! if(0.5*(fraca(ig,k+1)+fraca(ig,k)).LT.0.) THEN +! print*,'th_dv2 ig k fraca(:,k) fraca(:k+1)', & +! & ig,k,fraca(ig,k),fraca(ig,k+1) +! endif +! if(larga(ig).EQ.0.) THEN +! print*,'th_dv2 ig larga=0.',ig +! endif + if(larga(ig).GT.0.) THEN +!IM 060508 end + gamma0=masse(ig,k) & + & *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) ) & + & *0.5/larga(ig) & + & *1. +!IM 060508 beg + else + if(prt_level.GE.10) print*,'WARNING cas ELSE on initialise gamma0=0.' + gamma0=0. + endif !(larga(ig).GT.0.) THEN +!IM 060508 end +! s *0.5 +! gamma0=0. + zf=0.5*(fraca(ig,k)+fraca(ig,k+1)) + zf=0. + zf2=1./(1.-zf) +! la première fois on multiplie le coefficient de freinage +! par le module du vent dans la couche en dessous. + dua=ua(ig,k-1)-u(ig,k-1) + dva=va(ig,k-1)-v(ig,k-1) + do iter=1,5 +! On choisit une relaxation lineaire. + gamma(ig,k)=gamma0 +! On choisit une relaxation quadratique. + gamma(ig,k)=gamma0*sqrt(dua**2+dva**2) + ua(ig,k)=(fm(ig,k)*ua(ig,k-1) & + & +(zf2*entr(ig,k)+gamma(ig,k))*u(ig,k)) & + & /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2 & + & +gamma(ig,k)) + va(ig,k)=(fm(ig,k)*va(ig,k-1) & + & +(zf2*entr(ig,k)+gamma(ig,k))*v(ig,k)) & + & /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2 & + & +gamma(ig,k)) +! print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva + dua=ua(ig,k)-u(ig,k) + dva=va(ig,k)-v(ig,k) + ue(ig,k)=(u(ig,k)-zf*ua(ig,k))*zf2 + ve(ig,k)=(v(ig,k)-zf*va(ig,k))*zf2 + enddo + else + ua(ig,k)=u(ig,k) + va(ig,k)=v(ig,k) + ue(ig,k)=u(ig,k) + ve(ig,k)=v(ig,k) + gamma(ig,k)=0. + endif + enddo + enddo + + do k=2,nlay + do ig=1,ngrid + wud(ig,k)=fm(ig,k)*ue(ig,k) + wvd(ig,k)=fm(ig,k)*ve(ig,k) + enddo + enddo + do ig=1,ngrid + wud(ig,1)=0. + wud(ig,nlay+1)=0. + wvd(ig,1)=0. + wvd(ig,nlay+1)=0. + enddo + + do k=1,nlay + do ig=1,ngrid +!IM + if(prt_level.GE.10) print*,'th_dv2 ig k gamma entr detr ua ue va ve wud wvd masse',ig,k,gamma(ig,k), & + & entr(ig,k),detr(ig,k),ua(ig,k),ue(ig,k),va(ig,k),ve(ig,k),wud(ig,k),wvd(ig,k),wud(ig,k+1),wvd(ig,k+1), & + & masse(ig,k) +! + du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k) & + & -(entr(ig,k)+gamma(ig,k))*ue(ig,k) & + & -wud(ig,k)+wud(ig,k+1)) & + & /masse(ig,k) + dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k) & + & -(entr(ig,k)+gamma(ig,k))*ve(ig,k) & + & -wvd(ig,k)+wvd(ig,k+1)) & + & /masse(ig,k) + enddo + enddo + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_env.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_env.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_env.F90 (revision 1280) @@ -0,0 +1,139 @@ + SUBROUTINE thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay, & + & pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,zqsat,lev_out) + +!-------------------------------------------------------------- +!thermcell_env: calcule les caracteristiques de l environnement +!necessaires au calcul des proprietes dans le thermique +!-------------------------------------------------------------- + + IMPLICIT NONE + +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +#include "iniprint.h" + + INTEGER ngrid,nlay + REAL po(ngrid,nlay) + REAL pt(ngrid,nlay) + REAL pu(ngrid,nlay) + REAL pv(ngrid,nlay) + REAL pplay(ngrid,nlay) + REAL pplev(ngrid,nlay+1) + integer lev_out ! niveau pour les print + + REAL zo(ngrid,nlay) + REAL zl(ngrid,nlay) + REAL zh(ngrid,nlay) + REAL ztv(ngrid,nlay) + REAL zthl(ngrid,nlay) + REAL zpspsk(ngrid,nlay) + REAL zu(ngrid,nlay) + REAL zv(ngrid,nlay) + REAL zqsat(ngrid,nlay) + + INTEGER ig,l,ll + + real zcor,zdelta,zcvm5,qlbef + real Tbef,qsatbef + real dqsat_dT,DT,num,denom + REAL RLvCp,DDT0 + PARAMETER (DDT0=.01) + LOGICAL Zsat + + Zsat=.false. + RLvCp = RLVTT/RCPD + +! +! Pr Tprec=Tl calcul de qsat +! Si qsat>qT T=Tl, q=qT +! Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) +! On cherche DDT < DDT0 +! +! calcul des caracteristiques de l environnement + DO ll=1,nlay + DO ig=1,ngrid + zo(ig,ll)=po(ig,ll) + zl(ig,ll)=0. + zh(ig,ll)=pt(ig,ll) + zqsat(ig,ll)=0. + EndDO + EndDO +! +! +!recherche de saturation dans l environnement + DO ll=1,nlay +! les points insatures sont definitifs + DO ig=1,ngrid + Tbef=pt(ig,ll) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,ll) + qsatbef=MIN(0.5,qsatbef) + zcor=1./(1.-retv*qsatbef) + qsatbef=qsatbef*zcor + Zsat = (max(0.,po(ig,ll)-qsatbef) .gt. 1.e-10) + if (Zsat) then + qlbef=max(0.,po(ig,ll)-qsatbef) +! si sature: ql est surestime, d'ou la sous-relax + DT = 0.5*RLvCp*qlbef +! on pourra enchainer 2 ou 3 calculs sans Do while + do while (abs(DT).gt.DDT0) +! il faut verifier si c,a conserve quand on repasse en insature ... + Tbef=Tbef+DT + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,ll) + qsatbef=MIN(0.5,qsatbef) + zcor=1./(1.-retv*qsatbef) + qsatbef=qsatbef*zcor +! on veut le signe de qlbef + qlbef=po(ig,ll)-qsatbef +! dqsat_dT + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta + zcor=1./(1.-retv*qsatbef) + dqsat_dT=FOEDE(Tbef,zdelta,zcvm5,qsatbef,zcor) + num=-Tbef+pt(ig,ll)+RLvCp*qlbef + denom=1.+RLvCp*dqsat_dT + if (denom.lt.1.e-10) then + print*,'pb denom' + endif + DT=num/denom + enddo +! on ecrit de maniere conservative (sat ou non) + zl(ig,ll) = max(0.,qlbef) +! T = Tl +Lv/Cp ql + zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll) + zo(ig,ll) = po(ig,ll)-zl(ig,ll) + endif +!on ecrit zqsat + zqsat(ig,ll)=qsatbef + EndDO + EndDO +! +! +!----------------------------------------------------------------------- +! incrementation eventuelle de tendances precedentes: +! --------------------------------------------------- + + if (prt_level.ge.1) print*,'0 OK convect8' + + DO 1010 l=1,nlay + DO 1015 ig=1,ngrid + zpspsk(ig,l)=(pplay(ig,l)/100000.)**RKAPPA + zu(ig,l)=pu(ig,l) + zv(ig,l)=pv(ig,l) +!attention zh est maintenant le profil de T et plus le profil de theta ! +! +! T-> Theta + ztv(ig,l)=zh(ig,l)/zpspsk(ig,l) +!Theta_v + ztv(ig,l)=ztv(ig,l)*(1.+RETV*(zo(ig,l)) & + & -zl(ig,l)) +!Thetal + zthl(ig,l)=pt(ig,l)/zpspsk(ig,l) +! +1015 CONTINUE +1010 CONTINUE + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_flux.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_flux.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_flux.F90 (revision 1280) @@ -0,0 +1,508 @@ +! +! $Header$ +! + + + SUBROUTINE thermcell_flux(ngrid,klev,ptimestep,masse, & + & lalim,lmax,alim_star, & + & entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr, & + & detr,zqla,zmax,lev_out,lunout1,igout) + + +!--------------------------------------------------------------------------- +!thermcell_flux: deduction des flux +!--------------------------------------------------------------------------- + + IMPLICIT NONE +#include "iniprint.h" + + INTEGER ig,l + INTEGER ngrid,klev + + REAL alim_star(ngrid,klev),entr_star(ngrid,klev) + REAL detr_star(ngrid,klev) + REAL zw2(ngrid,klev+1) + REAL zlev(ngrid,klev+1) + REAL masse(ngrid,klev) + REAL ptimestep + REAL rhobarz(ngrid,klev) + REAL f(ngrid) + INTEGER lmax(ngrid) + INTEGER lalim(ngrid) + REAL zqla(ngrid,klev) + REAL zmax(ngrid) + + integer ncorecfm1,ncorecfm2,ncorecfm3,ncorecalpha + integer ncorecfm4,ncorecfm5,ncorecfm6,ncorecfm7,ncorecfm8 + + + REAL entr(ngrid,klev),detr(ngrid,klev) + REAL fm(ngrid,klev+1) + REAL zfm + + integer igout + integer lev_out + integer lunout1 + + REAL f_old,ddd0,eee0,ddd,eee,zzz + + REAL fomass_max,alphamax + save fomass_max,alphamax +!$OMP THREADPRIVATE(fomass_max,alphamax) + + fomass_max=0.5 + alphamax=0.7 + + ncorecfm1=0 + ncorecfm2=0 + ncorecfm3=0 + ncorecfm4=0 + ncorecfm5=0 + ncorecfm6=0 + ncorecfm7=0 + ncorecfm8=0 + ncorecalpha=0 + +!initialisation + fm(:,:)=0. + + if (prt_level.ge.10) then + write(lunout,*) 'Dans thermcell_flux 0' + write(lunout,*) 'flux base ',f(igout) + write(lunout,*) 'lmax ',lmax(igout) + write(lunout,*) 'lalim ',lalim(igout) + write(lunout,*) 'ig= ',igout + write(lunout,*) ' l E* A* D* ' + write(lunout,'(i4,3e15.5)') (l,entr_star(igout,l),alim_star(igout,l),detr_star(igout,l) & + & ,l=1,lmax(igout)) + endif + + +!------------------------------------------------------------------------- +! Verification de la nullite des entrainement et detrainement au dessus +! de lmax(ig) +!------------------------------------------------------------------------- + if ( prt_level > 1 ) THEN + do l=1,klev + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (entr_star(ig,l).gt.1.) then + print*,'WARNING thermcell_flux 1 ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'entr_star(ig,l)',entr_star(ig,l) + print*,'alim_star(ig,l)',alim_star(ig,l) + print*,'detr_star(ig,l)',detr_star(ig,l) +! stop + endif + else + if (abs(entr_star(ig,l))+abs(alim_star(ig,l))+abs(detr_star(ig,l)).gt.0.) then + print*,'cas 1 : ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'entr_star(ig,l)',entr_star(ig,l) + print*,'alim_star(ig,l)',alim_star(ig,l) + print*,'detr_star(ig,l)',detr_star(ig,l) + stop + endif + endif + enddo + enddo + endif !( prt_level > 1 ) THEN +!------------------------------------------------------------------------- +! Multiplication par le flux de masse issu de la femreture +!------------------------------------------------------------------------- + + do l=1,klev + entr(:,l)=f(:)*(entr_star(:,l)+alim_star(:,l)) + detr(:,l)=f(:)*detr_star(:,l) + enddo + + if (prt_level.ge.10) then + write(lunout,*) 'Dans thermcell_flux 1' + write(lunout,*) 'flux base ',f(igout) + write(lunout,*) 'lmax ',lmax(igout) + write(lunout,*) 'lalim ',lalim(igout) + write(lunout,*) 'ig= ',igout + write(lunout,*) ' l E D W2' + write(lunout,'(i4,3e15.5)') (l,entr(igout,l),detr(igout,l) & + & ,zw2(igout,l+1),l=1,lmax(igout)) + endif + + fm(:,1)=0. + do l=1,klev + do ig=1,ngrid + if (l.lt.lmax(ig)) then + fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l) + elseif(l.eq.lmax(ig)) then + fm(ig,l+1)=0. + detr(ig,l)=fm(ig,l)+entr(ig,l) + else + fm(ig,l+1)=0. + endif + enddo + enddo + + + +! Test provisoire : pour comprendre pourquoi on corrige plein de fois +! le cas fm6, on commence par regarder une premiere fois avant les +! autres corrections. + + do l=1,klev + do ig=1,ngrid + if (detr(ig,l).gt.fm(ig,l)) then + ncorecfm8=ncorecfm8+1 +! igout=ig + endif + enddo + enddo + + if (prt_level.ge.10) & + & call printflux(ngrid,klev,lunout,igout,f,lmax,lalim, & + & ptimestep,masse,entr,detr,fm,'2 ') + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH Version en cours de test; +! par rapport a thermcell_flux, on fait une grande boucle sur "l" +! et on modifie le flux avec tous les contr�les appliques d'affilee +! pour la meme couche +! Momentanement, on duplique le calcule du flux pour pouvoir comparer +! les flux avant et apres modif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do l=1,klev + + do ig=1,ngrid + if (l.lt.lmax(ig)) then + fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l) + elseif(l.eq.lmax(ig)) then + fm(ig,l+1)=0. + detr(ig,l)=fm(ig,l)+entr(ig,l) + else + fm(ig,l+1)=0. + endif + enddo + + +!------------------------------------------------------------------------- +! Verification de la positivite des flux de masse +!------------------------------------------------------------------------- + +! do l=1,klev + do ig=1,ngrid + if (fm(ig,l+1).lt.0.) then +! print*,'fm1<0',l+1,lmax(ig),fm(ig,l+1) + ncorecfm1=ncorecfm1+1 + fm(ig,l+1)=fm(ig,l) + detr(ig,l)=entr(ig,l) + endif + enddo +! enddo + + if (prt_level.ge.10) & + & write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!------------------------------------------------------------------------- +!Test sur fraca croissant +!------------------------------------------------------------------------- + + + if (1.eq.1) then +! do l=1,klev + do ig=1,ngrid + if (l.ge.lalim(ig).and.l.le.lmax(ig) & + & .and.(zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10) ) then +! zzz est le flux en l+1 a frac constant + zzz=fm(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1) & + & /(rhobarz(ig,l)*zw2(ig,l)) + if (fm(ig,l+1).gt.zzz) then + detr(ig,l)=detr(ig,l)+fm(ig,l+1)-zzz + fm(ig,l+1)=zzz + ncorecfm4=ncorecfm4+1 + endif + endif + enddo +! enddo + + if (prt_level.ge.10) & + & write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + else + if (l.eq.1) then + print*,'Test sur les fractions croissantes inhibe dans thermcell_flux2' + endif + endif + + +!------------------------------------------------------------------------- +!test sur flux de masse croissant +!------------------------------------------------------------------------- + +! do l=1,klev + do ig=1,ngrid + if ((fm(ig,l+1).gt.fm(ig,l)).and.(l.gt.lalim(ig))) then + f_old=fm(ig,l+1) + fm(ig,l+1)=fm(ig,l) + detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1) + ncorecfm5=ncorecfm5+1 + endif + enddo +! enddo + + if (prt_level.ge.10) & + & write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!------------------------------------------------------------------------- +!detr ne peut pas etre superieur a fm +!------------------------------------------------------------------------- + + if(1.eq.1) then + +! do l=1,klev + do ig=1,ngrid + if (entr(ig,l)<0.) then + print*,'N1 ig,l,entr',ig,l,entr(ig,l) + stop 'entr negatif' + endif + if (detr(ig,l).gt.fm(ig,l)) then + ncorecfm6=ncorecfm6+1 + detr(ig,l)=fm(ig,l) +! entr(ig,l)=fm(ig,l+1) + +! Dans le cas ou on est au dessus de la couche d'alimentation et que le +! detrainement est plus fort que le flux de masse, on stope le thermique. + if (l.gt.lalim(ig)) then + lmax(ig)=l + fm(ig,l+1)=0. + entr(ig,l)=0. + else + ncorecfm7=ncorecfm7+1 + endif + endif + + if(l.gt.lmax(ig)) then + detr(ig,l)=0. + fm(ig,l+1)=0. + entr(ig,l)=0. + endif + + if (entr(ig,l).lt.0.) then + print*,'ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'entr(ig,l)',entr(ig,l) + print*,'fm(ig,l)',fm(ig,l) + stop 'probleme dans thermcell flux' + endif + enddo +! enddo + endif + + + if (prt_level.ge.10) & + & write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!------------------------------------------------------------------------- +!fm ne peut pas etre negatif +!------------------------------------------------------------------------- + +! do l=1,klev + do ig=1,ngrid + if (fm(ig,l+1).lt.0.) then + detr(ig,l)=detr(ig,l)+fm(ig,l+1) + fm(ig,l+1)=0. +! print*,'fm2<0',l+1,lmax(ig) + ncorecfm2=ncorecfm2+1 + endif + if (detr(ig,l).lt.0.) then + print*,'cas 2 : ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'detr(ig,l)',detr(ig,l) + print*,'fm(ig,l)',fm(ig,l) + stop 'probleme dans thermcell flux' + endif + enddo +! enddo + + if (prt_level.ge.10) & + & write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!----------------------------------------------------------------------- +!la fraction couverte ne peut pas etre superieure a 1 +!----------------------------------------------------------------------- + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH Partie a revisiter. +! Il semble qu'etaient codees ici deux optiques dans le cas +! F/ (rho *w) > 1 +! soit limiter la hauteur du thermique en considerant que c'est +! la derniere chouche, soit limiter F a rho w. +! Dans le second cas, il faut en fait limiter a un peu moins +! que ca parce qu'on a des 1 / ( 1 -alpha) un peu plus loin +! dans thermcell_main et qu'il semble de toutes facons deraisonable +! d'avoir des fractions de 1.. +! Ci dessous, et dans l'etat actuel, le premier des deux if est +! sans doute inutile. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! do l=1,klev + do ig=1,ngrid + if (zw2(ig,l+1).gt.1.e-10) then + zfm=rhobarz(ig,l+1)*zw2(ig,l+1)*alphamax + if ( fm(ig,l+1) .gt. zfm) then + f_old=fm(ig,l+1) + fm(ig,l+1)=zfm +! zw2(ig,l+1)=0. +! zqla(ig,l+1)=0. + detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1) +! lmax(ig)=l+1 +! zmax(ig)=zlev(ig,lmax(ig)) +! print*,'alpha>1',l+1,lmax(ig) + ncorecalpha=ncorecalpha+1 + endif + endif + enddo +! enddo +! + + + if (prt_level.ge.10) & + & write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +! Fin de la grande boucle sur les niveaux verticaux + enddo + + if (prt_level.ge.10) & + & call printflux(ngrid,klev,lunout,igout,f,lmax,lalim, & + & ptimestep,masse,entr,detr,fm,'8 ') + + +!----------------------------------------------------------------------- +! On fait en sorte que la quantite totale d'air entraine dans le +! panache ne soit pas trop grande comparee a la masse de la maille +!----------------------------------------------------------------------- + + if (1.eq.1) then + do l=1,klev-1 + do ig=1,ngrid + eee0=entr(ig,l) + ddd0=detr(ig,l) + eee=entr(ig,l)-masse(ig,l)*fomass_max/ptimestep + ddd=detr(ig,l)-eee + if (eee.gt.0.) then + ncorecfm3=ncorecfm3+1 + entr(ig,l)=entr(ig,l)-eee + if ( ddd.gt.0.) then +! l'entrainement est trop fort mais l'exces peut etre compense par une +! diminution du detrainement) + detr(ig,l)=ddd + else +! l'entrainement est trop fort mais l'exces doit etre compense en partie +! par un entrainement plus fort dans la couche superieure + if(l.eq.lmax(ig)) then + detr(ig,l)=fm(ig,l)+entr(ig,l) + else + if(l.ge.lmax(ig).and.0.eq.1) then + print*,'ig,l',ig,l + print*,'eee0',eee0 + print*,'ddd0',ddd0 + print*,'eee',eee + print*,'ddd',ddd + print*,'entr',entr(ig,l) + print*,'detr',detr(ig,l) + print*,'masse',masse(ig,l) + print*,'fomass_max',fomass_max + print*,'masse(ig,l)*fomass_max/ptimestep',masse(ig,l)*fomass_max/ptimestep + print*,'ptimestep',ptimestep + print*,'lmax(ig)',lmax(ig) + print*,'fm(ig,l+1)',fm(ig,l+1) + print*,'fm(ig,l)',fm(ig,l) + stop 'probleme dans thermcell_flux' + endif + entr(ig,l+1)=entr(ig,l+1)-ddd + detr(ig,l)=0. + fm(ig,l+1)=fm(ig,l)+entr(ig,l) + detr(ig,l)=0. + endif + endif + endif + enddo + enddo + endif +! +! ddd=detr(ig)-entre +!on s assure que tout s annule bien en zmax + do ig=1,ngrid + fm(ig,lmax(ig)+1)=0. + entr(ig,lmax(ig))=0. + detr(ig,lmax(ig))=fm(ig,lmax(ig))+entr(ig,lmax(ig)) + enddo + +!----------------------------------------------------------------------- +! Impression du nombre de bidouilles qui ont ete necessaires +!----------------------------------------------------------------------- + + if (ncorecfm1+ncorecfm2+ncorecfm3+ncorecfm4+ncorecfm5+ncorecalpha > 0 ) then + if (prt_level.ge.10) then + print*,'PB thermcell : on a du coriger ',ncorecfm1,'x fm1',& + & ncorecfm2,'x fm2',ncorecfm3,'x fm3 et', & + & ncorecfm4,'x fm4',ncorecfm5,'x fm5 et', & + & ncorecfm6,'x fm6', & + & ncorecfm7,'x fm7', & + & ncorecfm8,'x fm8', & + & ncorecalpha,'x alpha' + endif + endif + + if (prt_level.ge.10) & + & call printflux(ngrid,klev,lunout,igout,f,lmax,lalim, & + & ptimestep,masse,entr,detr,fm,'fin') + + + return + end + + subroutine printflux(ngrid,klev,lunout,igout,f,lmax,lalim, & + & ptimestep,masse,entr,detr,fm,descr) + + implicit none + + integer ngrid,klev,lunout,igout,l,lm + + integer lmax(klev),lalim(klev) + real ptimestep,masse(ngrid,klev),entr(ngrid,klev),detr(ngrid,klev) + real fm(ngrid,klev+1),f(ngrid) + + character*3 descr + + lm=lmax(igout)+5 + if(lm.gt.klev) lm=klev + + print*,'Impression jusque lm=',lm + + write(lunout,*) 'Dans thermcell_flux '//descr + write(lunout,*) 'flux base ',f(igout) + write(lunout,*) 'lmax ',lmax(igout) + write(lunout,*) 'lalim ',lalim(igout) + write(lunout,*) 'ig= ',igout + write(lunout,'(a3,4a14)') 'l','M','E','D','F' + write(lunout,'(i4,4e14.4)') (l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l) & + & ,fm(igout,l+1),l=1,lm) + + + do l=lmax(igout)+1,klev + if (abs(entr(igout,l))+abs(detr(igout,l))+abs(fm(igout,l)).gt.0.) then + print*,'cas 1 : igout,l,lmax(igout)',igout,l,lmax(igout) + print*,'entr(igout,l)',entr(igout,l) + print*,'detr(igout,l)',detr(igout,l) + print*,'fm(igout,l)',fm(igout,l) + stop + endif + enddo + + return + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_flux2.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_flux2.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_flux2.F90 (revision 1280) @@ -0,0 +1,459 @@ + SUBROUTINE thermcell_flux2(ngrid,klev,ptimestep,masse, & + & lalim,lmax,alim_star, & + & entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr, & + & detr,zqla,lev_out,lunout1,igout) +!IM 060508 & detr,zqla,zmax,lev_out,lunout,igout) + + +!--------------------------------------------------------------------------- +!thermcell_flux: deduction des flux +!--------------------------------------------------------------------------- + + IMPLICIT NONE +#include "iniprint.h" +#include "thermcell.h" + + INTEGER ig,l + INTEGER ngrid,klev + + REAL alim_star(ngrid,klev),entr_star(ngrid,klev) + REAL detr_star(ngrid,klev) + REAL zw2(ngrid,klev+1) + REAL zlev(ngrid,klev+1) + REAL masse(ngrid,klev) + REAL ptimestep + REAL rhobarz(ngrid,klev) + REAL f(ngrid) + INTEGER lmax(ngrid) + INTEGER lalim(ngrid) + REAL zqla(ngrid,klev) + REAL zmax(ngrid) + + integer ncorecfm1,ncorecfm2,ncorecfm3,ncorecalpha + integer ncorecfm4,ncorecfm5,ncorecfm6,ncorecfm7,ncorecfm8 + + + REAL entr(ngrid,klev),detr(ngrid,klev) + REAL fm(ngrid,klev+1) + REAL zfm + + integer igout + integer lev_out + integer lunout1 + + REAL f_old,ddd0,eee0,ddd,eee,zzz + + REAL fomass_max,alphamax + save fomass_max,alphamax + + fomass_max=0.5 + alphamax=0.7 + + ncorecfm1=0 + ncorecfm2=0 + ncorecfm3=0 + ncorecfm4=0 + ncorecfm5=0 + ncorecfm6=0 + ncorecfm7=0 + ncorecfm8=0 + ncorecalpha=0 + +!initialisation + fm(:,:)=0. + + if (prt_level.ge.10) then + write(lunout1,*) 'Dans thermcell_flux 0' + write(lunout1,*) 'flux base ',f(igout) + write(lunout1,*) 'lmax ',lmax(igout) + write(lunout1,*) 'lalim ',lalim(igout) + write(lunout1,*) 'ig= ',igout + write(lunout1,*) ' l E* A* D* ' + write(lunout1,'(i4,3e15.5)') (l,entr_star(igout,l),alim_star(igout,l),detr_star(igout,l) & + & ,l=1,lmax(igout)) + endif + + +!------------------------------------------------------------------------- +! Verification de la nullite des entrainement et detrainement au dessus +! de lmax(ig) +!------------------------------------------------------------------------- + + do l=1,klev + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (entr_star(ig,l).gt.1.) then + print*,'WARNING thermcell_flux 1 ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'entr_star(ig,l)',entr_star(ig,l) + print*,'alim_star(ig,l)',alim_star(ig,l) + print*,'detr_star(ig,l)',detr_star(ig,l) +! stop + endif + else + if (abs(entr_star(ig,l))+abs(alim_star(ig,l))+abs(detr_star(ig,l)).gt.0.) then + print*,'cas 1 : ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'entr_star(ig,l)',entr_star(ig,l) + print*,'alim_star(ig,l)',alim_star(ig,l) + print*,'detr_star(ig,l)',detr_star(ig,l) + stop + endif + endif + enddo + enddo + +!------------------------------------------------------------------------- +! Multiplication par le flux de masse issu de la femreture +!------------------------------------------------------------------------- + + do l=1,klev + entr(:,l)=f(:)*(entr_star(:,l)+alim_star(:,l)) + detr(:,l)=f(:)*detr_star(:,l) + enddo + + if (prt_level.ge.10) then + write(lunout1,*) 'Dans thermcell_flux 1' + write(lunout1,*) 'flux base ',f(igout) + write(lunout1,*) 'lmax ',lmax(igout) + write(lunout1,*) 'lalim ',lalim(igout) + write(lunout1,*) 'ig= ',igout + write(lunout1,*) ' l E D W2' + write(lunout1,'(i4,3e15.5)') (l,entr(igout,l),detr(igout,l) & + & ,zw2(igout,l+1),l=1,lmax(igout)) + endif + + fm(:,1)=0. + do l=1,klev + do ig=1,ngrid + if (l.lt.lmax(ig)) then + fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l) + elseif(l.eq.lmax(ig)) then + fm(ig,l+1)=0. + detr(ig,l)=fm(ig,l)+entr(ig,l) + else + fm(ig,l+1)=0. + endif + enddo + enddo + + + +! Test provisoire : pour comprendre pourquoi on corrige plein de fois +! le cas fm6, on commence par regarder une premiere fois avant les +! autres corrections. + + do l=1,klev + do ig=1,ngrid + if (detr(ig,l).gt.fm(ig,l)) then + ncorecfm8=ncorecfm8+1 +! igout=ig + endif + enddo + enddo + +! if (prt_level.ge.10) & +! & call printflux(ngrid,klev,lunout1,igout,f,lmax,lalim, & +! & ptimestep,masse,entr,detr,fm,'2 ') + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH Version en cours de test; +! par rapport a thermcell_flux, on fait une grande boucle sur "l" +! et on modifie le flux avec tous les contr�les appliques d'affilee +! pour la meme couche +! Momentanement, on duplique le calcule du flux pour pouvoir comparer +! les flux avant et apres modif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do l=1,klev + + do ig=1,ngrid + if (l.lt.lmax(ig)) then + fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l) + elseif(l.eq.lmax(ig)) then + fm(ig,l+1)=0. + detr(ig,l)=fm(ig,l)+entr(ig,l) + else + fm(ig,l+1)=0. + endif + enddo + + +!------------------------------------------------------------------------- +! Verification de la positivite des flux de masse +!------------------------------------------------------------------------- + +! do l=1,klev + do ig=1,ngrid + if (fm(ig,l+1).lt.0.) then +! print*,'fm1<0',l+1,lmax(ig),fm(ig,l+1) + ncorecfm1=ncorecfm1+1 + fm(ig,l+1)=fm(ig,l) + detr(ig,l)=entr(ig,l) + endif + enddo +! enddo + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!------------------------------------------------------------------------- +!Test sur fraca croissant +!------------------------------------------------------------------------- + if (iflag_thermals_optflux==0) then +! do l=1,klev + do ig=1,ngrid + if (l.ge.lalim(ig).and.l.le.lmax(ig) & + & .and.(zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10) ) then +! zzz est le flux en l+1 a frac constant + zzz=fm(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1) & + & /(rhobarz(ig,l)*zw2(ig,l)) + if (fm(ig,l+1).gt.zzz) then + detr(ig,l)=detr(ig,l)+fm(ig,l+1)-zzz + fm(ig,l+1)=zzz + ncorecfm4=ncorecfm4+1 + endif + endif + enddo +! enddo + endif + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + + +!------------------------------------------------------------------------- +!test sur flux de masse croissant +!------------------------------------------------------------------------- + if (iflag_thermals_optflux==0) then +! do l=1,klev + do ig=1,ngrid + if ((fm(ig,l+1).gt.fm(ig,l)).and.(l.gt.lalim(ig))) then + f_old=fm(ig,l+1) + fm(ig,l+1)=fm(ig,l) + detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1) + ncorecfm5=ncorecfm5+1 + endif + enddo +! enddo + endif + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!fin 1.eq.0 +!------------------------------------------------------------------------- +!detr ne peut pas etre superieur a fm +!------------------------------------------------------------------------- + + if(1.eq.1) then + +! do l=1,klev + do ig=1,ngrid + if (entr(ig,l)<0.) then + print*,'N1 ig,l,entr',ig,l,entr(ig,l) + stop 'entr negatif' + endif + if (detr(ig,l).gt.fm(ig,l)) then + ncorecfm6=ncorecfm6+1 + detr(ig,l)=fm(ig,l) + entr(ig,l)=fm(ig,l+1) + +! Dans le cas ou on est au dessus de la couche d'alimentation et que le +! detrainement est plus fort que le flux de masse, on stope le thermique. +!test:on commente +! if (l.gt.lalim(ig)) then +! lmax(ig)=l +! fm(ig,l+1)=0. +! entr(ig,l)=0. +! else +! ncorecfm7=ncorecfm7+1 +! endif + endif + + if(l.gt.lmax(ig)) then + detr(ig,l)=0. + fm(ig,l+1)=0. + entr(ig,l)=0. + endif + + if (entr(ig,l).lt.0.) then + print*,'ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'entr(ig,l)',entr(ig,l) + print*,'fm(ig,l)',fm(ig,l) + stop 'probleme dans thermcell flux' + endif + enddo +! enddo + endif + + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!------------------------------------------------------------------------- +!fm ne peut pas etre negatif +!------------------------------------------------------------------------- + +! do l=1,klev + do ig=1,ngrid + if (fm(ig,l+1).lt.0.) then + detr(ig,l)=detr(ig,l)+fm(ig,l+1) + fm(ig,l+1)=0. +! print*,'fm2<0',l+1,lmax(ig) + ncorecfm2=ncorecfm2+1 + endif + if (detr(ig,l).lt.0.) then + print*,'cas 2 : ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'detr(ig,l)',detr(ig,l) + print*,'fm(ig,l)',fm(ig,l) + stop 'probleme dans thermcell flux' + endif + enddo +! enddo + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!----------------------------------------------------------------------- +!la fraction couverte ne peut pas etre superieure a 1 +!----------------------------------------------------------------------- + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH Partie a revisiter. +! Il semble qu'etaient codees ici deux optiques dans le cas +! F/ (rho *w) > 1 +! soit limiter la hauteur du thermique en considerant que c'est +! la derniere chouche, soit limiter F a rho w. +! Dans le second cas, il faut en fait limiter a un peu moins +! que ca parce qu'on a des 1 / ( 1 -alpha) un peu plus loin +! dans thermcell_main et qu'il semble de toutes facons deraisonable +! d'avoir des fractions de 1.. +! Ci dessous, et dans l'etat actuel, le premier des deux if est +! sans doute inutile. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! do l=1,klev + do ig=1,ngrid + if (zw2(ig,l+1).gt.1.e-10) then + zfm=rhobarz(ig,l+1)*zw2(ig,l+1)*alphamax + if ( fm(ig,l+1) .gt. zfm) then + f_old=fm(ig,l+1) + fm(ig,l+1)=zfm +! zw2(ig,l+1)=0. +! zqla(ig,l+1)=0. + detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1) +! lmax(ig)=l+1 +! zmax(ig)=zlev(ig,lmax(ig)) +! print*,'alpha>1',l+1,lmax(ig) + ncorecalpha=ncorecalpha+1 + endif + endif + enddo +! enddo +! + + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +! Fin de la grande boucle sur les niveaux verticaux + enddo + +! if (prt_level.ge.10) & +! & call printflux(ngrid,klev,lunout1,igout,f,lmax,lalim, & +! & ptimestep,masse,entr,detr,fm,'8 ') + + +!----------------------------------------------------------------------- +! On fait en sorte que la quantite totale d'air entraine dans le +! panache ne soit pas trop grande comparee a la masse de la maille +!----------------------------------------------------------------------- + + if (1.eq.1) then + do l=1,klev-1 + do ig=1,ngrid + eee0=entr(ig,l) + ddd0=detr(ig,l) + eee=entr(ig,l)-masse(ig,l)*fomass_max/ptimestep + ddd=detr(ig,l)-eee + if (eee.gt.0.) then + ncorecfm3=ncorecfm3+1 + entr(ig,l)=entr(ig,l)-eee + if ( ddd.gt.0.) then +! l'entrainement est trop fort mais l'exces peut etre compense par une +! diminution du detrainement) + detr(ig,l)=ddd + else +! l'entrainement est trop fort mais l'exces doit etre compense en partie +! par un entrainement plus fort dans la couche superieure + if(l.eq.lmax(ig)) then + detr(ig,l)=fm(ig,l)+entr(ig,l) + else + if(l.ge.lmax(ig).and.0.eq.1) then + print*,'ig,l',ig,l + print*,'eee0',eee0 + print*,'ddd0',ddd0 + print*,'eee',eee + print*,'ddd',ddd + print*,'entr',entr(ig,l) + print*,'detr',detr(ig,l) + print*,'masse',masse(ig,l) + print*,'fomass_max',fomass_max + print*,'masse(ig,l)*fomass_max/ptimestep',masse(ig,l)*fomass_max/ptimestep + print*,'ptimestep',ptimestep + print*,'lmax(ig)',lmax(ig) + print*,'fm(ig,l+1)',fm(ig,l+1) + print*,'fm(ig,l)',fm(ig,l) + stop 'probleme dans thermcell_flux' + endif + entr(ig,l+1)=entr(ig,l+1)-ddd + detr(ig,l)=0. + fm(ig,l+1)=fm(ig,l)+entr(ig,l) + detr(ig,l)=0. + endif + endif + endif + enddo + enddo + endif +! +! ddd=detr(ig)-entre +!on s assure que tout s annule bien en zmax + do ig=1,ngrid + fm(ig,lmax(ig)+1)=0. + entr(ig,lmax(ig))=0. + detr(ig,lmax(ig))=fm(ig,lmax(ig))+entr(ig,lmax(ig)) + enddo + +!----------------------------------------------------------------------- +! Impression du nombre de bidouilles qui ont ete necessaires +!----------------------------------------------------------------------- + +!IM 090508 beg +! if (ncorecfm1+ncorecfm2+ncorecfm3+ncorecfm4+ncorecfm5+ncorecalpha > 0 ) then +! +! print*,'PB thermcell : on a du coriger ',ncorecfm1,'x fm1',& +! & ncorecfm2,'x fm2',ncorecfm3,'x fm3 et', & +! & ncorecfm4,'x fm4',ncorecfm5,'x fm5 et', & +! & ncorecfm6,'x fm6', & +! & ncorecfm7,'x fm7', & +! & ncorecfm8,'x fm8', & +! & ncorecalpha,'x alpha' +! endif +!IM 090508 end + +! if (prt_level.ge.10) & +! & call printflux(ngrid,klev,lunout1,igout,f,lmax,lalim, & +! & ptimestep,masse,entr,detr,fm,'fin') + + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_height.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_height.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_height.F90 (revision 1280) @@ -0,0 +1,153 @@ + SUBROUTINE thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix, & + & zw2,zlev,lmax,zmax,zmax0,zmix,wmax,lev_out) + +!----------------------------------------------------------------------------- +!thermcell_height: calcul des caracteristiques du thermique: zmax,wmax,zmix +!----------------------------------------------------------------------------- + IMPLICIT NONE +#include "iniprint.h" +#include "thermcell.h" + + INTEGER ig,l + INTEGER ngrid,nlay + INTEGER lalim(ngrid),lmin(ngrid) + INTEGER lmix(ngrid) + REAL linter(ngrid) + integer lev_out ! niveau pour les print + + REAL zw2(ngrid,nlay+1) + REAL zlev(ngrid,nlay+1) + + REAL wmax(ngrid) + INTEGER lmax(ngrid) + REAL zmax(ngrid) + REAL zmax0(ngrid) + REAL zmix(ngrid) + REAL num(ngrid) + REAL denom(ngrid) + + REAL zlevinter(ngrid) + +!calcul de la hauteur max du thermique + do ig=1,ngrid + lmax(ig)=lalim(ig) + enddo + do ig=1,ngrid + do l=nlay,lalim(ig)+1,-1 + if (zw2(ig,l).le.1.e-10) then + lmax(ig)=l-1 + endif + enddo + enddo +! pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.1) then + lmax(ig)=1 + lmin(ig)=1 + lalim(ig)=1 + endif + enddo +! +! Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (zw2(ig,l).lt.0.)then + print*,'pb2 zw2<0' + endif + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +! Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=0. + zlevinter(ig)=zlev(ig,1) + enddo + + if (iflag_thermals_ed.ge.1) then + + num(:)=0. + denom(:)=0. + do ig=1,ngrid + do l=1,nlay + num(ig)=num(ig)+zw2(ig,l)*zlev(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + denom(ig)=denom(ig)+zw2(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + enddo + enddo + do ig=1,ngrid + if (denom(ig).gt.1.e-10) then + zmax(ig)=2.*num(ig)/denom(ig) + zmax0(ig)=zmax(ig) + endif + enddo + + else + + do ig=1,ngrid +! calcul de zlevinter + zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* & + & linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) & + & -zlev(ig,lmax(ig))) +!pour le cas ou on prend tjs lmin=1 +! zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1)) + zmax0(ig)=zmax(ig) + enddo + + + endif +!endif iflag_thermals_ed +! +! def de zmix continu (profil parabolique des vitesses) + do ig=1,ngrid + if (lmix(ig).gt.1) then +! test + if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) & + & *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) & + & -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) & + & *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10) & + & then +! + zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) & + & *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2) & + & -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) & + & *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2)) & + & /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) & + & *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) & + & -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) & + & *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + else + zmix(ig)=zlev(ig,lmix(ig)) + print*,'pb zmix' + endif + else + zmix(ig)=0. + endif +!test + if ((zmax(ig)-zmix(ig)).le.0.) then + zmix(ig)=0.9*zmax(ig) +! print*,'pb zmix>zmax' + endif + enddo +! +! calcul du nouveau lmix correspondant + do ig=1,ngrid + do l=1,nlay + if (zmix(ig).ge.zlev(ig,l).and. & + & zmix(ig).lt.zlev(ig,l+1)) then + lmix(ig)=l + endif + enddo + enddo +! + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_init.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_init.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_init.F90 (revision 1280) @@ -0,0 +1,162 @@ + SUBROUTINE thermcell_init(ngrid,nlay,ztv,zlay,zlev, & + & lalim,lmin,alim_star,alim_star_tot,lev_out) + +!---------------------------------------------------------------------- +!thermcell_init: calcul du profil d alimentation du thermique +!---------------------------------------------------------------------- + IMPLICIT NONE +#include "iniprint.h" +#include "thermcell.h" + + INTEGER l,ig +!arguments d entree + INTEGER ngrid,nlay + REAL ztv(ngrid,nlay) + REAL zlay(ngrid,nlay) + REAL zlev(ngrid,nlay+1) +!arguments de sortie + INTEGER lalim(ngrid) + INTEGER lmin(ngrid) + REAL alim_star(ngrid,nlay) + REAL alim_star_tot(ngrid) + integer lev_out ! niveau pour les print + + REAL zzalim(ngrid) +!CR: ponderation entrainement des couches instables +!def des alim_star tels que alim=f*alim_star + + do l=1,nlay + do ig=1,ngrid + alim_star(ig,l)=0. + enddo + enddo +! determination de la longueur de la couche d entrainement + do ig=1,ngrid + lalim(ig)=1 + enddo + + if (iflag_thermals_ed.ge.1) then +!si la première couche est instable, on declenche un thermique + do ig=1,ngrid + if (ztv(ig,1).gt.ztv(ig,2)) then + lmin(ig)=1 + lalim(ig)=2 + alim_star(ig,1)=1. + alim_star_tot(ig)=alim_star(ig,1) + if(prt_level.GE.10) print*,'init',alim_star(ig,1),alim_star_tot(ig) + else + lmin(ig)=1 + lalim(ig)=1 + alim_star(ig,1)=0. + alim_star_tot(ig)=0. + endif + enddo + + else +!else iflag_thermals_ed=0 ancienne def de l alim + +!on ne considere que les premieres couches instables + do l=nlay-2,1,-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. & + & ztv(ig,l+1).le.ztv(ig,l+2)) then + lalim(ig)=l+1 + endif + enddo + enddo + +! determination du lmin: couche d ou provient le thermique + + do ig=1,ngrid +! FH initialisation de lmin a nlay plutot que 1. +! lmin(ig)=nlay + lmin(ig)=1 + enddo + do l=nlay,2,-1 + do ig=1,ngrid + if (ztv(ig,l-1).gt.ztv(ig,l)) then + lmin(ig)=l-1 + endif + enddo + enddo +! + zzalim(:)=0. + do l=1,nlay-1 + do ig=1,ngrid + if (l1) then + zzalim(ig)=zlay(ig,1)+zzalim(ig)/(ztv(ig,1)-ztv(ig,lalim(ig))) + else + zzalim(ig)=zlay(ig,1) + endif + enddo + + if(prt_level.GE.10) print*,'ZZALIM LALIM ',zzalim,lalim,zlay(1,lalim(1)) + +! definition de l'entrainement des couches + if (1.eq.1) then + do l=1,nlay-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. & + & l.ge.lmin(ig).and.l.lt.lalim(ig)) then +!def possibles pour alim_star: zdthetadz, dthetadz, zdtheta + alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.) & + & *sqrt(zlev(ig,l+1)) + endif + enddo + enddo + else + do l=1,nlay-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. & + & l.ge.lmin(ig).and.l.lt.lalim(ig)) then + alim_star(ig,l)=max(3.*zzalim(ig)-zlay(ig,l),0.) & + & *(zlev(ig,l+1)-zlev(ig,l)) + endif + enddo + enddo + endif + +! pas de thermique si couche 1 stable + do ig=1,ngrid +!CRnouveau test + if (alim_star(ig,1).lt.1.e-10) then + do l=1,nlay + alim_star(ig,l)=0. + enddo + lmin(ig)=1 + endif + enddo +! calcul de l alimentation totale + do ig=1,ngrid + alim_star_tot(ig)=0. + enddo + do l=1,nlay + do ig=1,ngrid + alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l) + enddo + enddo +! +! Calcul entrainement normalise + do l=1,nlay + do ig=1,ngrid + if (alim_star_tot(ig).gt.1.e-10) then + alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig) + endif + enddo + enddo + +!on remet alim_star_tot a 1 + do ig=1,ngrid + alim_star_tot(ig)=1. + enddo + + endif +!endif iflag_thermals_ed + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_main.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_main.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_main.F90 (revision 1280) @@ -0,0 +1,836 @@ +! +! $Header$ +! + SUBROUTINE thermcell_main(itap,ngrid,nlay,ptimestep & + & ,pplay,pplev,pphi,debut & + & ,pu,pv,pt,po & + & ,pduadj,pdvadj,pdtadj,pdoadj & + & ,fm0,entr0,detr0,zqta,zqla,lmax & + & ,ratqscth,ratqsdiff,zqsatth & + & ,r_aspect,l_mix,tau_thermals & + & ,Ale_bl,Alp_bl,lalim_conv,wght_th & + & ,zmax0, f0,zw2,fraca) + + USE dimphy + USE comgeomphy , ONLY:rlond,rlatd + IMPLICIT NONE + +!======================================================================= +! Auteurs: Frederic Hourdin, Catherine Rio, Anne Mathieu +! Version du 09.02.07 +! Calcul du transport vertical dans la couche limite en presence +! de "thermiques" explicitement representes avec processus nuageux +! +! Réécriture à partir d'un listing papier à Habas, le 14/02/00 +! +! le thermique est supposé homogène et dissipé par mélange avec +! son environnement. la longueur l_mix contrôle l'efficacité du +! mélange +! +! Le calcul du transport des différentes espèces se fait en prenant +! en compte: +! 1. un flux de masse montant +! 2. un flux de masse descendant +! 3. un entrainement +! 4. un detrainement +! +!======================================================================= + +!----------------------------------------------------------------------- +! declarations: +! ------------- + +#include "dimensions.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +#include "iniprint.h" + +! arguments: +! ---------- + +!IM 140508 + INTEGER itap + + INTEGER ngrid,nlay,w2di + real tau_thermals + real ptimestep,l_mix,r_aspect + REAL pt(ngrid,nlay),pdtadj(ngrid,nlay) + REAL pu(ngrid,nlay),pduadj(ngrid,nlay) + REAL pv(ngrid,nlay),pdvadj(ngrid,nlay) + REAL po(ngrid,nlay),pdoadj(ngrid,nlay) + REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1) + real pphi(ngrid,nlay) + +! local: +! ------ + + integer icount + data icount/0/ + save icount +!$OMP THREADPRIVATE(icount) + + integer,save :: igout=1 +!$OMP THREADPRIVATE(igout) + integer,save :: lunout1=6 +!$OMP THREADPRIVATE(lunout1) + integer,save :: lev_out=10 +!$OMP THREADPRIVATE(lev_out) + + INTEGER ig,k,l,ll + real zsortie1d(klon) + INTEGER lmax(klon),lmin(klon),lalim(klon) + INTEGER lmix(klon) + INTEGER lmix_bis(klon) + real linter(klon) + real zmix(klon) + real zmax(klon),zw2(klon,klev+1),ztva(klon,klev),zw_est(klon,klev+1) +! real fraca(klon,klev) + + real zmax_sec(klon) +!on garde le zmax du pas de temps precedent + real zmax0(klon) +!FH/IM save zmax0 + + real lambda + + real zlev(klon,klev+1),zlay(klon,klev) + real deltaz(klon,klev) + REAL zh(klon,klev) + real zthl(klon,klev),zdthladj(klon,klev) + REAL ztv(klon,klev) + real zu(klon,klev),zv(klon,klev),zo(klon,klev) + real zl(klon,klev) + real zsortie(klon,klev) + real zva(klon,klev) + real zua(klon,klev) + real zoa(klon,klev) + + real zta(klon,klev) + real zha(klon,klev) + real fraca(klon,klev+1) + real zf,zf2 + real thetath2(klon,klev),wth2(klon,klev),wth3(klon,klev) + real q2(klon,klev) +! FH probleme de dimensionnement avec l'allocation dynamique +! common/comtherm/thetath2,wth2 + + real ratqscth(klon,klev) + real var + real vardiff + real ratqsdiff(klon,klev) + + logical sorties + real rho(klon,klev),rhobarz(klon,klev),masse(klon,klev) + real zpspsk(klon,klev) + + real wmax(klon) + real wmax_sec(klon) + real fm0(klon,klev+1),entr0(klon,klev),detr0(klon,klev) + real fm(klon,klev+1),entr(klon,klev),detr(klon,klev) + + real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev) +!niveau de condensation + integer nivcon(klon) + real zcon(klon) + REAL CHI + real zcon2(klon) + real pcon(klon) + real zqsat(klon,klev) + real zqsatth(klon,klev) + + real f_star(klon,klev+1),entr_star(klon,klev) + real detr_star(klon,klev) + real alim_star_tot(klon),alim_star2(klon) + real alim_star(klon,klev) + real f(klon), f0(klon) +!FH/IM save f0 + real zlevinter(klon) + logical debut + real seuil + +! + !nouvelles variables pour la convection + real Ale_bl(klon) + real Alp_bl(klon) + real alp_int(klon) + real ale_int(klon) + integer n_int(klon) + real fm_tot(klon) + real wght_th(klon,klev) + integer lalim_conv(klon) +!v1d logical therm +!v1d save therm + + character*2 str2 + character*10 str10 + + EXTERNAL SCOPY +! + +!----------------------------------------------------------------------- +! initialisation: +! --------------- +! + + seuil=0.25 + + if (debut) then + fm0=0. + entr0=0. + detr0=0. + + +! #define wrgrads_thermcell +#undef wrgrads_thermcell +#ifdef wrgrads_thermcell +! Initialisation des sorties grads pour les thermiques. +! Pour l'instant en 1D sur le point igout. +! Utilise par thermcell_out3d.h + str10='therm' + call inigrads(1,1,rlond(igout),1.,-180.,180.,jjm, & + & rlatd(igout),-90.,90.,1.,llm,pplay(igout,:),1., & + & ptimestep,str10,'therm ') +#endif + + + + endif + + fm=0. ; entr=0. ; detr=0. + + icount=icount+1 + +!IM 090508 beg +!print*,'=====================================================================' +!print*,'=====================================================================' +!print*,' PAS ',icount,' PAS ',icount,' PAS ',icount,' PAS ',icount +!print*,'=====================================================================' +!print*,'=====================================================================' +!IM 090508 end + + if (prt_level.ge.1) print*,'thermcell_main V4' + + sorties=.true. + IF(ngrid.NE.klon) THEN + PRINT* + PRINT*,'STOP dans convadj' + PRINT*,'ngrid =',ngrid + PRINT*,'klon =',klon + ENDIF +! +!Initialisation +! +! IF (1.eq.0) THEN +! do ig=1,klon +!FH/IM 130308 if ((debut).or.((.not.debut).and.(f0(ig).lt.1.e-10))) then +! if ((.not.debut).and.(f0(ig).lt.1.e-10)) then +! f0(ig)=1.e-5 +! zmax0(ig)=40. +!v1d therm=.false. +! endif +! enddo +! ENDIF !(1.eq.0) THEN + if (prt_level.ge.10)write(lunout,*) & + & 'WARNING thermcell_main f0=max(f0,1.e-2)' + do ig=1,klon + if (prt_level.ge.20) then + print*,'th_main ig f0',ig,f0(ig) + endif + f0(ig)=max(f0(ig),1.e-2) +!IMmarche pas ?! if (f0(ig)<1.e-2) f0(ig)=1.e-2 + enddo + +!----------------------------------------------------------------------- +! Calcul de T,q,ql a partir de Tl et qT dans l environnement +! -------------------------------------------------------------------- +! + CALL thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay, & + & pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,zqsat,lev_out) + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_env' + +!------------------------------------------------------------------------ +! -------------------- +! +! +! + + + + + + + + + + + +! +! +! wa, fraca, wd, fracd -------------------- zlev(2), rhobarz +! wh,wt,wo ... +! +! + + + + + + + + + + + zh,zu,zv,zo,rho +! +! +! -------------------- zlev(1) +! \\\\\\\\\\\\\\\\\\\\ +! +! + +!----------------------------------------------------------------------- +! Calcul des altitudes des couches +!----------------------------------------------------------------------- + + do l=2,nlay + zlev(:,l)=0.5*(pphi(:,l)+pphi(:,l-1))/RG + enddo + zlev(:,1)=0. + zlev(:,nlay+1)=(2.*pphi(:,klev)-pphi(:,klev-1))/RG + do l=1,nlay + zlay(:,l)=pphi(:,l)/RG + enddo +!calcul de l epaisseur des couches + do l=1,nlay + deltaz(:,l)=zlev(:,l+1)-zlev(:,l) + enddo + +! print*,'2 OK convect8' +!----------------------------------------------------------------------- +! Calcul des densites +!----------------------------------------------------------------------- + + do l=1,nlay + rho(:,l)=pplay(:,l)/(zpspsk(:,l)*RD*ztv(:,l)) + enddo + +!IM + if (prt_level.ge.10)write(lunout,*) & + & 'WARNING thermcell_main rhobarz(:,1)=rho(:,1)' + rhobarz(:,1)=rho(:,1) + + do l=2,nlay + rhobarz(:,l)=0.5*(rho(:,l)+rho(:,l-1)) + enddo + +!calcul de la masse + do l=1,nlay + masse(:,l)=(pplev(:,l)-pplev(:,l+1))/RG + enddo + + if (prt_level.ge.1) print*,'thermcell_main apres initialisation' + +!------------------------------------------------------------------ +! +! /|\ +! -------- | F_k+1 ------- +! ----> D_k +! /|\ <---- E_k , A_k +! -------- | F_k --------- +! ----> D_k-1 +! <---- E_k-1 , A_k-1 +! +! +! +! +! +! --------------------------- +! +! ----- F_lmax+1=0 ---------- \ +! lmax (zmax) | +! --------------------------- | +! | +! --------------------------- | +! | +! --------------------------- | +! | +! --------------------------- | +! | +! --------------------------- | +! | E +! --------------------------- | D +! | +! --------------------------- | +! | +! --------------------------- \ | +! lalim | | +! --------------------------- | | +! | | +! --------------------------- | | +! | A | +! --------------------------- | | +! | | +! --------------------------- | | +! lmin (=1 pour le moment) | | +! ----- F_lmin=0 ------------ / / +! +! --------------------------- +! ////////////////////////// +! +! +!============================================================================= +! Calculs initiaux ne faisant pas intervenir les changements de phase +!============================================================================= + +!------------------------------------------------------------------ +! 1. alim_star est le profil vertical de l'alimentation à la base du +! panache thermique, calculé à partir de la flotabilité de l'air sec +! 2. lmin et lalim sont les indices inferieurs et superieurs de alim_star +!------------------------------------------------------------------ +! + entr_star=0. ; detr_star=0. ; alim_star=0. ; alim_star_tot=0. + CALL thermcell_init(ngrid,nlay,ztv,zlay,zlev, & + & lalim,lmin,alim_star,alim_star_tot,lev_out) + +call test_ltherm(ngrid,nlay,pplev,pplay,lmin,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_init lmin ') +call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_init lalim ') + + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_init' + if (prt_level.ge.10) then + write(lunout1,*) 'Dans thermcell_main 1' + write(lunout1,*) 'lmin ',lmin(igout) + write(lunout1,*) 'lalim ',lalim(igout) + write(lunout1,*) ' ig l alim_star thetav' + write(lunout1,'(i6,i4,2e15.5)') (igout,l,alim_star(igout,l) & + & ,ztv(igout,l),l=1,lalim(igout)+4) + endif + +!v1d do ig=1,klon +!v1d if (alim_star(ig,1).gt.1.e-10) then +!v1d therm=.true. +!v1d endif +!v1d enddo +!----------------------------------------------------------------------------- +! 3. wmax_sec et zmax_sec sont les vitesses et altitudes maximum d'un +! panache sec conservatif (e=d=0) alimente selon alim_star +! Il s'agit d'un calcul de type CAPE +! zmax_sec est utilisé pour déterminer la géométrie du thermique. +!------------------------------------------------------------------------------ +! + CALL thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star, & + & lalim,lmin,zmax_sec,wmax_sec,lev_out) + +call test_ltherm(ngrid,nlay,pplev,pplay,lmin,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry lmin ') +call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry lalim ') + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_dry' + if (prt_level.ge.10) then + write(lunout1,*) 'Dans thermcell_main 1b' + write(lunout1,*) 'lmin ',lmin(igout) + write(lunout1,*) 'lalim ',lalim(igout) + write(lunout1,*) ' ig l alim_star entr_star detr_star f_star ' + write(lunout1,'(i6,i4,e15.5)') (igout,l,alim_star(igout,l) & + & ,l=1,lalim(igout)+4) + endif + + + +!--------------------------------------------------------------------------------- +!calcul du melange et des variables dans le thermique +!-------------------------------------------------------------------------------- +! + if (prt_level.ge.1) print*,'avant thermcell_plume ',lev_out +!IM 140508 CALL thermcell_plume(ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz, & + CALL thermcell_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz, & + & zlev,pplev,pphi,zpspsk,l_mix,r_aspect,alim_star,alim_star_tot, & + & lalim,zmax_sec,f0,detr_star,entr_star,f_star,ztva, & + & ztla,zqla,zqta,zha,zw2,zw_est,zqsatth,lmix,lmix_bis,linter & + & ,lev_out,lunout1,igout) + if (prt_level.ge.1) print*,'apres thermcell_plume ',lev_out + + call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lalim ') + call test_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lmix ') + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_plume' + if (prt_level.ge.10) then + write(lunout1,*) 'Dans thermcell_main 2' + write(lunout1,*) 'lmin ',lmin(igout) + write(lunout1,*) 'lalim ',lalim(igout) + write(lunout1,*) ' ig l alim_star entr_star detr_star f_star ' + write(lunout1,'(i6,i4,4e15.5)') (igout,l,alim_star(igout,l),entr_star(igout,l),detr_star(igout,l) & + & ,f_star(igout,l+1),l=1,nint(linter(igout))+5) + endif + +!------------------------------------------------------------------------------- +! Calcul des caracteristiques du thermique:zmax,zmix,wmax +!------------------------------------------------------------------------------- +! + CALL thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix,zw2, & + & zlev,lmax,zmax,zmax0,zmix,wmax,lev_out) + + + call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lalim ') + call test_ltherm(ngrid,nlay,pplev,pplay,lmin ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmin ') + call test_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmix ') + call test_ltherm(ngrid,nlay,pplev,pplay,lmax ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmax ') + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_height' + +!------------------------------------------------------------------------------- +! Fermeture,determination de f +!------------------------------------------------------------------------------- +! +!avant closure: on redéfinit lalim, alim_star_tot et alim_star +! do ig=1,klon +! do l=2,lalim(ig) +! alim_star(ig,l)=entr_star(ig,l) +! entr_star(ig,l)=0. +! enddo +! enddo + + CALL thermcell_closure(ngrid,nlay,r_aspect,ptimestep,rho, & + & zlev,lalim,alim_star,alim_star_tot,zmax_sec,wmax_sec,zmax,wmax,f,lev_out) + + if(prt_level.ge.1)print*,'thermcell_closure apres thermcell_closure' + + if (tau_thermals>1.) then + lambda=exp(-ptimestep/tau_thermals) + f0=(1.-lambda)*f+lambda*f0 + else + f0=f + endif + +! Test valable seulement en 1D mais pas genant + if (.not. (f0(1).ge.0.) ) then + stop 'Dans thermcell_main' + endif + +!------------------------------------------------------------------------------- +!deduction des flux +!------------------------------------------------------------------------------- + + CALL thermcell_flux2(ngrid,nlay,ptimestep,masse, & + & lalim,lmax,alim_star, & + & entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr, & + & detr,zqla,lev_out,lunout1,igout) +!IM 060508 & detr,zqla,zmax,lev_out,lunout,igout) + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_flux' + call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lalim ') + call test_ltherm(ngrid,nlay,pplev,pplay,lmax ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lmax ') + +!------------------------------------------------------------------ +! On ne prend pas directement les profils issus des calculs precedents +! mais on s'autorise genereusement une relaxation vers ceci avec +! une constante de temps tau_thermals (typiquement 1800s). +!------------------------------------------------------------------ + + if (tau_thermals>1.) then + lambda=exp(-ptimestep/tau_thermals) + fm0=(1.-lambda)*fm+lambda*fm0 + entr0=(1.-lambda)*entr+lambda*entr0 +! detr0=(1.-lambda)*detr+lambda*detr0 + else + fm0=fm + entr0=entr + detr0=detr + endif + +!c------------------------------------------------------------------ +! calcul du transport vertical +!------------------------------------------------------------------ + + call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse, & + & zthl,zdthladj,zta,lev_out) + call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse, & + & po,pdoadj,zoa,lev_out) + +!------------------------------------------------------------------ +! Calcul de la fraction de l'ascendance +!------------------------------------------------------------------ + do ig=1,klon + fraca(ig,1)=0. + fraca(ig,nlay+1)=0. + enddo + do l=2,nlay + do ig=1,klon + if (zw2(ig,l).gt.1.e-10) then + fraca(ig,l)=fm(ig,l)/(rhobarz(ig,l)*zw2(ig,l)) + else + fraca(ig,l)=0. + endif + enddo + enddo + +!------------------------------------------------------------------ +! calcul du transport vertical du moment horizontal +!------------------------------------------------------------------ + +!IM 090508 + if (1.eq.1) then +!IM 070508 vers. _dq +! if (1.eq.0) then + + +! Calcul du transport de V tenant compte d'echange par gradient +! de pression horizontal avec l'environnement + + call thermcell_dv2(ngrid,nlay,ptimestep,fm0,entr0,masse & + & ,fraca,zmax & + & ,zu,zv,pduadj,pdvadj,zua,zva,lev_out) +!IM 050508 & ,zu,zv,pduadj,pdvadj,zua,zva,igout,lev_out) + else + +! calcul purement conservatif pour le transport de V + call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse & + & ,zu,pduadj,zua,lev_out) + call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse & + & ,zv,pdvadj,zva,lev_out) + endif + +! print*,'13 OK convect8' + do l=1,nlay + do ig=1,ngrid + pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l) + enddo + enddo + + if (prt_level.ge.1) print*,'14 OK convect8' +!------------------------------------------------------------------ +! Calculs de diagnostiques pour les sorties +!------------------------------------------------------------------ +!calcul de fraca pour les sorties + + if (sorties) then + if (prt_level.ge.1) print*,'14a OK convect8' +! calcul du niveau de condensation +! initialisation + do ig=1,ngrid + nivcon(ig)=0 + zcon(ig)=0. + enddo +!nouveau calcul + do ig=1,ngrid + CHI=zh(ig,1)/(1669.0-122.0*zo(ig,1)/zqsat(ig,1)-zh(ig,1)) + pcon(ig)=pplay(ig,1)*(zo(ig,1)/zqsat(ig,1))**CHI + enddo + do k=1,nlay + do ig=1,ngrid + if ((pcon(ig).le.pplay(ig,k)) & + & .and.(pcon(ig).gt.pplay(ig,k+1))) then + zcon2(ig)=zlay(ig,k)-(pcon(ig)-pplay(ig,k))/(RG*rho(ig,k))/100. + endif + enddo + enddo + if (prt_level.ge.1) print*,'14b OK convect8' + do k=nlay,1,-1 + do ig=1,ngrid + if (zqla(ig,k).gt.1e-10) then + nivcon(ig)=k + zcon(ig)=zlev(ig,k) + endif + enddo + enddo + if (prt_level.ge.1) print*,'14c OK convect8' +!calcul des moments +!initialisation + do l=1,nlay + do ig=1,ngrid + q2(ig,l)=0. + wth2(ig,l)=0. + wth3(ig,l)=0. + ratqscth(ig,l)=0. + ratqsdiff(ig,l)=0. + enddo + enddo + if (prt_level.ge.1) print*,'14d OK convect8' + if (prt_level.ge.10)write(lunout,*) & + & 'WARNING thermcell_main wth2=0. si zw2 > 1.e-10' + do l=1,nlay + do ig=1,ngrid + zf=fraca(ig,l) + zf2=zf/(1.-zf) +! + if (prt_level.ge.10) print*,'14e OK convect8 ig,l,zf,zf2',ig,l,zf,zf2 +! + if (prt_level.ge.10) print*,'14f OK convect8 ig,l,zha zh zpspsk ',ig,l,zha(ig,l),zh(ig,l),zpspsk(ig,l) + thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l)/zpspsk(ig,l))**2 + if(zw2(ig,l).gt.1.e-10) then + wth2(ig,l)=zf2*(zw2(ig,l))**2 + else + wth2(ig,l)=0. + endif +! print*,'wth2=',wth2(ig,l) + wth3(ig,l)=zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l)) & + & *zw2(ig,l)*zw2(ig,l)*zw2(ig,l) + if (prt_level.ge.10) print*,'14g OK convect8 ig,l,po',ig,l,po(ig,l) + q2(ig,l)=zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2 +!test: on calcul q2/po=ratqsc + ratqscth(ig,l)=sqrt(max(q2(ig,l),1.e-6)/(po(ig,l)*1000.)) + enddo + enddo +!calcul de ale_bl et alp_bl +!pour le calcul d'une valeur intégrée entre la surface et lmax + do ig=1,ngrid + alp_int(ig)=0. + ale_int(ig)=0. + n_int(ig)=0 + enddo +! + do l=1,nlay + do ig=1,ngrid + if(l.LE.lmax(ig)) THEN + alp_int(ig)=alp_int(ig)+0.5*rhobarz(ig,l)*wth3(ig,l) + ale_int(ig)=ale_int(ig)+0.5*zw2(ig,l)**2 + n_int(ig)=n_int(ig)+1 + endif + enddo + enddo +! print*,'avant calcul ale et alp' +!calcul de ALE et ALP pour la convection + do ig=1,ngrid +! Alp_bl(ig)=0.5*rhobarz(ig,lmix_bis(ig))*wth3(ig,lmix(ig)) +! Alp_bl(ig)=0.5*rhobarz(ig,nivcon(ig))*wth3(ig,nivcon(ig)) +! Alp_bl(ig)=0.5*rhobarz(ig,lmix(ig))*wth3(ig,lmix(ig)) +! & *0.1 +!valeur integree de alp_bl * 0.5: + if (n_int(ig).gt.0) then + Alp_bl(ig)=0.5*alp_int(ig)/n_int(ig) +! if (Alp_bl(ig).lt.0.) then +! Alp_bl(ig)=0. + endif +! endif +! write(18,*),'rhobarz,wth3,Alp',rhobarz(ig,nivcon(ig)), +! s wth3(ig,nivcon(ig)),Alp_bl(ig) +! write(18,*),'ALP_BL',Alp_bl(ig),lmix(ig) +! Ale_bl(ig)=0.5*zw2(ig,lmix_bis(ig))**2 +! if (nivcon(ig).eq.1) then +! Ale_bl(ig)=0. +! else +!valeur max de ale_bl: + Ale_bl(ig)=0.5*zw2(ig,lmix(ig))**2 +! & /2. +! & *0.1 +! Ale_bl(ig)=0.5*zw2(ig,lmix_bis(ig))**2 +! if (n_int(ig).gt.0) then +! Ale_bl(ig)=ale_int(ig)/n_int(ig) +! Ale_bl(ig)=4. +! endif +! endif +! Ale_bl(ig)=0.5*wth2(ig,lmix_bis(ig)) +! Ale_bl(ig)=wth2(ig,nivcon(ig)) +! write(19,*),'wth2,ALE_BL',wth2(ig,nivcon(ig)),Ale_bl(ig) + enddo +!test:calcul de la ponderation des couches pour KE +!initialisations +! print*,'ponderation' + do ig=1,ngrid + fm_tot(ig)=0. + enddo + do ig=1,ngrid + do k=1,klev + wght_th(ig,k)=1. + enddo + enddo + do ig=1,ngrid +! lalim_conv(ig)=lmix_bis(ig) +!la hauteur de la couche alim_conv = hauteur couche alim_therm + lalim_conv(ig)=lalim(ig) +! zentr(ig)=zlev(ig,lalim(ig)) + enddo + do ig=1,ngrid + do k=1,lalim_conv(ig) + fm_tot(ig)=fm_tot(ig)+fm(ig,k) + enddo + enddo + do ig=1,ngrid + do k=1,lalim_conv(ig) + if (fm_tot(ig).gt.1.e-10) then +! wght_th(ig,k)=fm(ig,k)/fm_tot(ig) + endif +!on pondere chaque couche par a* + if (alim_star(ig,k).gt.1.e-10) then + wght_th(ig,k)=alim_star(ig,k) + else + wght_th(ig,k)=1. + endif + enddo + enddo +! print*,'apres wght_th' +!test pour prolonger la convection + do ig=1,ngrid +!v1d if ((alim_star(ig,1).lt.1.e-10).and.(therm)) then + if ((alim_star(ig,1).lt.1.e-10)) then + lalim_conv(ig)=1 + wght_th(ig,1)=1. +! print*,'lalim_conv ok',lalim_conv(ig),wght_th(ig,1) + endif + enddo + +!calcul du ratqscdiff + if (prt_level.ge.1) print*,'14e OK convect8' + var=0. + vardiff=0. + ratqsdiff(:,:)=0. + do ig=1,ngrid + do l=1,lalim(ig) + var=var+alim_star(ig,l)*zqta(ig,l)*1000. + enddo + enddo + if (prt_level.ge.1) print*,'14f OK convect8' + do ig=1,ngrid + do l=1,lalim(ig) + zf=fraca(ig,l) + zf2=zf/(1.-zf) + vardiff=vardiff+alim_star(ig,l) & + & *(zqta(ig,l)*1000.-var)**2 +! ratqsdiff=ratqsdiff+alim_star(ig,l)* +! s (zqta(ig,l)*1000.-po(ig,l)*1000.)**2 + enddo + enddo + if (prt_level.ge.1) print*,'14g OK convect8' + do l=1,nlay + do ig=1,ngrid + ratqsdiff(ig,l)=sqrt(vardiff)/(po(ig,l)*1000.) +! write(11,*)'ratqsdiff=',ratqsdiff(ig,l) + enddo + enddo +!-------------------------------------------------------------------- +! +!ecriture des fichiers sortie +! print*,'15 OK convect8' + + if (prt_level.ge.1) print*,'thermcell_main sorties 3D' +#ifdef wrgrads_thermcell +#include "thermcell_out3d.h" +#endif + + endif + + if (prt_level.ge.1) print*,'thermcell_main FIN OK' + +! if(icount.eq.501) stop'au pas 301 dans thermcell_main' + return + end + +!----------------------------------------------------------------------------- + + subroutine test_ltherm(klon,klev,pplev,pplay,long,seuil,ztv,po,ztva,zqla,f_star,zw2,comment) + IMPLICIT NONE +#include "iniprint.h" + + integer i, k, klon,klev + real pplev(klon,klev+1),pplay(klon,klev) + real ztv(klon,klev) + real po(klon,klev) + real ztva(klon,klev) + real zqla(klon,klev) + real f_star(klon,klev) + real zw2(klon,klev) + integer long(klon) + real seuil + character*21 comment + + if (prt_level.ge.1) THEN + print*,'WARNING !!! TEST ',comment + endif + return + +! test sur la hauteur des thermiques ... + do i=1,klon +!IMtemp if (pplay(i,long(i)).lt.seuil*pplev(i,1)) then + if (prt_level.ge.10) then + print*,'WARNING ',comment,' au point ',i,' K= ',long(i) + print*,' K P(MB) THV(K) Qenv(g/kg)THVA QLA(g/kg) F* W2' + do k=1,klev + write(6,'(i3,7f10.3)') k,pplay(i,k),ztv(i,k),1000*po(i,k),ztva(i,k),1000*zqla(i,k),f_star(i,k),zw2(i,k) + enddo +! stop + endif + enddo + + + return + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_old.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_old.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_old.F (revision 1280) @@ -0,0 +1,6130 @@ + SUBROUTINE thermcell_2002(ngrid,nlay,ptimestep + s ,pplay,pplev,pphi + s ,pu,pv,pt,po + s ,pduadj,pdvadj,pdtadj,pdoadj + s ,fm0,entr0 +c s ,pu_therm,pv_therm + s ,r_aspect,l_mix,w2di,tho) + + USE dimphy + IMPLICIT NONE + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c +c Réécriture à partir d'un listing papier à Habas, le 14/02/00 +c +c le thermique est supposé homogène et dissipé par mélange avec +c son environnement. la longueur l_mix contrôle l'efficacité du +c mélange +c +c Le calcul du transport des différentes espèces se fait en prenant +c en compte: +c 1. un flux de masse montant +c 2. un flux de masse descendant +c 3. un entrainement +c 4. un detrainement +c +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" + +c arguments: +c ---------- + + INTEGER ngrid,nlay,w2di,tho + real ptimestep,l_mix,r_aspect + REAL pt(ngrid,nlay),pdtadj(ngrid,nlay) + REAL pu(ngrid,nlay),pduadj(ngrid,nlay) + REAL pv(ngrid,nlay),pdvadj(ngrid,nlay) + REAL po(ngrid,nlay),pdoadj(ngrid,nlay) + REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1) + real pphi(ngrid,nlay) + + integer idetr + save idetr + data idetr/3/ +c$OMP THREADPRIVATE(idetr) + +c local: +c ------ + + INTEGER ig,k,l,lmax(klon,klev+1),lmaxa(klon),lmix(klon) + real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz + + real zlev(klon,klev+1),zlay(klon,klev) + REAL zh(klon,klev),zdhadj(klon,klev) + REAL ztv(klon,klev) + real zu(klon,klev),zv(klon,klev),zo(klon,klev) + REAL wh(klon,klev+1) + real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1) + real zla(klon,klev+1) + real zwa(klon,klev+1) + real zld(klon,klev+1) + real zwd(klon,klev+1) + real zsortie(klon,klev) + real zva(klon,klev) + real zua(klon,klev) + real zoa(klon,klev) + + real zha(klon,klev) + real wa_moy(klon,klev+1) + real fraca(klon,klev+1) + real fracc(klon,klev+1) + real zf,zf2 + real thetath2(klon,klev),wth2(klon,klev) +! common/comtherm/thetath2,wth2 + + real count_time + integer isplit,nsplit,ialt + parameter (nsplit=10) + data isplit/0/ + save isplit +c$OMP THREADPRIVATE(isplit) + + logical sorties + real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev) + real zpspsk(klon,klev) + + real wmax(klon,klev),wmaxa(klon) + + real wa(klon,klev,klev+1) + real wd(klon,klev+1) + real larg_part(klon,klev,klev+1) + real fracd(klon,klev+1) + real xxx(klon,klev+1) + real larg_cons(klon,klev+1) + real larg_detr(klon,klev+1) + real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev) + real pu_therm(klon,klev),pv_therm(klon,klev) + real fm(klon,klev+1),entr(klon,klev) + real fmc(klon,klev+1) + + character (len=2) :: str2 + character (len=10) :: str10 + + LOGICAL vtest(klon),down + + EXTERNAL SCOPY + + integer ncorrec,ll + save ncorrec + data ncorrec/0/ +c$OMP THREADPRIVATE(ncorrec) + +c +c----------------------------------------------------------------------- +c initialisation: +c --------------- +c + sorties=.true. + IF(ngrid.NE.klon) THEN + PRINT* + PRINT*,'STOP dans convadj' + PRINT*,'ngrid =',ngrid + PRINT*,'klon =',klon + ENDIF +c +c----------------------------------------------------------------------- +c incrementation eventuelle de tendances precedentes: +c --------------------------------------------------- + + print*,'0 OK convect8' + + DO 1010 l=1,nlay + DO 1015 ig=1,ngrid + zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA + zh(ig,l)=pt(ig,l)/zpspsk(ig,l) + zu(ig,l)=pu(ig,l) + zv(ig,l)=pv(ig,l) + zo(ig,l)=po(ig,l) + ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l)) +1015 CONTINUE +1010 CONTINUE + +c print*,'1 OK convect8' +c -------------------- +c +c +c + + + + + + + + + + + +c +c +c wa, fraca, wd, fracd -------------------- zlev(2), rhobarz +c wh,wt,wo ... +c +c + + + + + + + + + + + zh,zu,zv,zo,rho +c +c +c -------------------- zlev(1) +c \\\\\\\\\\\\\\\\\\\\ +c +c + +c----------------------------------------------------------------------- +c Calcul des altitudes des couches +c----------------------------------------------------------------------- + + do l=2,nlay + do ig=1,ngrid + zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG + enddo + enddo + do ig=1,ngrid + zlev(ig,1)=0. + zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG + enddo + do l=1,nlay + do ig=1,ngrid + zlay(ig,l)=pphi(ig,l)/RG + enddo + enddo + +c print*,'2 OK convect8' +c----------------------------------------------------------------------- +c Calcul des densites +c----------------------------------------------------------------------- + + do l=1,nlay + do ig=1,ngrid + rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l)) + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1)) + enddo + enddo + + do k=1,nlay + do l=1,nlay+1 + do ig=1,ngrid + wa(ig,k,l)=0. + enddo + enddo + enddo + +c print*,'3 OK convect8' +c------------------------------------------------------------------ +c Calcul de w2, quarre de w a partir de la cape +c a partir de w2, on calcule wa, vitesse de l'ascendance +c +c ATTENTION: Dans cette version, pour cause d'economie de memoire, +c w2 est stoke dans wa +c +c ATTENTION: dans convect8, on n'utilise le calcule des wa +c independants par couches que pour calculer l'entrainement +c a la base et la hauteur max de l'ascendance. +c +c Indicages: +c l'ascendance provenant du niveau k traverse l'interface l avec +c une vitesse wa(k,l). +c +c -------------------- +c +c + + + + + + + + + + +c +c wa(k,l) ---- -------------------- l +c /\ +c /||\ + + + + + + + + + + +c || +c || -------------------- +c || +c || + + + + + + + + + + +c || +c || -------------------- +c ||__ +c |___ + + + + + + + + + + k +c +c -------------------- +c +c +c +c------------------------------------------------------------------ + + + do k=1,nlay-1 + do ig=1,ngrid + wa(ig,k,k)=0. + wa(ig,k,k+1)=2.*RG*(ztv(ig,k)-ztv(ig,k+1))/ztv(ig,k+1) + s *(zlev(ig,k+1)-zlev(ig,k)) + enddo + do l=k+1,nlay-1 + do ig=1,ngrid + wa(ig,k,l+1)=wa(ig,k,l)+ + s 2.*RG*(ztv(ig,k)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + enddo + enddo + do ig=1,ngrid + wa(ig,k,nlay+1)=0. + enddo + enddo + +c print*,'4 OK convect8' +c Calcul de la couche correspondant a la hauteur du thermique + do k=1,nlay-1 + do ig=1,ngrid + lmax(ig,k)=k + enddo + do l=nlay,k+1,-1 + do ig=1,ngrid + if(wa(ig,k,l).le.1.e-10) lmax(ig,k)=l-1 + enddo + enddo + enddo + +c print*,'5 OK convect8' +c Calcule du w max du thermique + do k=1,nlay + do ig=1,ngrid + wmax(ig,k)=0. + enddo + enddo + + do k=1,nlay-1 + do l=k,nlay + do ig=1,ngrid + if (l.le.lmax(ig,k)) then + wa(ig,k,l)=sqrt(wa(ig,k,l)) + wmax(ig,k)=max(wmax(ig,k),wa(ig,k,l)) + else + wa(ig,k,l)=0. + endif + enddo + enddo + enddo + + do k=1,nlay-1 + do ig=1,ngrid + pu_therm(ig,k)=sqrt(wmax(ig,k)) + pv_therm(ig,k)=sqrt(wmax(ig,k)) + enddo + enddo + +c print*,'6 OK convect8' +c Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=500. + enddo +c print*,'LMAX LMAX LMAX ' + do k=1,nlay-1 + do ig=1,ngrid + zmax(ig)=max(zmax(ig),zlev(ig,lmax(ig,k))-zlev(ig,k)) + enddo +c print*,k,lmax(1,k) + enddo +c print*,'ZMAX ZMAX ZMAX ',zmax +c call dump2d(iim,jjm-1,zmax(2:ngrid-1),'ZMAX ') + +c Calcul de l'entrainement. +c Le rapport d'aspect relie la largeur de l'ascendance a l'epaisseur +c de la couche d'alimentation en partant du principe que la vitesse +c maximum dans l'ascendance est la vitesse d'entrainement horizontale. + do k=1,nlay + do ig=1,ngrid + zzz=rho(ig,k)*wmax(ig,k)*(zlev(ig,k+1)-zlev(ig,k)) + s /(zmax(ig)*r_aspect) + if(w2di.eq.2) then + entr(ig,k)=entr(ig,k)+ + s ptimestep*(zzz-entr(ig,k))/float(tho) + else + entr(ig,k)=zzz + endif + ztva(ig,k)=ztv(ig,k) + enddo + enddo + +c print*,'7 OK convect8' + do k=1,klev+1 + do ig=1,ngrid + zw2(ig,k)=0. + fmc(ig,k)=0. + larg_cons(ig,k)=0. + larg_detr(ig,k)=0. + wa_moy(ig,k)=0. + enddo + enddo + +c print*,'8 OK convect8' + do ig=1,ngrid + lmaxa(ig)=1 + lmix(ig)=1 + wmaxa(ig)=0. + enddo + + + do l=1,nlay-2 + do ig=1,ngrid +c if (zw2(ig,l).lt.1.e-10.and.ztv(ig,l).gt.ztv(ig,l+1)) then +c print*,'COUCOU ',l,zw2(ig,l),ztv(ig,l),ztv(ig,l+1) + if (zw2(ig,l).lt.1.e-10.and.ztv(ig,l).gt.ztv(ig,l+1) + s .and.entr(ig,l).gt.1.e-10) then +c print*,'COUCOU cas 1' +c Initialisation de l'ascendance +c lmix(ig)=1 + ztva(ig,l)=ztv(ig,l) + fmc(ig,l)=0. + fmc(ig,l+1)=entr(ig,l) + zw2(ig,l)=0. +c if (.not.ztv(ig,l+1).gt.150.) then +c print*,'ig,l+1,ztv(ig,l+1)' +c print*, ig,l+1,ztv(ig,l+1) +c stop'dans thermiques' +c endif + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) + s *(zlev(ig,l+1)-zlev(ig,l)) + larg_detr(ig,l)=0. + else if (zw2(ig,l).ge.1.e-10.and. + . fmc(ig,l)+entr(ig,l).gt.1.e-10) then +c Incrementation... + fmc(ig,l+1)=fmc(ig,l)+entr(ig,l) +c if (.not.fmc(ig,l+1).gt.1.e-15) then +c print*,'ig,l+1,fmc(ig,l+1)' +c print*, ig,l+1,fmc(ig,l+1) +c print*,'Fmc ',(fmc(ig,ll),ll=1,klev+1) +c print*,'W2 ',(zw2(ig,ll),ll=1,klev+1) +c print*,'Tv ',(ztv(ig,ll),ll=1,klev) +c print*,'Entr ',(entr(ig,ll),ll=1,klev) +c stop'dans thermiques' +c endif + ztva(ig,l)=(fmc(ig,l)*ztva(ig,l-1)+entr(ig,l)*ztv(ig,l)) + s /fmc(ig,l+1) +c mise a jour de la vitesse ascendante (l'air entraine de la couche +c consideree commence avec une vitesse nulle). + zw2(ig,l+1)=zw2(ig,l)*(fmc(ig,l)/fmc(ig,l+1))**2+ + s 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + endif + if (zw2(ig,l+1).lt.0.) then + zw2(ig,l+1)=0. + lmaxa(ig)=l + else + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + endif + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +c lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif +c print*,'COUCOU cas 2 LMIX=',lmix(ig),wa_moy(ig,l+1),wmaxa(ig) + enddo + enddo + +c print*,'9 OK convect8' +c print*,'WA1 ',wa_moy + +c determination de l'indice du debut de la mixed layer ou w decroit + +c calcul de la largeur de chaque ascendance dans le cas conservatif. +c dans ce cas simple, on suppose que la largeur de l'ascendance provenant +c d'une couche est égale à la hauteur de la couche alimentante. +c La vitesse maximale dans l'ascendance est aussi prise comme estimation +c de la vitesse d'entrainement horizontal dans la couche alimentante. + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then + zw=max(wa_moy(ig,l),1.e-10) + larg_cons(ig,l)=zmax(ig)*r_aspect + s *fmc(ig,l)/(rhobarz(ig,l)*zw) + endif + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then +c if (idetr.eq.0) then +c cette option est finalement en dur. + larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c else if (idetr.eq.1) then +c larg_detr(ig,l)=larg_cons(ig,l) +c s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) +c else if (idetr.eq.2) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *sqrt(wa_moy(ig,l)) +c else if (idetr.eq.4) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *wa_moy(ig,l) +c endif + endif + enddo + enddo + +c print*,'10 OK convect8' +c print*,'WA2 ',wa_moy +c calcul de la fraction de la maille concernée par l'ascendance en tenant +c compte de l'epluchage du thermique. + + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then +c print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l)) + s /(r_aspect*zmax(ig)) + if(l.gt.lmix(ig)) then + xxx(ig,l)=(lmaxa(ig)+1.-l) / (lmaxa(ig)+1.-lmix(ig)) + if (idetr.eq.0) then + fraca(ig,l)=fraca(ig,lmix(ig)) + else if (idetr.eq.1) then + fraca(ig,l)=fraca(ig,lmix(ig))*xxx(ig,l) + else if (idetr.eq.2) then + fraca(ig,l)=fraca(ig,lmix(ig))*(1.-(1.-xxx(ig,l))**2) + else + fraca(ig,l)=fraca(ig,lmix(ig))*xxx(ig,l)**2 + endif + endif +c print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + else +c wa_moy(ig,l)=0. + fraca(ig,l)=0. + fracc(ig,l)=0. + fracd(ig,l)=1. + endif + enddo + enddo + +c print*,'11 OK convect8' +c print*,'Ea3 ',wa_moy +c------------------------------------------------------------------ +c Calcul de fracd, wd +c somme wa - wd = 0 +c------------------------------------------------------------------ + + + do ig=1,ngrid + fm(ig,1)=0. + fm(ig,nlay+1)=0. + enddo + + do l=2,nlay + do ig=1,ngrid + fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l) + enddo + do ig=1,ngrid + if(fracd(ig,l).lt.0.1) then + stop'fracd trop petit' + else +c vitesse descendante "diagnostique" + wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l)) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid +c masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG + enddo + enddo + +c print*,'12 OK convect8' +c print*,'WA4 ',wa_moy +cc------------------------------------------------------------------ +c calcul du transport vertical +c------------------------------------------------------------------ + + go to 4444 +c print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + do l=2,nlay-1 + do ig=1,ngrid + if(fm(ig,l+1)*ptimestep.gt.masse(ig,l) + s .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then +c print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' +c s ,fm(ig,l+1)*ptimestep +c s ,' M=',masse(ig,l),masse(ig,l+1) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then +c print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' +c s ,entr(ig,l)*ptimestep +c s ,' M=',masse(ig,l) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then +c print*,'WARN!!! fm exagere ig=',ig,' l=',l +c s ,' FM=',fm(ig,l) + endif + if(.not.masse(ig,l).ge.1.e-10 + s .or..not.masse(ig,l).le.1.e4) then +c print*,'WARN!!! masse exagere ig=',ig,' l=',l +c s ,' M=',masse(ig,l) +c print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', +c s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) +c print*,'zlev(ig,l+1),zlev(ig,l)' +c s ,zlev(ig,l+1),zlev(ig,l) +c print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' +c s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + endif + if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then +c print*,'WARN!!! entr exagere ig=',ig,' l=',l +c s ,' E=',entr(ig,l) + endif + enddo + enddo + +4444 continue + + if (w2di.eq.1) then + fm0=fm0+ptimestep*(fm-fm0)/float(tho) + entr0=entr0+ptimestep*(entr-entr0)/float(tho) + else + fm0=fm + entr0=entr + endif + + if (1.eq.1) then + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zh,zdhadj,zha) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zo,pdoadj,zoa) + else + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zh,zdhadj,zha) + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zo,pdoadj,zoa) + endif + + if (1.eq.0) then + call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,fraca,zmax + . ,zu,zv,pduadj,pdvadj,zua,zva) + else + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zu,pduadj,zua) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zv,pdvadj,zva) + endif + + do l=1,nlay + do ig=1,ngrid + zf=0.5*(fracc(ig,l)+fracc(ig,l+1)) + zf2=zf/(1.-zf) + thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2 + wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 + enddo + enddo + + + +c print*,'13 OK convect8' +c print*,'WA5 ',wa_moy + do l=1,nlay + do ig=1,ngrid + pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l) + enddo + enddo + + +c do l=1,nlay +c do ig=1,ngrid +c if(abs(pdtadj(ig,l))*86400..gt.500.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdtadj=',pdtadj(ig,l) +c endif +c if(abs(pdoadj(ig,l))*86400..gt.1.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdoadj=',pdoadj(ig,l) +c endif +c enddo +c enddo + +c print*,'14 OK convect8' +c------------------------------------------------------------------ +c Calculs pour les sorties +c------------------------------------------------------------------ + + if(sorties) then + do l=1,nlay + do ig=1,ngrid + zla(ig,l)=(1.-fracd(ig,l))*zmax(ig) + zld(ig,l)=fracd(ig,l)*zmax(ig) + if(1.-fracd(ig,l).gt.1.e-10) + s zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l)) + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) + if (detr(ig,l).lt.0.) then + entr(ig,l)=entr(ig,l)-detr(ig,l) + detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l + endif + enddo + enddo + +c print*,'15 OK convect8' + + isplit=isplit+1 + + +c #define und + goto 123 +#ifdef und + CALL writeg1d(1,nlay,wd,'wd ','wd ') + CALL writeg1d(1,nlay,zwa,'wa ','wa ') + CALL writeg1d(1,nlay,fracd,'fracd ','fracd ') + CALL writeg1d(1,nlay,fraca,'fraca ','fraca ') + CALL writeg1d(1,nlay,wa_moy,'wam ','wam ') + CALL writeg1d(1,nlay,zla,'la ','la ') + CALL writeg1d(1,nlay,zld,'ld ','ld ') + CALL writeg1d(1,nlay,pt,'pt ','pt ') + CALL writeg1d(1,nlay,zh,'zh ','zh ') + CALL writeg1d(1,nlay,zha,'zha ','zha ') + CALL writeg1d(1,nlay,zu,'zu ','zu ') + CALL writeg1d(1,nlay,zv,'zv ','zv ') + CALL writeg1d(1,nlay,zo,'zo ','zo ') + CALL writeg1d(1,nlay,wh,'wh ','wh ') + CALL writeg1d(1,nlay,wu,'wu ','wu ') + CALL writeg1d(1,nlay,wv,'wv ','wv ') + CALL writeg1d(1,nlay,wo,'w15uo ','wXo ') + CALL writeg1d(1,nlay,zdhadj,'zdhadj ','zdhadj ') + CALL writeg1d(1,nlay,pduadj,'pduadj ','pduadj ') + CALL writeg1d(1,nlay,pdvadj,'pdvadj ','pdvadj ') + CALL writeg1d(1,nlay,pdoadj,'pdoadj ','pdoadj ') + CALL writeg1d(1,nlay,entr ,'entr ','entr ') + CALL writeg1d(1,nlay,detr ,'detr ','detr ') + CALL writeg1d(1,nlay,fm ,'fm ','fm ') + + CALL writeg1d(1,nlay,pdtadj,'pdtadj ','pdtadj ') + CALL writeg1d(1,nlay,pplay,'pplay ','pplay ') + CALL writeg1d(1,nlay,pplev,'pplev ','pplev ') +c recalcul des flux en diagnostique... +c print*,'PAS DE TEMPS ',ptimestep + call dt2F(pplev,pplay,pt,pdtadj,wh) + CALL writeg1d(1,nlay,wh,'wh2 ','wh2 ') +#endif +123 continue +! #define troisD +#ifdef troisD +c if (sorties) then + print*,'Debut des wrgradsfi' + +c print*,'16 OK convect8' + call wrgradsfi(1,nlay,wd,'wd ','wd ') + call wrgradsfi(1,nlay,zwa,'wa ','wa ') + call wrgradsfi(1,nlay,fracd,'fracd ','fracd ') + call wrgradsfi(1,nlay,fraca,'fraca ','fraca ') + call wrgradsfi(1,nlay,xxx,'xxx ','xxx ') + call wrgradsfi(1,nlay,wa_moy,'wam ','wam ') +c print*,'WA6 ',wa_moy + call wrgradsfi(1,nlay,zla,'la ','la ') + call wrgradsfi(1,nlay,zld,'ld ','ld ') + call wrgradsfi(1,nlay,pt,'pt ','pt ') + call wrgradsfi(1,nlay,zh,'zh ','zh ') + call wrgradsfi(1,nlay,zha,'zha ','zha ') + call wrgradsfi(1,nlay,zua,'zua ','zua ') + call wrgradsfi(1,nlay,zva,'zva ','zva ') + call wrgradsfi(1,nlay,zu,'zu ','zu ') + call wrgradsfi(1,nlay,zv,'zv ','zv ') + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,wh,'wh ','wh ') + call wrgradsfi(1,nlay,wu,'wu ','wu ') + call wrgradsfi(1,nlay,wv,'wv ','wv ') + call wrgradsfi(1,nlay,wo,'wo ','wo ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,nlay,zdhadj,'zdhadj ','zdhadj ') + call wrgradsfi(1,nlay,pduadj,'pduadj ','pduadj ') + call wrgradsfi(1,nlay,pdvadj,'pdvadj ','pdvadj ') + call wrgradsfi(1,nlay,pdoadj,'pdoadj ','pdoadj ') + call wrgradsfi(1,nlay,entr,'entr ','entr ') + call wrgradsfi(1,nlay,detr,'detr ','detr ') + call wrgradsfi(1,nlay,fm,'fm ','fm ') + call wrgradsfi(1,nlay,fmc,'fmc ','fmc ') + call wrgradsfi(1,nlay,zw2,'zw2 ','zw2 ') + call wrgradsfi(1,nlay,ztva,'ztva ','ztva ') + call wrgradsfi(1,nlay,ztv,'ztv ','ztv ') + + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,larg_cons,'Lc ','Lc ') + call wrgradsfi(1,nlay,larg_detr,'Ldetr ','Ldetr ') + + +c print*,'17 OK convect8' + + do k=1,klev/10 + write(str2,'(i2.2)') k + str10='wa'//str2 + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=wa(ig,k,l) + enddo + enddo + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=larg_part(ig,k,l) + enddo + enddo + str10='la'//str2 + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + enddo + + +c print*,'18 OK convect8' +c endif + print*,'Fin des wrgradsfi' +#endif + + endif + +c if(wa_moy(1,4).gt.1.e-10) stop + +c print*,'19 OK convect8' + return + end + + SUBROUTINE thermcell_cld(ngrid,nlay,ptimestep + s ,pplay,pplev,pphi,zlev,debut + s ,pu,pv,pt,po + s ,pduadj,pdvadj,pdtadj,pdoadj + s ,fm0,entr0,zqla,lmax + s ,zmax_sec,wmax_sec,zw_sec,lmix_sec + s ,ratqscth,ratqsdiff +c s ,pu_therm,pv_therm + s ,r_aspect,l_mix,w2di,tho) + + USE dimphy + IMPLICIT NONE + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c +c Réécriture à partir d'un listing papier à Habas, le 14/02/00 +c +c le thermique est supposé homogène et dissipé par mélange avec +c son environnement. la longueur l_mix contrôle l'efficacité du +c mélange +c +c Le calcul du transport des différentes espèces se fait en prenant +c en compte: +c 1. un flux de masse montant +c 2. un flux de masse descendant +c 3. un entrainement +c 4. un detrainement +c +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" + +c arguments: +c ---------- + + INTEGER ngrid,nlay,w2di,tho + real ptimestep,l_mix,r_aspect + REAL pt(ngrid,nlay),pdtadj(ngrid,nlay) + REAL pu(ngrid,nlay),pduadj(ngrid,nlay) + REAL pv(ngrid,nlay),pdvadj(ngrid,nlay) + REAL po(ngrid,nlay),pdoadj(ngrid,nlay) + REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1) + real pphi(ngrid,nlay) + + integer idetr + save idetr + data idetr/3/ +c$OMP THREADPRIVATE(idetr) + +c local: +c ------ + + INTEGER ig,k,l,lmaxa(klon),lmix(klon) + real zsortie1d(klon) +c CR: on remplace lmax(klon,klev+1) + INTEGER lmax(klon),lmin(klon),lentr(klon) + real linter(klon) + real zmix(klon), fracazmix(klon) + real alpha + save alpha + data alpha/1./ +c$OMP THREADPRIVATE(alpha) + +c RC + real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz + real zmax_sec(klon) + real zmax_sec2(klon) + real zw_sec(klon,klev+1) + INTEGER lmix_sec(klon) + real w_est(klon,klev+1) +con garde le zmax du pas de temps precedent +c real zmax0(klon) +c save zmax0 +c real zmix0(klon) +c save zmix0 + REAL, SAVE, ALLOCATABLE :: zmax0(:), zmix0(:) +c$OMP THREADPRIVATE(zmax0, zmix0) + + real zlev(klon,klev+1),zlay(klon,klev) + real deltaz(klon,klev) + REAL zh(klon,klev),zdhadj(klon,klev) + real zthl(klon,klev),zdthladj(klon,klev) + REAL ztv(klon,klev) + real zu(klon,klev),zv(klon,klev),zo(klon,klev) + real zl(klon,klev) + REAL wh(klon,klev+1) + real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1) + real zla(klon,klev+1) + real zwa(klon,klev+1) + real zld(klon,klev+1) + real zwd(klon,klev+1) + real zsortie(klon,klev) + real zva(klon,klev) + real zua(klon,klev) + real zoa(klon,klev) + + real zta(klon,klev) + real zha(klon,klev) + real wa_moy(klon,klev+1) + real fraca(klon,klev+1) + real fracc(klon,klev+1) + real zf,zf2 + real thetath2(klon,klev),wth2(klon,klev),wth3(klon,klev) + real q2(klon,klev) + real dtheta(klon,klev) +! common/comtherm/thetath2,wth2 + + real ratqscth(klon,klev) + real sum + real sumdiff + real ratqsdiff(klon,klev) + real count_time + integer isplit,nsplit,ialt + parameter (nsplit=10) + data isplit/0/ + save isplit +c$OMP THREADPRIVATE(isplit) + + logical sorties + real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev) + real zpspsk(klon,klev) + +c real wmax(klon,klev),wmaxa(klon) + real wmax(klon),wmaxa(klon) + real wmax_sec(klon) + real wmax_sec2(klon) + real wa(klon,klev,klev+1) + real wd(klon,klev+1) + real larg_part(klon,klev,klev+1) + real fracd(klon,klev+1) + real xxx(klon,klev+1) + real larg_cons(klon,klev+1) + real larg_detr(klon,klev+1) + real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev) + real massetot(klon,klev) + real detr0(klon,klev) + real alim0(klon,klev) + real pu_therm(klon,klev),pv_therm(klon,klev) + real fm(klon,klev+1),entr(klon,klev) + real fmc(klon,klev+1) + + real zcor,zdelta,zcvm5,qlbef + real Tbef(klon),qsatbef(klon) + real dqsat_dT,DT,num,denom + REAL REPS,RLvCp,DDT0 + real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev) +cCR niveau de condensation + real nivcon(klon) + real zcon(klon) + real zqsat(klon,klev) + real zqsatth(klon,klev) + PARAMETER (DDT0=.01) + + +cCR:nouvelles variables + real f_star(klon,klev+1),entr_star(klon,klev) + real detr_star(klon,klev) + real alim_star_tot(klon),alim_star2(klon) + real entr_star_tot(klon) + real detr_star_tot(klon) + real alim_star(klon,klev) + real alim(klon,klev) + real nu(klon,klev) + real nu_e(klon,klev) + real nu_min + real nu_max + real nu_r + real f(klon) +c real f(klon), f0(klon) +c save f0 + REAL,SAVE, ALLOCATABLE :: f0(:) +c$OMP THREADPRIVATE(f0) + + real f_old + real zlevinter(klon) + logical, save :: first = .true. +c$OMP THREADPRIVATE(first) +c data first /.false./ +c save first + logical nuage +c save nuage + logical boucle + logical therm + logical debut + logical rale + integer test(klon) + integer signe_zw2 +cRC + + character*2 str2 + character*10 str10 + + LOGICAL vtest(klon),down + LOGICAL Zsat(klon) + + EXTERNAL SCOPY + + integer ncorrec,ll + save ncorrec + data ncorrec/0/ +c$OMP THREADPRIVATE(ncorrec) + +c + +c----------------------------------------------------------------------- +c initialisation: +c --------------- +c + if (first) then + allocate(zmix0(klon)) + allocate(zmax0(klon)) + allocate(f0(klon)) + first=.false. + endif + + sorties=.false. +c print*,'NOUVEAU DETR PLUIE ' + IF(ngrid.NE.klon) THEN + PRINT* + PRINT*,'STOP dans convadj' + PRINT*,'ngrid =',ngrid + PRINT*,'klon =',klon + ENDIF +c +c Initialisation + RLvCp = RLVTT/RCPD + REPS = RD/RV +cinitialisations de zqsat + DO ll=1,nlay + DO ig=1,ngrid + zqsat(ig,ll)=0. + zqsatth(ig,ll)=0. + ENDDO + ENDDO +c +con met le first a true pour le premier passage de la journée + do ig=1,klon + test(ig)=0 + enddo + if (debut) then + do ig=1,klon + test(ig)=1 + f0(ig)=0. + zmax0(ig)=0. + enddo + endif + do ig=1,klon + if ((.not.debut).and.(f0(ig).lt.1.e-10)) then + test(ig)=1 + endif + enddo +c do ig=1,klon +c print*,'test(ig)',test(ig),zmax0(ig) +c enddo + nuage=.false. +c----------------------------------------------------------------------- +cAM Calcul de T,q,ql a partir de Tl et qT +c --------------------------------------------------- +c +c Pr Tprec=Tl calcul de qsat +c Si qsat>qT T=Tl, q=qT +c Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) +c On cherche DDT < DDT0 +c +c defaut + DO ll=1,nlay + DO ig=1,ngrid + zo(ig,ll)=po(ig,ll) + zl(ig,ll)=0. + zh(ig,ll)=pt(ig,ll) + EndDO + EndDO + do ig=1,ngrid + Zsat(ig)=.false. + enddo +c +c + DO ll=1,nlay +c les points insatures sont definitifs + DO ig=1,ngrid + Tbef(ig)=pt(ig,ll) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll) + qsatbef(ig)=MIN(0.5,qsatbef(ig)) + zcor=1./(1.-retv*qsatbef(ig)) + qsatbef(ig)=qsatbef(ig)*zcor + Zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig)) .gt. 1.e-10) + EndDO + + DO ig=1,ngrid + if (Zsat(ig).and.(1.eq.1)) then + qlbef=max(0.,po(ig,ll)-qsatbef(ig)) +c si sature: ql est surestime, d'ou la sous-relax + DT = 0.5*RLvCp*qlbef +c write(18,*),'DT0=',DT +c on pourra enchainer 2 ou 3 calculs sans Do while + do while (abs(DT).gt.DDT0) +c il faut verifier si c,a conserve quand on repasse en insature ... + Tbef(ig)=Tbef(ig)+DT + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll) + qsatbef(ig)=MIN(0.5,qsatbef(ig)) + zcor=1./(1.-retv*qsatbef(ig)) + qsatbef(ig)=qsatbef(ig)*zcor +c on veut le signe de qlbef + qlbef=po(ig,ll)-qsatbef(ig) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta + zcor=1./(1.-retv*qsatbef(ig)) + dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor) + num=-Tbef(ig)+pt(ig,ll)+RLvCp*qlbef + denom=1.+RLvCp*dqsat_dT + if (denom.lt.1.e-10) then + print*,'pb denom' + endif + DT=num/denom + enddo +c on ecrit de maniere conservative (sat ou non) + zl(ig,ll) = max(0.,qlbef) +c T = Tl +Lv/Cp ql + zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll) + zo(ig,ll) = po(ig,ll)-zl(ig,ll) + endif +con ecrit zqsat + zqsat(ig,ll)=qsatbef(ig) + EndDO + EndDO +cAM fin +c +c----------------------------------------------------------------------- +c incrementation eventuelle de tendances precedentes: +c --------------------------------------------------- + +c print*,'0 OK convect8' + + DO 1010 l=1,nlay + DO 1015 ig=1,ngrid + zpspsk(ig,l)=(pplay(ig,l)/100000.)**RKAPPA +c zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA +c zh(ig,l)=pt(ig,l)/zpspsk(ig,l) + zu(ig,l)=pu(ig,l) + zv(ig,l)=pv(ig,l) +c zo(ig,l)=po(ig,l) +c ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l)) +cAM attention zh est maintenant le profil de T et plus le profil de theta ! +c +c T-> Theta + ztv(ig,l)=zh(ig,l)/zpspsk(ig,l) +cAM Theta_v + ztv(ig,l)=ztv(ig,l)*(1.+RETV*(zo(ig,l)) + s -zl(ig,l)) +cAM Thetal + zthl(ig,l)=pt(ig,l)/zpspsk(ig,l) +c +1015 CONTINUE +1010 CONTINUE + +c print*,'1 OK convect8' +c -------------------- +c +c +c + + + + + + + + + + + +c +c +c wa, fraca, wd, fracd -------------------- zlev(2), rhobarz +c wh,wt,wo ... +c +c + + + + + + + + + + + zh,zu,zv,zo,rho +c +c +c -------------------- zlev(1) +c \\\\\\\\\\\\\\\\\\\\ +c +c + +c----------------------------------------------------------------------- +c Calcul des altitudes des couches +c----------------------------------------------------------------------- + + do l=2,nlay + do ig=1,ngrid + zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG + enddo + enddo + do ig=1,ngrid + zlev(ig,1)=0. + zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG + enddo + do l=1,nlay + do ig=1,ngrid + zlay(ig,l)=pphi(ig,l)/RG + enddo + enddo +ccalcul de deltaz + do l=1,nlay + do ig=1,ngrid + deltaz(ig,l)=zlev(ig,l+1)-zlev(ig,l) + enddo + enddo + +c print*,'2 OK convect8' +c----------------------------------------------------------------------- +c Calcul des densites +c----------------------------------------------------------------------- + + do l=1,nlay + do ig=1,ngrid +c rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l)) + rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*ztv(ig,l)) + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1)) + enddo + enddo + + do k=1,nlay + do l=1,nlay+1 + do ig=1,ngrid + wa(ig,k,l)=0. + enddo + enddo + enddo +cCr:ajout:calcul de la masse + do l=1,nlay + do ig=1,ngrid +c masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG + enddo + enddo +c print*,'3 OK convect8' +c------------------------------------------------------------------ +c Calcul de w2, quarre de w a partir de la cape +c a partir de w2, on calcule wa, vitesse de l'ascendance +c +c ATTENTION: Dans cette version, pour cause d'economie de memoire, +c w2 est stoke dans wa +c +c ATTENTION: dans convect8, on n'utilise le calcule des wa +c independants par couches que pour calculer l'entrainement +c a la base et la hauteur max de l'ascendance. +c +c Indicages: +c l'ascendance provenant du niveau k traverse l'interface l avec +c une vitesse wa(k,l). +c +c -------------------- +c +c + + + + + + + + + + +c +c wa(k,l) ---- -------------------- l +c /\ +c /||\ + + + + + + + + + + +c || +c || -------------------- +c || +c || + + + + + + + + + + +c || +c || -------------------- +c ||__ +c |___ + + + + + + + + + + k +c +c -------------------- +c +c +c +c------------------------------------------------------------------ + +cCR: ponderation entrainement des couches instables +cdef des alim_star tels que alim=f*alim_star + do l=1,klev + do ig=1,ngrid + alim_star(ig,l)=0. + alim(ig,l)=0. + enddo + enddo +c determination de la longueur de la couche d entrainement + do ig=1,ngrid + lentr(ig)=1 + enddo + +con ne considere que les premieres couches instables + therm=.false. + do k=nlay-2,1,-1 + do ig=1,ngrid + if (ztv(ig,k).gt.ztv(ig,k+1).and. + s ztv(ig,k+1).le.ztv(ig,k+2)) then + lentr(ig)=k+1 + therm=.true. + endif + enddo + enddo +c +c determination du lmin: couche d ou provient le thermique + do ig=1,ngrid + lmin(ig)=1 + enddo + do ig=1,ngrid + do l=nlay,2,-1 + if (ztv(ig,l-1).gt.ztv(ig,l)) then + lmin(ig)=l-1 + endif + enddo + enddo +c +c definition de l'entrainement des couches + do l=1,klev-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. + s l.ge.lmin(ig).and.l.lt.lentr(ig)) then +cdef possibles pour alim_star: zdthetadz, dthetadz, zdtheta + alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.) +c s *(zlev(ig,l+1)-zlev(ig,l)) + s *sqrt(zlev(ig,l+1)) +c alim_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1) +c s /zlev(ig,lentr(ig)+2)))**(3./2.) + endif + enddo + enddo + +c pas de thermique si couche 1 stable + do ig=1,ngrid +c if (lmin(ig).gt.1) then +cCRnouveau test + if (alim_star(ig,1).lt.1.e-10) then + do l=1,klev + alim_star(ig,l)=0. + enddo + endif + enddo +c calcul de l entrainement total + do ig=1,ngrid + alim_star_tot(ig)=0. + entr_star_tot(ig)=0. + detr_star_tot(ig)=0. + enddo + do ig=1,ngrid + do k=1,klev + alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,k) + enddo + enddo +c +c Calcul entrainement normalise + do ig=1,ngrid + if (alim_star_tot(ig).gt.1.e-10) then +c do l=1,lentr(ig) + do l=1,klev +cdef possibles pour entr_star: zdthetadz, dthetadz, zdtheta + alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig) + enddo + endif + enddo + +c print*,'fin calcul alim_star' + +cAM:initialisations + do k=1,nlay + do ig=1,ngrid + ztva(ig,k)=ztv(ig,k) + ztla(ig,k)=zthl(ig,k) + zqla(ig,k)=0. + zqta(ig,k)=po(ig,k) + Zsat(ig) =.false. + enddo + enddo + do k=1,klev + do ig=1,ngrid + detr_star(ig,k)=0. + entr_star(ig,k)=0. + detr(ig,k)=0. + entr(ig,k)=0. + enddo + enddo +c print*,'7 OK convect8' + do k=1,klev+1 + do ig=1,ngrid + zw2(ig,k)=0. + fmc(ig,k)=0. +cCR + f_star(ig,k)=0. +cRC + larg_cons(ig,k)=0. + larg_detr(ig,k)=0. + wa_moy(ig,k)=0. + enddo + enddo + +cn print*,'8 OK convect8' + do ig=1,ngrid + linter(ig)=1. + lmaxa(ig)=1 + lmix(ig)=1 + wmaxa(ig)=0. + enddo + + nu_min=l_mix + nu_max=1000. +c do ig=1,ngrid +c nu_max=wmax_sec(ig) +c enddo + do ig=1,ngrid + do k=1,klev + nu(ig,k)=0. + nu_e(ig,k)=0. + enddo + enddo +cCalcul de l'excès de température du à la diffusion turbulente + do ig=1,ngrid + do l=1,klev + dtheta(ig,l)=0. + enddo + enddo + do ig=1,ngrid + do l=1,lentr(ig)-1 + dtheta(ig,l)=sqrt(10.*0.4*zlev(ig,l+1)**2*1. + s *((ztv(ig,l+1)-ztv(ig,l))/(zlev(ig,l+1)-zlev(ig,l)))**2) + enddo + enddo +c do l=1,nlay-2 + do l=1,klev-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1) + s .and.alim_star(ig,l).gt.1.e-10 + s .and.zw2(ig,l).lt.1e-10) then +cAM +ctest:on rajoute un excès de T dans couche alim +c ztla(ig,l)=zthl(ig,l)+dtheta(ig,l) + ztla(ig,l)=zthl(ig,l) +ctest: on rajoute un excès de q dans la couche alim +c zqta(ig,l)=po(ig,l)+0.001 + zqta(ig,l)=po(ig,l) + zqla(ig,l)=zl(ig,l) +cAM + f_star(ig,l+1)=alim_star(ig,l) +ctest:calcul de dteta + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) + s *(zlev(ig,l+1)-zlev(ig,l)) + s *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + w_est(ig,l+1)=zw2(ig,l+1) + larg_detr(ig,l)=0. +c print*,'coucou boucle 1' + else if ((zw2(ig,l).ge.1e-10).and. + s (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then +c print*,'coucou boucle 2' +cestimation du detrainement a partir de la geometrie du pas precedent + if ((test(ig).eq.1).or.((.not.debut).and.(f0(ig).lt.1.e-10))) then + detr_star(ig,l)=0. + entr_star(ig,l)=0. +c print*,'coucou test(ig)',test(ig),f0(ig),zmax0(ig) + else +c print*,'coucou debut detr' +ctests sur la definition du detr + if (zqla(ig,l-1).gt.1.e-10) then + nuage=.true. + endif + + w_est(ig,l+1)=zw2(ig,l)* + s ((f_star(ig,l))**2) + s /(f_star(ig,l)+alim_star(ig,l))**2+ + s 2.*RG*(ztva(ig,l-1)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + if (w_est(ig,l+1).lt.0.) then + w_est(ig,l+1)=zw2(ig,l) + endif + if (l.gt.2) then + if ((w_est(ig,l+1).gt.w_est(ig,l)).and. + s (zlev(ig,l+1).lt.zmax_sec(ig)).and. + s (zqla(ig,l-1).lt.1.e-10)) then + detr_star(ig,l)=MAX(0.,(rhobarz(ig,l+1) + s *sqrt(w_est(ig,l+1))*sqrt(nu(ig,l)*zlev(ig,l+1)) + s -rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(nu(ig,l)*zlev(ig,l))) + s /(r_aspect*zmax_sec(ig))) + else if ((zlev(ig,l+1).lt.zmax_sec(ig)).and. + s (zqla(ig,l-1).lt.1.e-10)) then + detr_star(ig,l)=-f0(ig)*f_star(ig,lmix(ig)) + s /(rhobarz(ig,lmix(ig))*wmaxa(ig))* + s (rhobarz(ig,l+1)*sqrt(w_est(ig,l+1)) + s *((zmax_sec(ig)-zlev(ig,l+1))/((zmax_sec(ig)-zlev(ig,lmix(ig))))) + s **2. + s -rhobarz(ig,l)*sqrt(w_est(ig,l)) + s *((zmax_sec(ig)-zlev(ig,l))/((zmax_sec(ig)-zlev(ig,lmix(ig))))) + s **2.) + else + detr_star(ig,l)=0.002*f0(ig)*f_star(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + + endif + else + detr_star(ig,l)=0. + endif + + detr_star(ig,l)=detr_star(ig,l)/f0(ig) + if (nuage) then + entr_star(ig,l)=0.4*detr_star(ig,l) + else + entr_star(ig,l)=0.4*detr_star(ig,l) + endif + + if ((detr_star(ig,l)).gt.f_star(ig,l)) then + detr_star(ig,l)=f_star(ig,l) +c entr_star(ig,l)=0. + endif + + if ((l.lt.lentr(ig))) then + entr_star(ig,l)=0. +c detr_star(ig,l)=0. + endif + +c print*,'ok detr_star' + endif +cprise en compte du detrainement dans le calcul du flux + f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l) + s -detr_star(ig,l) +ctest +c if (f_star(ig,l+1).lt.0.) then +c f_star(ig,l+1)=0. +c entr_star(ig,l)=0. +c detr_star(ig,l)=f_star(ig,l)+alim_star(ig,l) +c endif +ctest sur le signe de f_star + if (f_star(ig,l+1).gt.1.e-10) then +c then +ctest +c if (((f_star(ig,l+1)+detr_star(ig,l)).gt.1.e-10)) then +cAM on melange Tl et qt du thermique +con rajoute un excès de T dans la couche alim +c if (l.lt.lentr(ig)) then +c ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+ +c s (alim_star(ig,l)+entr_star(ig,l))*(zthl(ig,l)+dtheta(ig,l))) +c s /(f_star(ig,l+1)+detr_star(ig,l)) +c else + ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+ + s (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l)) + s /(f_star(ig,l+1)+detr_star(ig,l)) +c s /(f_star(ig,l+1)) +c endif +con rajoute un excès de q dans la couche alim +c if (l.lt.lentr(ig)) then +c zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+ +c s (alim_star(ig,l)+entr_star(ig,l))*(po(ig,l)+0.001)) +c s /(f_star(ig,l+1)+detr_star(ig,l)) +c else + zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+ + s (alim_star(ig,l)+entr_star(ig,l))*po(ig,l)) + s /(f_star(ig,l+1)+detr_star(ig,l)) +c s /(f_star(ig,l+1)) +c endif +cAM on en deduit thetav et ql du thermique +cCR test +c Tbef(ig)=ztla(ig,l)*zpspsk(ig,l) + Tbef(ig)=ztla(ig,l)*zpspsk(ig,l) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l) + qsatbef(ig)=MIN(0.5,qsatbef(ig)) + zcor=1./(1.-retv*qsatbef(ig)) + qsatbef(ig)=qsatbef(ig)*zcor + Zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig)) .gt. 1.e-10) + + if (Zsat(ig).and.(1.eq.1)) then + qlbef=max(0.,zqta(ig,l)-qsatbef(ig)) + DT = 0.5*RLvCp*qlbef +c write(17,*)'DT0=',DT + do while (abs(DT).gt.DDT0) +c print*,'aie' + Tbef(ig)=Tbef(ig)+DT + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l) + qsatbef(ig)=MIN(0.5,qsatbef(ig)) + zcor=1./(1.-retv*qsatbef(ig)) + qsatbef(ig)=qsatbef(ig)*zcor + qlbef=zqta(ig,l)-qsatbef(ig) + + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta + zcor=1./(1.-retv*qsatbef(ig)) + dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor) + num=-Tbef(ig)+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef + denom=1.+RLvCp*dqsat_dT + if (denom.lt.1.e-10) then + print*,'pb denom' + endif + DT=num/denom +c write(17,*)'DT=',DT + enddo + zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig)) + zqla(ig,l) = max(0.,qlbef) +c zqla(ig,l)=0. + endif +c zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig)) +c +c on ecrit de maniere conservative (sat ou non) +c T = Tl +Lv/Cp ql +cCR rq utilisation de humidite specifique ou rapport de melange? + ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) + ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) +con rajoute le calcul de zha pour diagnostiques (temp potentielle) + zha(ig,l) = ztva(ig,l) +c if (l.lt.lentr(ig)) then +c ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) +c s -zqla(ig,l))-zqla(ig,l)) + 0.1 +c else + ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) + s -zqla(ig,l))-zqla(ig,l)) +c endif +c ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) +c s /(1.-retv*zqla(ig,l)) +c ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) +c ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) +c s /(1.-retv*zqta(ig,l)) +c s -zqla(ig,l)/(1.-retv*zqla(ig,l))) +c s -zqla(ig,l)/(1.-retv*zqla(ig,l))) +c write(13,*)zqla(ig,l),zqla(ig,l)/(1.-retv*zqla(ig,l)) +con ecrit zqsat + zqsatth(ig,l)=qsatbef(ig) +c enddo +c DO ig=1,ngrid +c if (zw2(ig,l).ge.1.e-10.and. +c s f_star(ig,l)+entr_star(ig,l).gt.1.e-10) then +c mise a jour de la vitesse ascendante (l'air entraine de la couche +c consideree commence avec une vitesse nulle). +c +c if (f_star(ig,l+1).gt.1.e-10) then + zw2(ig,l+1)=zw2(ig,l)* +c s ((f_star(ig,l)-detr_star(ig,l))**2) +c s /f_star(ig,l+1)**2+ + s ((f_star(ig,l))**2) + s /(f_star(ig,l+1)+detr_star(ig,l))**2+ +c s /(f_star(ig,l+1))**2+ + s 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) +c s *(f_star(ig,l)/f_star(ig,l+1))**2 + + endif + endif +c + if (zw2(ig,l+1).lt.0.) then + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) + s -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. +c print*,'linter=',linter(ig) +c else if ((zw2(ig,l+1).lt.1.e-10).and.(zw2(ig,l+1).ge.0.)) then +c linter(ig)=l+1 +c print*,'linter=l',zw2(ig,l),zw2(ig,l+1) + else + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) +c wa_moy(ig,l+1)=zw2(ig,l+1) + endif + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +c lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo + print*,'fin calcul zw2' +c +c Calcul de la couche correspondant a la hauteur du thermique + do ig=1,ngrid + lmax(ig)=lentr(ig) + enddo + do ig=1,ngrid + do l=nlay,lentr(ig)+1,-1 + if (zw2(ig,l).le.1.e-10) then + lmax(ig)=l-1 + endif + enddo + enddo +c pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.1) then + lmax(ig)=1 + lmin(ig)=1 + lentr(ig)=1 + endif + enddo +c +c Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (zw2(ig,l).lt.0.)then + print*,'pb2 zw2<0' + endif + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +c Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=0. + zlevinter(ig)=zlev(ig,1) + enddo + do ig=1,ngrid +c calcul de zlevinter + zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* + s linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) + s -zlev(ig,lmax(ig))) +cpour le cas ou on prend tjs lmin=1 +c zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1)) + zmax0(ig)=zmax(ig) + write(11,*)'ig,lmax,linter',ig,lmax(ig),linter(ig) + write(12,*)'ig,zlevinter,zmax',ig,zmax(ig),zlevinter(ig) + enddo + +cCalcul de zmax_sec et wmax_sec + call fermeture_seche(ngrid,nlay + s ,pplay,pplev,pphi,zlev,rhobarz,f0,zpspsk + s ,alim,zh,zo,lentr,lmin,nu_min,nu_max,r_aspect + s ,zmax_sec2,wmax_sec2) + + print*,'avant fermeture' +c Fermeture,determination de f +c en lmax f=d-e + do ig=1,ngrid +c entr_star(ig,lmax(ig))=0. +c f_star(ig,lmax(ig)+1)=0. +c detr_star(ig,lmax(ig))=f_star(ig,lmax(ig))+entr_star(ig,lmax(ig)) +c s +alim_star(ig,lmax(ig)) + enddo +c + do ig=1,ngrid + alim_star2(ig)=0. + enddo +ccalcul de entr_star_tot + do ig=1,ngrid + do k=1,lmix(ig) + entr_star_tot(ig)=entr_star_tot(ig) +c s +entr_star(ig,k) + s +alim_star(ig,k) +c s -detr_star(ig,k) + detr_star_tot(ig)=detr_star_tot(ig) +c s +alim_star(ig,k) + s -detr_star(ig,k) + s +entr_star(ig,k) + enddo + enddo + + do ig=1,ngrid + if (alim_star_tot(ig).LT.1.e-10) then + f(ig)=0. + else +c do k=lmin(ig),lentr(ig) + do k=1,lentr(ig) + alim_star2(ig)=alim_star2(ig)+alim_star(ig,k)**2 + s /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))) + enddo + if ((zmax_sec(ig).gt.1.e-10).and.(1.eq.1)) then + f(ig)=wmax_sec(ig)/(max(500.,zmax_sec(ig))*r_aspect + s *alim_star2(ig)) + f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/ + s zmax_sec(ig))*wmax_sec(ig)) + else + f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect*alim_star2(ig)) + f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/ + s zmax(ig))*wmax(ig)) + endif + endif + f0(ig)=f(ig) + enddo + print*,'apres fermeture' +c Calcul de l'entrainement + do ig=1,ngrid + do k=1,klev + alim(ig,k)=f(ig)*alim_star(ig,k) + enddo + enddo +cCR:test pour entrainer moins que la masse +c do ig=1,ngrid +c do l=1,lentr(ig) +c if ((alim(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then +c alim(ig,l+1)=alim(ig,l+1)+alim(ig,l) +c s -0.9*masse(ig,l)/ptimestep +c alim(ig,l)=0.9*masse(ig,l)/ptimestep +c endif +c enddo +c enddo +c calcul du détrainement + do ig=1,klon + do k=1,klev + detr(ig,k)=f(ig)*detr_star(ig,k) + if (detr(ig,k).lt.0.) then +c print*,'detr1<0!!!' + endif + enddo + do k=1,klev + entr(ig,k)=f(ig)*entr_star(ig,k) + if (entr(ig,k).lt.0.) then +c print*,'entr1<0!!!' + endif + enddo + enddo +c +c do ig=1,ngrid +c do l=1,klev +c if (((detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep).gt. +c s (masse(ig,l))) then +c print*,'d2+e2+a2>m2','ig=',ig,'l=',l,'lmax(ig)=',lmax(ig),'d+e+a=' +c s,(detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep,'m=',masse(ig,l) +c endif +c enddo +c enddo +c Calcul des flux + + do ig=1,ngrid + do l=1,lmax(ig) +c do l=1,klev +c fmc(ig,l+1)=f(ig)*f_star(ig,l+1) + fmc(ig,l+1)=fmc(ig,l)+alim(ig,l)+entr(ig,l)-detr(ig,l) +c print*,'??!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig), +c s 'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l), +c s 'f+1=',fmc(ig,l+1) + if (fmc(ig,l+1).lt.0.) then + print*,'fmc1<0',l+1,lmax(ig),fmc(ig,l+1) + fmc(ig,l+1)=fmc(ig,l) + detr(ig,l)=alim(ig,l)+entr(ig,l) +c fmc(ig,l+1)=0. +c print*,'fmc1<0',l+1,lmax(ig),fmc(ig,l+1) + endif +c if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then +c f_old=fmc(ig,l+1) +c fmc(ig,l+1)=fmc(ig,l) +c detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1) +c endif + +c if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then +c f_old=fmc(ig,l+1) +c fmc(ig,l+1)=fmc(ig,l) +c detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l) +c endif +crajout du test sur alpha croissant +cif test +c if (1.eq.0) then + + if (l.eq.klev) then + print*,'THERMCELL PB ig=',ig,' l=',l + stop + endif +! if ((zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10).and. +! s (l.ge.lentr(ig)).and. + if ((zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10).and. + s (l.ge.lentr(ig)) ) then + if ( ((fmc(ig,l+1)/(rhobarz(ig,l+1)*zw2(ig,l+1))).gt. + s (fmc(ig,l)/(rhobarz(ig,l)*zw2(ig,l))))) then + f_old=fmc(ig,l+1) + fmc(ig,l+1)=fmc(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1) + s /(rhobarz(ig,l)*zw2(ig,l)) + detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1) +c detr(ig,l)=(fmc(ig,l+1)-fmc(ig,l))/(0.4-1.) +c entr(ig,l)=0.4*detr(ig,l) +c entr(ig,l)=fmc(ig,l+1)-fmc(ig,l)+detr(ig,l) + endif + endif + if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then + f_old=fmc(ig,l+1) + fmc(ig,l+1)=fmc(ig,l) + detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1) + endif + if (detr(ig,l).gt.fmc(ig,l)) then + detr(ig,l)=fmc(ig,l) + entr(ig,l)=fmc(ig,l+1)-alim(ig,l) + endif + if (fmc(ig,l+1).lt.0.) then + detr(ig,l)=detr(ig,l)+fmc(ig,l+1) + fmc(ig,l+1)=0. + print*,'fmc2<0',l+1,lmax(ig) + endif + +ctest pour ne pas avoir f=0 et d=e/=0 +c if (fmc(ig,l+1).lt.1.e-10) then +c detr(ig,l+1)=0. +c entr(ig,l+1)=0. +c zqla(ig,l+1)=0. +c zw2(ig,l+1)=0. +c lmax(ig)=l+1 +c zmax(ig)=zlev(ig,lmax(ig)) +c endif + if (zw2(ig,l+1).gt.1.e-10) then + if ((((fmc(ig,l+1))/(rhobarz(ig,l+1)*zw2(ig,l+1))).gt. + s 1.)) then + f_old=fmc(ig,l+1) + fmc(ig,l+1)=rhobarz(ig,l+1)*zw2(ig,l+1) + zw2(ig,l+1)=0. + zqla(ig,l+1)=0. + detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1) + lmax(ig)=l+1 + zmax(ig)=zlev(ig,lmax(ig)) + print*,'alpha>1',l+1,lmax(ig) + endif + endif +c write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) +cendif test +c endif + enddo + enddo + do ig=1,ngrid +c if (fmc(ig,lmax(ig)+1).ne.0.) then + fmc(ig,lmax(ig)+1)=0. + entr(ig,lmax(ig))=0. + detr(ig,lmax(ig))=fmc(ig,lmax(ig))+entr(ig,lmax(ig)) + s +alim(ig,lmax(ig)) +c endif + enddo +ctest sur le signe de fmc + do ig=1,ngrid + do l=1,klev+1 + if (fmc(ig,l).lt.0.) then + print*,'fm1<0!!!','ig=',ig,'l=',l,'a=',alim(ig,l-1),'e=' + s ,entr(ig,l-1),'f=',fmc(ig,l-1),'d=',detr(ig,l-1),'f+1=',fmc(ig,l) + endif + enddo + enddo +ctest de verification + do ig=1,ngrid + do l=1,lmax(ig) + if ((abs(fmc(ig,l+1)-fmc(ig,l)-alim(ig,l)-entr(ig,l)+detr(ig,l))) + s .gt.1.e-4) then +c print*,'pbcm!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig), +c s 'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l), +c s 'f+1=',fmc(ig,l+1) + endif + if (detr(ig,l).lt.0.) then + print*,'detrdemi<0!!!' + endif + enddo + enddo +c +cRC +cCR def de zmix continu (profil parabolique des vitesses) + do ig=1,ngrid + if (lmix(ig).gt.1.) then +c test + if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10) + s then +c + zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2)) + s /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + else + zmix(ig)=zlev(ig,lmix(ig)) + print*,'pb zmix' + endif + else + zmix(ig)=0. + endif +ctest + if ((zmax(ig)-zmix(ig)).le.0.) then + zmix(ig)=0.9*zmax(ig) +c print*,'pb zmix>zmax' + endif + enddo + do ig=1,klon + zmix0(ig)=zmix(ig) + enddo +c +c calcul du nouveau lmix correspondant + do ig=1,ngrid + do l=1,klev + if (zmix(ig).ge.zlev(ig,l).and. + s zmix(ig).lt.zlev(ig,l+1)) then + lmix(ig)=l + endif + enddo + enddo +c +cne devrait pas arriver!!!!! + do ig=1,ngrid + do l=1,klev + if (detr(ig,l).gt.(fmc(ig,l)+alim(ig,l))+entr(ig,l)) then + print*,'detr2>fmc2!!!','ig=',ig,'l=',l,'d=',detr(ig,l), + s 'f=',fmc(ig,l),'lmax=',lmax(ig) +c detr(ig,l)=fmc(ig,l)+alim(ig,l)+entr(ig,l) +c entr(ig,l)=0. +c fmc(ig,l+1)=0. +c zw2(ig,l+1)=0. +c zqla(ig,l+1)=0. + print*,'pb!fm=0 et f_star>0',l,lmax(ig) +c lmax(ig)=l + endif + enddo + enddo + do ig=1,ngrid + do l=lmax(ig)+1,klev+1 +c fmc(ig,l)=0. +c detr(ig,l)=0. +c entr(ig,l)=0. +c zw2(ig,l)=0. +c zqla(ig,l)=0. + enddo + enddo + +cCalcul du detrainement lors du premier passage +c print*,'9 OK convect8' +c print*,'WA1 ',wa_moy + +c determination de l'indice du debut de la mixed layer ou w decroit + +c calcul de la largeur de chaque ascendance dans le cas conservatif. +c dans ce cas simple, on suppose que la largeur de l'ascendance provenant +c d'une couche est égale à la hauteur de la couche alimentante. +c La vitesse maximale dans l'ascendance est aussi prise comme estimation +c de la vitesse d'entrainement horizontal dans la couche alimentante. + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmax(ig).and.(test(ig).eq.1)) then + zw=max(wa_moy(ig,l),1.e-10) + larg_cons(ig,l)=zmax(ig)*r_aspect + s *fmc(ig,l)/(rhobarz(ig,l)*zw) + endif + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmax(ig).and.(test(ig).eq.1)) then +c if (idetr.eq.0) then +c cette option est finalement en dur. + if ((l_mix*zlev(ig,l)).lt.0.)then + print*,'pb l_mix*zlev<0' + endif +cCR: test: nouvelle def de lambda +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + if (zw2(ig,l).gt.1.e-10) then + larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l)) + else + larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + endif +c else if (idetr.eq.1) then +c larg_detr(ig,l)=larg_cons(ig,l) +c s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) +c else if (idetr.eq.2) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *sqrt(wa_moy(ig,l)) +c else if (idetr.eq.4) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *wa_moy(ig,l) +c endif + endif + enddo + enddo + +c print*,'10 OK convect8' +c print*,'WA2 ',wa_moy +c cal1cul de la fraction de la maille concernée par l'ascendance en tenant +c compte de l'epluchage du thermique. +c +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1..and.(test(ig).eq.1)) then +c print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l)) + s /(r_aspect*zmax(ig)) +c test + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + else +c wa_moy(ig,l)=0. + fraca(ig,l)=0. + fracc(ig,l)=0. + fracd(ig,l)=1. + endif + enddo + enddo +cCR: calcul de fracazmix + do ig=1,ngrid + if (test(ig).eq.1) then + fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ + s (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + s +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1) + s -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) + endif + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1..and.(test(ig).eq.1)) then + if (l.gt.lmix(ig)) then +ctest + if (zmax(ig)-zmix(ig).lt.1.e-10) then +c print*,'pb xxx' + xxx(ig,l)=(lmax(ig)+1.-l)/(lmax(ig)+1.-lmix(ig)) + else + xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) + endif + if (idetr.eq.0) then + fraca(ig,l)=fracazmix(ig) + else if (idetr.eq.1) then + fraca(ig,l)=fracazmix(ig)*xxx(ig,l) + else if (idetr.eq.2) then + fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) + else + fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2 + endif +c print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + endif + endif + enddo + enddo + + print*,'fin calcul fraca' +c print*,'11 OK convect8' +c print*,'Ea3 ',wa_moy +c------------------------------------------------------------------ +c Calcul de fracd, wd +c somme wa - wd = 0 +c------------------------------------------------------------------ + + + do ig=1,ngrid + fm(ig,1)=0. + fm(ig,nlay+1)=0. + enddo + + do l=2,nlay + do ig=1,ngrid + if (test(ig).eq.1) then + fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l) +cCR:test + if (alim(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1) + s .and.l.gt.lmix(ig)) then + fm(ig,l)=fm(ig,l-1) +c write(1,*)'ajustement fm, l',l + endif +c write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) +cRC + endif + enddo + do ig=1,ngrid + if(fracd(ig,l).lt.0.1.and.(test(ig).eq.1)) then + stop'fracd trop petit' + else +c vitesse descendante "diagnostique" + wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l)) + endif + enddo + enddo + + do l=1,nlay+1 + do ig=1,ngrid + if (test(ig).eq.0) then + fm(ig,l)=fmc(ig,l) + endif + enddo + enddo + +cfin du first + do l=1,nlay + do ig=1,ngrid +c masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG + enddo + enddo + + print*,'12 OK convect8' +c print*,'WA4 ',wa_moy +cc------------------------------------------------------------------ +c calcul du transport vertical +c------------------------------------------------------------------ + + go to 4444 +c print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + do l=2,nlay-1 + do ig=1,ngrid + if(fm(ig,l+1)*ptimestep.gt.masse(ig,l) + s .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then + print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' + s ,fm(ig,l+1)*ptimestep + s ,' M=',masse(ig,l),masse(ig,l+1) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if((alim(ig,l)+entr(ig,l))*ptimestep.gt.masse(ig,l)) then + print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' + s ,(entr(ig,l)+alim(ig,l))*ptimestep + s ,' M=',masse(ig,l) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then +c print*,'WARN!!! fm exagere ig=',ig,' l=',l +c s ,' FM=',fm(ig,l) + endif + if(.not.masse(ig,l).ge.1.e-10 + s .or..not.masse(ig,l).le.1.e4) then +c print*,'WARN!!! masse exagere ig=',ig,' l=',l +c s ,' M=',masse(ig,l) +c print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', +c s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) +c print*,'zlev(ig,l+1),zlev(ig,l)' +c s ,zlev(ig,l+1),zlev(ig,l) +c print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' +c s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + endif + if(.not.alim(ig,l).ge.0..or..not.alim(ig,l).le.10.) then +c print*,'WARN!!! entr exagere ig=',ig,' l=',l +c s ,' E=',entr(ig,l) + endif + enddo + enddo + +4444 continue + +cCR:redefinition du entr +cCR:test:on ne change pas la def du entr mais la def du fm + do l=1,nlay + do ig=1,ngrid + if (test(ig).eq.1) then + detr(ig,l)=fm(ig,l)+alim(ig,l)-fm(ig,l+1) + if (detr(ig,l).lt.0.) then +c entr(ig,l)=entr(ig,l)-detr(ig,l) + fm(ig,l+1)=fm(ig,l)+alim(ig,l) + detr(ig,l)=0. +c write(11,*)'l,ig,entr',l,ig,entr(ig,l) +c print*,'WARNING !!! detrainement negatif ',ig,l + endif + endif + enddo + enddo +cRC + + if (w2di.eq.1) then + fm0=fm0+ptimestep*(fm-fm0)/float(tho) + entr0=entr0+ptimestep*(alim+entr-entr0)/float(tho) + else + fm0=fm + entr0=alim+entr + detr0=detr + alim0=alim +c zoa=zqta +c entr0=alim + endif + + if (1.eq.1) then +c call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse +c . ,zh,zdhadj,zha) +c call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse +c . ,zo,pdoadj,zoa) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse, + . zthl,zdthladj,zta) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse, + . po,pdoadj,zoa) + else + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zh,zdhadj,zha) + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zo,pdoadj,zoa) + endif + + if (1.eq.0) then + call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,fraca,zmax + . ,zu,zv,pduadj,pdvadj,zua,zva) + else + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zu,pduadj,zua) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zv,pdvadj,zva) + endif + +cCalcul des moments +c do l=1,nlay +c do ig=1,ngrid +c zf=0.5*(fracc(ig,l)+fracc(ig,l+1)) +c zf2=zf/(1.-zf) +c thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2 +c wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 +c enddo +c enddo + + + + + + +c print*,'13 OK convect8' +c print*,'WA5 ',wa_moy + do l=1,nlay + do ig=1,ngrid +c pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l) + pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l) + enddo + enddo + + +c do l=1,nlay +c do ig=1,ngrid +c if(abs(pdtadj(ig,l))*86400..gt.500.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdtadj=',pdtadj(ig,l) +c endif +c if(abs(pdoadj(ig,l))*86400..gt.1.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdoadj=',pdoadj(ig,l) +c endif +c enddo +c enddo + + print*,'14 OK convect8' +c------------------------------------------------------------------ +c Calculs pour les sorties +c------------------------------------------------------------------ +ccalcul de fraca pour les sorties + do l=2,klev + do ig=1,klon + if (zw2(ig,l).gt.1.e-10) then + fraca(ig,l)=fm(ig,l)/(rhobarz(ig,l)*zw2(ig,l)) + else + fraca(ig,l)=0. + endif + enddo + enddo + if(sorties) then + do l=1,nlay + do ig=1,ngrid + zla(ig,l)=(1.-fracd(ig,l))*zmax(ig) + zld(ig,l)=fracd(ig,l)*zmax(ig) + if(1.-fracd(ig,l).gt.1.e-10) + s zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l)) + enddo + enddo +c CR calcul du niveau de condensation +c initialisation + do ig=1,ngrid + nivcon(ig)=0. + zcon(ig)=0. + enddo + do k=nlay,1,-1 + do ig=1,ngrid + if (zqla(ig,k).gt.1e-10) then + nivcon(ig)=k + zcon(ig)=zlev(ig,k) + endif +c if (zcon(ig).gt.1.e-10) then +c nuage=.true. +c else +c nuage=.false. +c endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + zf=fraca(ig,l) + zf2=zf/(1.-zf) + thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l)/zpspsk(ig,l))**2 + wth2(ig,l)=zf2*(zw2(ig,l))**2 +c print*,'wth2=',wth2(ig,l) + wth3(ig,l)=zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l)) + s *zw2(ig,l)*zw2(ig,l)*zw2(ig,l) + q2(ig,l)=zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2 +ctest: on calcul q2/po=ratqsc +c if (nuage) then + ratqscth(ig,l)=sqrt(q2(ig,l))/(po(ig,l)*1000.) +c else +c ratqscth(ig,l)=0. +c endif + enddo + enddo +ccalcul du ratqscdiff + sum=0. + sumdiff=0. + ratqsdiff(:,:)=0. + do ig=1,ngrid + do l=1,lentr(ig) + sum=sum+alim_star(ig,l)*zqta(ig,l)*1000. + enddo + enddo + do ig=1,ngrid + do l=1,lentr(ig) + zf=fraca(ig,l) + zf2=zf/(1.-zf) + sumdiff=sumdiff+alim_star(ig,l) + s *(zqta(ig,l)*1000.-sum)**2 +c ratqsdiff=ratqsdiff+alim_star(ig,l)* +c s (zqta(ig,l)*1000.-po(ig,l)*1000.)**2 + enddo + enddo + do l=1,klev + do ig=1,ngrid + ratqsdiff(ig,l)=sqrt(sumdiff)/(po(ig,l)*1000.) +c write(11,*)'ratqsdiff=',ratqsdiff(ig,l) + enddo + enddo +cdeja fait +c do l=1,nlay +c do ig=1,ngrid +c detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) +c if (detr(ig,l).lt.0.) then +c entr(ig,l)=entr(ig,l)-detr(ig,l) +c detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l +c endif +c enddo +c enddo + +c print*,'15 OK convect8' + + isplit=isplit+1 + + +c #define und + goto 123 +#ifdef und + CALL writeg1d(1,nlay,wd,'wd ','wd ') + CALL writeg1d(1,nlay,zwa,'wa ','wa ') + CALL writeg1d(1,nlay,fracd,'fracd ','fracd ') + CALL writeg1d(1,nlay,fraca,'fraca ','fraca ') + CALL writeg1d(1,nlay,wa_moy,'wam ','wam ') + CALL writeg1d(1,nlay,zla,'la ','la ') + CALL writeg1d(1,nlay,zld,'ld ','ld ') + CALL writeg1d(1,nlay,pt,'pt ','pt ') + CALL writeg1d(1,nlay,zh,'zh ','zh ') + CALL writeg1d(1,nlay,zha,'zha ','zha ') + CALL writeg1d(1,nlay,zu,'zu ','zu ') + CALL writeg1d(1,nlay,zv,'zv ','zv ') + CALL writeg1d(1,nlay,zo,'zo ','zo ') + CALL writeg1d(1,nlay,wh,'wh ','wh ') + CALL writeg1d(1,nlay,wu,'wu ','wu ') + CALL writeg1d(1,nlay,wv,'wv ','wv ') + CALL writeg1d(1,nlay,wo,'w15uo ','wXo ') + CALL writeg1d(1,nlay,zdhadj,'zdhadj ','zdhadj ') + CALL writeg1d(1,nlay,pduadj,'pduadj ','pduadj ') + CALL writeg1d(1,nlay,pdvadj,'pdvadj ','pdvadj ') + CALL writeg1d(1,nlay,pdoadj,'pdoadj ','pdoadj ') + CALL writeg1d(1,nlay,entr ,'entr ','entr ') + CALL writeg1d(1,nlay,detr ,'detr ','detr ') + CALL writeg1d(1,nlay,fm ,'fm ','fm ') + + CALL writeg1d(1,nlay,pdtadj,'pdtadj ','pdtadj ') + CALL writeg1d(1,nlay,pplay,'pplay ','pplay ') + CALL writeg1d(1,nlay,pplev,'pplev ','pplev ') + +c recalcul des flux en diagnostique... +c print*,'PAS DE TEMPS ',ptimestep + call dt2F(pplev,pplay,pt,pdtadj,wh) + CALL writeg1d(1,nlay,wh,'wh2 ','wh2 ') +#endif +123 continue +! #define troisD +#ifdef troisD +c if (sorties) then + print*,'Debut des wrgradsfi' + +c print*,'16 OK convect8' +c call wrgradsfi(1,nlay,wd,'wd ','wd ') +c call wrgradsfi(1,nlay,zwa,'wa ','wa ') + call wrgradsfi(1,nlay,fracd,'fracd ','fracd ') + call wrgradsfi(1,nlay,fraca,'fraca ','fraca ') +c call wrgradsfi(1,nlay,xxx,'xxx ','xxx ') +c call wrgradsfi(1,nlay,wa_moy,'wam ','wam ') +c print*,'WA6 ',wa_moy +c call wrgradsfi(1,nlay,zla,'la ','la ') +c call wrgradsfi(1,nlay,zld,'ld ','ld ') + call wrgradsfi(1,nlay,pt,'pt ','pt ') + call wrgradsfi(1,nlay,zh,'zh ','zh ') + call wrgradsfi(1,nlay,zha,'zha ','zha ') + call wrgradsfi(1,nlay,zua,'zua ','zua ') + call wrgradsfi(1,nlay,zva,'zva ','zva ') + call wrgradsfi(1,nlay,zu,'zu ','zu ') + call wrgradsfi(1,nlay,zv,'zv ','zv ') + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,wh,'wh ','wh ') + call wrgradsfi(1,nlay,wu,'wu ','wu ') + call wrgradsfi(1,nlay,wv,'wv ','wv ') + call wrgradsfi(1,nlay,wo,'wo ','wo ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,nlay,zdhadj,'zdhadj ','zdhadj ') + call wrgradsfi(1,nlay,pduadj,'pduadj ','pduadj ') + call wrgradsfi(1,nlay,pdvadj,'pdvadj ','pdvadj ') + call wrgradsfi(1,nlay,pdoadj,'pdoadj ','pdoadj ') + call wrgradsfi(1,nlay,entr,'entr ','entr ') + call wrgradsfi(1,nlay,detr,'detr ','detr ') + call wrgradsfi(1,nlay,fm,'fm ','fm ') + call wrgradsfi(1,nlay,fmc,'fmc ','fmc ') + call wrgradsfi(1,nlay,zw2,'zw2 ','zw2 ') + call wrgradsfi(1,nlay,w_est,'w_est ','w_est ') +con sort les moments + call wrgradsfi(1,nlay,thetath2,'zh2 ','zh2 ') + call wrgradsfi(1,nlay,wth2,'w2 ','w2 ') + call wrgradsfi(1,nlay,wth3,'w3 ','w3 ') + call wrgradsfi(1,nlay,q2,'q2 ','q2 ') + call wrgradsfi(1,nlay,dtheta,'dT ','dT ') +c + call wrgradsfi(1,nlay,zw_sec,'zw_sec ','zw_sec ') + call wrgradsfi(1,nlay,ztva,'ztva ','ztva ') + call wrgradsfi(1,nlay,ztv,'ztv ','ztv ') + call wrgradsfi(1,nlay,nu,'nu ','nu ') + + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,zoa,'zoa ','zoa ') +c call wrgradsfi(1,nlay,larg_cons,'Lc ','Lc ') +c call wrgradsfi(1,nlay,larg_detr,'Ldetr ','Ldetr ') + +cAM:nouveaux diagnostiques + call wrgradsfi(1,nlay,zthl,'zthl ','zthl ') + call wrgradsfi(1,nlay,zta,'zta ','zta ') + call wrgradsfi(1,nlay,zl,'zl ','zl ') + call wrgradsfi(1,nlay,zdthladj,'zdthladj ', + s 'zdthladj ') + call wrgradsfi(1,nlay,ztla,'ztla ','ztla ') + call wrgradsfi(1,nlay,zqta,'zqta ','zqta ') + call wrgradsfi(1,nlay,zqla,'zqla ','zqla ') + call wrgradsfi(1,nlay,deltaz,'deltaz ','deltaz ') +cCR:nouveaux diagnostiques + call wrgradsfi(1,nlay,entr_star ,'entr_star ','entr_star ') + call wrgradsfi(1,nlay,detr_star ,'detr_star ','detr_star ') + call wrgradsfi(1,nlay,f_star ,'f_star ','f_star ') + call wrgradsfi(1,nlay,zqsat ,'zqsat ','zqsat ') + call wrgradsfi(1,nlay,zqsatth ,'qsath ','qsath ') + call wrgradsfi(1,nlay,alim_star ,'alim_star ','alim_star ') + call wrgradsfi(1,nlay,alim ,'alim ','alim ') + call wrgradsfi(1,1,f,'f ','f ') + call wrgradsfi(1,1,alim_star_tot,'a_s_t ','a_s_t ') + call wrgradsfi(1,1,alim_star2,'a_2 ','a_2 ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,1,zmax_sec,'z_sec ','z_sec ') +c call wrgradsfi(1,1,zmax_sec2,'zz_se ','zz_se ') + call wrgradsfi(1,1,zmix,'zmix ','zmix ') + call wrgradsfi(1,1,nivcon,'nivcon ','nivcon ') + call wrgradsfi(1,1,zcon,'zcon ','zcon ') + zsortie1d(:)=lmax(:) + call wrgradsfi(1,1,zsortie1d,'lmax ','lmax ') + call wrgradsfi(1,1,wmax,'wmax ','wmax ') + call wrgradsfi(1,1,wmax_sec,'w_sec ','w_sec ') + zsortie1d(:)=lmix(:) + call wrgradsfi(1,1,zsortie1d,'lmix ','lmix ') + zsortie1d(:)=lentr(:) + call wrgradsfi(1,1,zsortie1d,'lentr ','lentr ') + +c print*,'17 OK convect8' + + do k=1,klev/10 + write(str2,'(i2.2)') k + str10='wa'//str2 + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=wa(ig,k,l) + enddo + enddo + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=larg_part(ig,k,l) + enddo + enddo + str10='la'//str2 + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + enddo + + +c print*,'18 OK convect8' +c endif + print*,'Fin des wrgradsfi' +#endif + + endif + +c if(wa_moy(1,4).gt.1.e-10) stop + + print*,'19 OK convect8' + return + end + SUBROUTINE thermcell_eau(ngrid,nlay,ptimestep + s ,pplay,pplev,pphi + s ,pu,pv,pt,po + s ,pduadj,pdvadj,pdtadj,pdoadj + s ,fm0,entr0 +c s ,pu_therm,pv_therm + s ,r_aspect,l_mix,w2di,tho) + + USE dimphy + IMPLICIT NONE + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c +c Réécriture à partir d'un listing papier à Habas, le 14/02/00 +c +c le thermique est supposé homogène et dissipé par mélange avec +c son environnement. la longueur l_mix contrôle l'efficacité du +c mélange +c +c Le calcul du transport des différentes espèces se fait en prenant +c en compte: +c 1. un flux de masse montant +c 2. un flux de masse descendant +c 3. un entrainement +c 4. un detrainement +c +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" + +c arguments: +c ---------- + + INTEGER ngrid,nlay,w2di,tho + real ptimestep,l_mix,r_aspect + REAL pt(ngrid,nlay),pdtadj(ngrid,nlay) + REAL pu(ngrid,nlay),pduadj(ngrid,nlay) + REAL pv(ngrid,nlay),pdvadj(ngrid,nlay) + REAL po(ngrid,nlay),pdoadj(ngrid,nlay) + REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1) + real pphi(ngrid,nlay) + + integer idetr + save idetr + data idetr/3/ +c$OMP THREADPRIVATE(idetr) + +c local: +c ------ + + INTEGER ig,k,l,lmaxa(klon),lmix(klon) + real zsortie1d(klon) +c CR: on remplace lmax(klon,klev+1) + INTEGER lmax(klon),lmin(klon),lentr(klon) + real linter(klon) + real zmix(klon), fracazmix(klon) +c RC + real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz + + real zlev(klon,klev+1),zlay(klon,klev) + REAL zh(klon,klev),zdhadj(klon,klev) + real zthl(klon,klev),zdthladj(klon,klev) + REAL ztv(klon,klev) + real zu(klon,klev),zv(klon,klev),zo(klon,klev) + real zl(klon,klev) + REAL wh(klon,klev+1) + real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1) + real zla(klon,klev+1) + real zwa(klon,klev+1) + real zld(klon,klev+1) + real zwd(klon,klev+1) + real zsortie(klon,klev) + real zva(klon,klev) + real zua(klon,klev) + real zoa(klon,klev) + + real zta(klon,klev) + real zha(klon,klev) + real wa_moy(klon,klev+1) + real fraca(klon,klev+1) + real fracc(klon,klev+1) + real zf,zf2 + real thetath2(klon,klev),wth2(klon,klev) +! common/comtherm/thetath2,wth2 + + real count_time + integer isplit,nsplit,ialt + parameter (nsplit=10) + data isplit/0/ + save isplit +c$OMP THREADPRIVATE(isplit) + + logical sorties + real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev) + real zpspsk(klon,klev) + +c real wmax(klon,klev),wmaxa(klon) + real wmax(klon),wmaxa(klon) + real wa(klon,klev,klev+1) + real wd(klon,klev+1) + real larg_part(klon,klev,klev+1) + real fracd(klon,klev+1) + real xxx(klon,klev+1) + real larg_cons(klon,klev+1) + real larg_detr(klon,klev+1) + real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev) + real pu_therm(klon,klev),pv_therm(klon,klev) + real fm(klon,klev+1),entr(klon,klev) + real fmc(klon,klev+1) + + real zcor,zdelta,zcvm5,qlbef + real Tbef(klon),qsatbef(klon) + real dqsat_dT,DT,num,denom + REAL REPS,RLvCp,DDT0 + real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev) + + PARAMETER (DDT0=.01) + +cCR:nouvelles variables + real f_star(klon,klev+1),entr_star(klon,klev) + real entr_star_tot(klon),entr_star2(klon) + real f(klon), f0(klon) + real zlevinter(klon) + logical first + data first /.false./ + save first +c$OMP THREADPRIVATE(first) + +cRC + + character*2 str2 + character*10 str10 + + LOGICAL vtest(klon),down + LOGICAL Zsat(klon) + + EXTERNAL SCOPY + + integer ncorrec,ll + save ncorrec + data ncorrec/0/ +c$OMP THREADPRIVATE(ncorrec) + +c + +c----------------------------------------------------------------------- +c initialisation: +c --------------- +c + sorties=.true. + IF(ngrid.NE.klon) THEN + PRINT* + PRINT*,'STOP dans convadj' + PRINT*,'ngrid =',ngrid + PRINT*,'klon =',klon + ENDIF +c +c Initialisation + RLvCp = RLVTT/RCPD + REPS = RD/RV +c +c----------------------------------------------------------------------- +cAM Calcul de T,q,ql a partir de Tl et qT +c --------------------------------------------------- +c +c Pr Tprec=Tl calcul de qsat +c Si qsat>qT T=Tl, q=qT +c Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) +c On cherche DDT < DDT0 +c +c defaut + DO ll=1,nlay + DO ig=1,ngrid + zo(ig,ll)=po(ig,ll) + zl(ig,ll)=0. + zh(ig,ll)=pt(ig,ll) + EndDO + EndDO + do ig=1,ngrid + Zsat(ig)=.false. + enddo +c +c + DO ll=1,nlay +c les points insatures sont definitifs + DO ig=1,ngrid + Tbef(ig)=pt(ig,ll) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll) + qsatbef(ig)=MIN(0.5,qsatbef(ig)) + zcor=1./(1.-retv*qsatbef(ig)) + qsatbef(ig)=qsatbef(ig)*zcor + Zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig)) .gt. 0.00001) + EndDO + + DO ig=1,ngrid + if (Zsat(ig)) then + qlbef=max(0.,po(ig,ll)-qsatbef(ig)) +c si sature: ql est surestime, d'ou la sous-relax + DT = 0.5*RLvCp*qlbef +c on pourra enchainer 2 ou 3 calculs sans Do while + do while (DT.gt.DDT0) +c il faut verifier si c,a conserve quand on repasse en insature ... + Tbef(ig)=Tbef(ig)+DT + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll) + qsatbef(ig)=MIN(0.5,qsatbef(ig)) + zcor=1./(1.-retv*qsatbef(ig)) + qsatbef(ig)=qsatbef(ig)*zcor +c on veut le signe de qlbef + qlbef=po(ig,ll)-qsatbef(ig) +c dqsat_dT + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta + zcor=1./(1.-retv*qsatbef(ig)) + dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor) + num=-Tbef(ig)+pt(ig,ll)+RLvCp*qlbef + denom=1.+RLvCp*dqsat_dT + DT=num/denom + enddo +c on ecrit de maniere conservative (sat ou non) + zl(ig,ll) = max(0.,qlbef) +c T = Tl +Lv/Cp ql + zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll) + zo(ig,ll) = po(ig,ll)-zl(ig,ll) + endif + EndDO + EndDO +cAM fin +c +c----------------------------------------------------------------------- +c incrementation eventuelle de tendances precedentes: +c --------------------------------------------------- + + print*,'0 OK convect8' + + DO 1010 l=1,nlay + DO 1015 ig=1,ngrid + zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA +c zh(ig,l)=pt(ig,l)/zpspsk(ig,l) + zu(ig,l)=pu(ig,l) + zv(ig,l)=pv(ig,l) +c zo(ig,l)=po(ig,l) +c ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l)) +cAM attention zh est maintenant le profil de T et plus le profil de theta ! +c +c T-> Theta + ztv(ig,l)=zh(ig,l)/zpspsk(ig,l) +cAM Theta_v + ztv(ig,l)=ztv(ig,l)*(1.+RETV*(zo(ig,l)) + s -zl(ig,l)) +cAM Thetal + zthl(ig,l)=pt(ig,l)/zpspsk(ig,l) +c +1015 CONTINUE +1010 CONTINUE + +c print*,'1 OK convect8' +c -------------------- +c +c +c + + + + + + + + + + + +c +c +c wa, fraca, wd, fracd -------------------- zlev(2), rhobarz +c wh,wt,wo ... +c +c + + + + + + + + + + + zh,zu,zv,zo,rho +c +c +c -------------------- zlev(1) +c \\\\\\\\\\\\\\\\\\\\ +c +c + +c----------------------------------------------------------------------- +c Calcul des altitudes des couches +c----------------------------------------------------------------------- + + do l=2,nlay + do ig=1,ngrid + zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG + enddo + enddo + do ig=1,ngrid + zlev(ig,1)=0. + zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG + enddo + do l=1,nlay + do ig=1,ngrid + zlay(ig,l)=pphi(ig,l)/RG + enddo + enddo + +c print*,'2 OK convect8' +c----------------------------------------------------------------------- +c Calcul des densites +c----------------------------------------------------------------------- + + do l=1,nlay + do ig=1,ngrid +c rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l)) + rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*ztv(ig,l)) + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1)) + enddo + enddo + + do k=1,nlay + do l=1,nlay+1 + do ig=1,ngrid + wa(ig,k,l)=0. + enddo + enddo + enddo + +c print*,'3 OK convect8' +c------------------------------------------------------------------ +c Calcul de w2, quarre de w a partir de la cape +c a partir de w2, on calcule wa, vitesse de l'ascendance +c +c ATTENTION: Dans cette version, pour cause d'economie de memoire, +c w2 est stoke dans wa +c +c ATTENTION: dans convect8, on n'utilise le calcule des wa +c independants par couches que pour calculer l'entrainement +c a la base et la hauteur max de l'ascendance. +c +c Indicages: +c l'ascendance provenant du niveau k traverse l'interface l avec +c une vitesse wa(k,l). +c +c -------------------- +c +c + + + + + + + + + + +c +c wa(k,l) ---- -------------------- l +c /\ +c /||\ + + + + + + + + + + +c || +c || -------------------- +c || +c || + + + + + + + + + + +c || +c || -------------------- +c ||__ +c |___ + + + + + + + + + + k +c +c -------------------- +c +c +c +c------------------------------------------------------------------ + +cCR: ponderation entrainement des couches instables +cdef des entr_star tels que entr=f*entr_star + do l=1,klev + do ig=1,ngrid + entr_star(ig,l)=0. + enddo + enddo +c determination de la longueur de la couche d entrainement + do ig=1,ngrid + lentr(ig)=1 + enddo + +con ne considere que les premieres couches instables + do k=nlay-1,1,-1 + do ig=1,ngrid + if (ztv(ig,k).gt.ztv(ig,k+1).and. + s ztv(ig,k+1).lt.ztv(ig,k+2)) then + lentr(ig)=k + endif + enddo + enddo + +c determination du lmin: couche d ou provient le thermique + do ig=1,ngrid + lmin(ig)=1 + enddo + do ig=1,ngrid + do l=nlay,2,-1 + if (ztv(ig,l-1).gt.ztv(ig,l)) then + lmin(ig)=l-1 + endif + enddo + enddo +c +c definition de l'entrainement des couches + do l=1,klev-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. + s l.ge.lmin(ig).and.l.le.lentr(ig)) then + entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))* + s (zlev(ig,l+1)-zlev(ig,l)) + endif + enddo + enddo +c pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.1) then + do l=1,klev + entr_star(ig,l)=0. + enddo + endif + enddo +c calcul de l entrainement total + do ig=1,ngrid + entr_star_tot(ig)=0. + enddo + do ig=1,ngrid + do k=1,klev + entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k) + enddo + enddo +c + do k=1,klev + do ig=1,ngrid + ztva(ig,k)=ztv(ig,k) + enddo + enddo +cRC +cAM:initialisations + do k=1,nlay + do ig=1,ngrid + ztva(ig,k)=ztv(ig,k) + ztla(ig,k)=zthl(ig,k) + zqla(ig,k)=0. + zqta(ig,k)=po(ig,k) + Zsat(ig) =.false. + enddo + enddo +c +c print*,'7 OK convect8' + do k=1,klev+1 + do ig=1,ngrid + zw2(ig,k)=0. + fmc(ig,k)=0. +cCR + f_star(ig,k)=0. +cRC + larg_cons(ig,k)=0. + larg_detr(ig,k)=0. + wa_moy(ig,k)=0. + enddo + enddo + +c print*,'8 OK convect8' + do ig=1,ngrid + linter(ig)=1. + lmaxa(ig)=1 + lmix(ig)=1 + wmaxa(ig)=0. + enddo + +cCR: + do l=1,nlay-2 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1) + s .and.entr_star(ig,l).gt.1.e-10 + s .and.zw2(ig,l).lt.1e-10) then +cAM + ztla(ig,l)=zthl(ig,l) + zqta(ig,l)=po(ig,l) + zqla(ig,l)=zl(ig,l) +cAM + f_star(ig,l+1)=entr_star(ig,l) +ctest:calcul de dteta + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) + s *(zlev(ig,l+1)-zlev(ig,l)) + s *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + larg_detr(ig,l)=0. + else if ((zw2(ig,l).ge.1e-10).and. + s (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then + f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l) +c +cAM on melange Tl et qt du thermique + ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+entr_star(ig,l) + s *zthl(ig,l))/f_star(ig,l+1) + zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+entr_star(ig,l) + s *po(ig,l))/f_star(ig,l+1) +c +c ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l) +c s *ztv(ig,l))/f_star(ig,l+1) +c +cAM on en deduit thetav et ql du thermique + Tbef(ig)=ztla(ig,l)*zpspsk(ig,l) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l) + qsatbef(ig)=MIN(0.5,qsatbef(ig)) + zcor=1./(1.-retv*qsatbef(ig)) + qsatbef(ig)=qsatbef(ig)*zcor + Zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig)) .gt. 0.00001) + endif + enddo + DO ig=1,ngrid + if (Zsat(ig)) then + qlbef=max(0.,zqta(ig,l)-qsatbef(ig)) + DT = 0.5*RLvCp*qlbef + do while (DT.gt.DDT0) + Tbef(ig)=Tbef(ig)+DT + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l) + qsatbef(ig)=MIN(0.5,qsatbef(ig)) + zcor=1./(1.-retv*qsatbef(ig)) + qsatbef(ig)=qsatbef(ig)*zcor + qlbef=zqta(ig,l)-qsatbef(ig) + + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta + zcor=1./(1.-retv*qsatbef(ig)) + dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor) + num=-Tbef(ig)+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef + denom=1.+RLvCp*dqsat_dT + DT=num/denom + enddo + zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig)) + endif +c on ecrit de maniere conservative (sat ou non) +c T = Tl +Lv/Cp ql + ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) + ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) + ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) + s -zqla(ig,l))-zqla(ig,l)) + + enddo + DO ig=1,ngrid + if (zw2(ig,l).ge.1.e-10.and. + s f_star(ig,l)+entr_star(ig,l).gt.1.e-10) then +c mise a jour de la vitesse ascendante (l'air entraine de la couche +c consideree commence avec une vitesse nulle). +c + zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+ + s 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + endif +c determination de zmax continu par interpolation lineaire + if (zw2(ig,l+1).lt.0.) then + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) + s -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. + lmaxa(ig)=l + else + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + endif + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +c lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo +c +c Calcul de la couche correspondant a la hauteur du thermique + do ig=1,ngrid + lmax(ig)=lentr(ig) + enddo + do ig=1,ngrid + do l=nlay,lentr(ig)+1,-1 + if (zw2(ig,l).le.1.e-10) then + lmax(ig)=l-1 + endif + enddo + enddo +c pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.1) then + lmax(ig)=1 + lmin(ig)=1 + endif + enddo +c +c Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +c Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=500. + zlevinter(ig)=zlev(ig,1) + enddo + do ig=1,ngrid +c calcul de zlevinter + zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* + s linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) + s -zlev(ig,lmax(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + enddo + +c Fermeture,determination de f + do ig=1,ngrid + entr_star2(ig)=0. + enddo + do ig=1,ngrid + if (entr_star_tot(ig).LT.1.e-10) then + f(ig)=0. + else + do k=lmin(ig),lentr(ig) + entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2 + s /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))) + enddo +c Nouvelle fermeture + f(ig)=wmax(ig)/(zmax(ig)*r_aspect*entr_star2(ig)) + s *entr_star_tot(ig) +ctest + if (first) then + f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig) + s *wmax(ig)) + endif + endif + f0(ig)=f(ig) + first=.true. + enddo + +c Calcul de l'entrainement + do k=1,klev + do ig=1,ngrid + entr(ig,k)=f(ig)*entr_star(ig,k) + enddo + enddo +c Calcul des flux + do ig=1,ngrid + do l=1,lmax(ig)-1 + fmc(ig,l+1)=fmc(ig,l)+entr(ig,l) + enddo + enddo + +cRC + + +c print*,'9 OK convect8' +c print*,'WA1 ',wa_moy + +c determination de l'indice du debut de la mixed layer ou w decroit + +c calcul de la largeur de chaque ascendance dans le cas conservatif. +c dans ce cas simple, on suppose que la largeur de l'ascendance provenant +c d'une couche est égale à la hauteur de la couche alimentante. +c La vitesse maximale dans l'ascendance est aussi prise comme estimation +c de la vitesse d'entrainement horizontal dans la couche alimentante. + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then + zw=max(wa_moy(ig,l),1.e-10) + larg_cons(ig,l)=zmax(ig)*r_aspect + s *fmc(ig,l)/(rhobarz(ig,l)*zw) + endif + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then +c if (idetr.eq.0) then +c cette option est finalement en dur. + larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c else if (idetr.eq.1) then +c larg_detr(ig,l)=larg_cons(ig,l) +c s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) +c else if (idetr.eq.2) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *sqrt(wa_moy(ig,l)) +c else if (idetr.eq.4) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *wa_moy(ig,l) +c endif + endif + enddo + enddo + +c print*,'10 OK convect8' +c print*,'WA2 ',wa_moy +c calcul de la fraction de la maille concernée par l'ascendance en tenant +c compte de l'epluchage du thermique. +c +cCR def de zmix continu (profil parabolique des vitesses) + do ig=1,ngrid + if (lmix(ig).gt.1.) then + zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2)) + s /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + else + zmix(ig)=0. + endif + enddo +c +c calcul du nouveau lmix correspondant + do ig=1,ngrid + do l=1,klev + if (zmix(ig).ge.zlev(ig,l).and. + s zmix(ig).lt.zlev(ig,l+1)) then + lmix(ig)=l + endif + enddo + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then +c print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l)) + s /(r_aspect*zmax(ig)) +c test + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + else +c wa_moy(ig,l)=0. + fraca(ig,l)=0. + fracc(ig,l)=0. + fracd(ig,l)=1. + endif + enddo + enddo +cCR: calcul de fracazmix + do ig=1,ngrid + fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ + s (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + s +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1) + s -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then + if (l.gt.lmix(ig)) then + xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) + if (idetr.eq.0) then + fraca(ig,l)=fracazmix(ig) + else if (idetr.eq.1) then + fraca(ig,l)=fracazmix(ig)*xxx(ig,l) + else if (idetr.eq.2) then + fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) + else + fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2 + endif +c print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + endif + endif + enddo + enddo + +c print*,'11 OK convect8' +c print*,'Ea3 ',wa_moy +c------------------------------------------------------------------ +c Calcul de fracd, wd +c somme wa - wd = 0 +c------------------------------------------------------------------ + + + do ig=1,ngrid + fm(ig,1)=0. + fm(ig,nlay+1)=0. + enddo + + do l=2,nlay + do ig=1,ngrid + fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l) +cCR:test + if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1) + s .and.l.gt.lmix(ig)) then + fm(ig,l)=fm(ig,l-1) +c write(1,*)'ajustement fm, l',l + endif +c write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) +cRC + enddo + do ig=1,ngrid + if(fracd(ig,l).lt.0.1) then + stop'fracd trop petit' + else +c vitesse descendante "diagnostique" + wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l)) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid +c masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG + enddo + enddo + +c print*,'12 OK convect8' +c print*,'WA4 ',wa_moy +cc------------------------------------------------------------------ +c calcul du transport vertical +c------------------------------------------------------------------ + + go to 4444 +c print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + do l=2,nlay-1 + do ig=1,ngrid + if(fm(ig,l+1)*ptimestep.gt.masse(ig,l) + s .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then +c print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' +c s ,fm(ig,l+1)*ptimestep +c s ,' M=',masse(ig,l),masse(ig,l+1) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then +c print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' +c s ,entr(ig,l)*ptimestep +c s ,' M=',masse(ig,l) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then +c print*,'WARN!!! fm exagere ig=',ig,' l=',l +c s ,' FM=',fm(ig,l) + endif + if(.not.masse(ig,l).ge.1.e-10 + s .or..not.masse(ig,l).le.1.e4) then +c print*,'WARN!!! masse exagere ig=',ig,' l=',l +c s ,' M=',masse(ig,l) +c print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', +c s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) +c print*,'zlev(ig,l+1),zlev(ig,l)' +c s ,zlev(ig,l+1),zlev(ig,l) +c print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' +c s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + endif + if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then +c print*,'WARN!!! entr exagere ig=',ig,' l=',l +c s ,' E=',entr(ig,l) + endif + enddo + enddo + +4444 continue + + if (w2di.eq.1) then + fm0=fm0+ptimestep*(fm-fm0)/float(tho) + entr0=entr0+ptimestep*(entr-entr0)/float(tho) + else + fm0=fm + entr0=entr + endif + + if (1.eq.1) then +c call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse +c . ,zh,zdhadj,zha) +c call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse +c . ,zo,pdoadj,zoa) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zthl,zdthladj,zta) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,po,pdoadj,zoa) + else + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zh,zdhadj,zha) + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zo,pdoadj,zoa) + endif + + if (1.eq.0) then + call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,fraca,zmax + . ,zu,zv,pduadj,pdvadj,zua,zva) + else + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zu,pduadj,zua) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zv,pdvadj,zva) + endif + + do l=1,nlay + do ig=1,ngrid + zf=0.5*(fracc(ig,l)+fracc(ig,l+1)) + zf2=zf/(1.-zf) + thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2 + wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 + enddo + enddo + + + +c print*,'13 OK convect8' +c print*,'WA5 ',wa_moy + do l=1,nlay + do ig=1,ngrid +c pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l) + pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l) + enddo + enddo + + +c do l=1,nlay +c do ig=1,ngrid +c if(abs(pdtadj(ig,l))*86400..gt.500.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdtadj=',pdtadj(ig,l) +c endif +c if(abs(pdoadj(ig,l))*86400..gt.1.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdoadj=',pdoadj(ig,l) +c endif +c enddo +c enddo + +c print*,'14 OK convect8' +c------------------------------------------------------------------ +c Calculs pour les sorties +c------------------------------------------------------------------ + + if(sorties) then + do l=1,nlay + do ig=1,ngrid + zla(ig,l)=(1.-fracd(ig,l))*zmax(ig) + zld(ig,l)=fracd(ig,l)*zmax(ig) + if(1.-fracd(ig,l).gt.1.e-10) + s zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l)) + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) + if (detr(ig,l).lt.0.) then + entr(ig,l)=entr(ig,l)-detr(ig,l) + detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l + endif + enddo + enddo + +c print*,'15 OK convect8' + + isplit=isplit+1 + + +c #define und + goto 123 +#ifdef und + CALL writeg1d(1,nlay,wd,'wd ','wd ') + CALL writeg1d(1,nlay,zwa,'wa ','wa ') + CALL writeg1d(1,nlay,fracd,'fracd ','fracd ') + CALL writeg1d(1,nlay,fraca,'fraca ','fraca ') + CALL writeg1d(1,nlay,wa_moy,'wam ','wam ') + CALL writeg1d(1,nlay,zla,'la ','la ') + CALL writeg1d(1,nlay,zld,'ld ','ld ') + CALL writeg1d(1,nlay,pt,'pt ','pt ') + CALL writeg1d(1,nlay,zh,'zh ','zh ') + CALL writeg1d(1,nlay,zha,'zha ','zha ') + CALL writeg1d(1,nlay,zu,'zu ','zu ') + CALL writeg1d(1,nlay,zv,'zv ','zv ') + CALL writeg1d(1,nlay,zo,'zo ','zo ') + CALL writeg1d(1,nlay,wh,'wh ','wh ') + CALL writeg1d(1,nlay,wu,'wu ','wu ') + CALL writeg1d(1,nlay,wv,'wv ','wv ') + CALL writeg1d(1,nlay,wo,'w15uo ','wXo ') + CALL writeg1d(1,nlay,zdhadj,'zdhadj ','zdhadj ') + CALL writeg1d(1,nlay,pduadj,'pduadj ','pduadj ') + CALL writeg1d(1,nlay,pdvadj,'pdvadj ','pdvadj ') + CALL writeg1d(1,nlay,pdoadj,'pdoadj ','pdoadj ') + CALL writeg1d(1,nlay,entr ,'entr ','entr ') + CALL writeg1d(1,nlay,detr ,'detr ','detr ') + CALL writeg1d(1,nlay,fm ,'fm ','fm ') + + CALL writeg1d(1,nlay,pdtadj,'pdtadj ','pdtadj ') + CALL writeg1d(1,nlay,pplay,'pplay ','pplay ') + CALL writeg1d(1,nlay,pplev,'pplev ','pplev ') + +c recalcul des flux en diagnostique... +c print*,'PAS DE TEMPS ',ptimestep + call dt2F(pplev,pplay,pt,pdtadj,wh) + CALL writeg1d(1,nlay,wh,'wh2 ','wh2 ') +#endif +123 continue +! #define troisD +#ifdef troisD +c if (sorties) then + print*,'Debut des wrgradsfi' + +c print*,'16 OK convect8' + call wrgradsfi(1,nlay,wd,'wd ','wd ') + call wrgradsfi(1,nlay,zwa,'wa ','wa ') + call wrgradsfi(1,nlay,fracd,'fracd ','fracd ') + call wrgradsfi(1,nlay,fraca,'fraca ','fraca ') + call wrgradsfi(1,nlay,xxx,'xxx ','xxx ') + call wrgradsfi(1,nlay,wa_moy,'wam ','wam ') +c print*,'WA6 ',wa_moy + call wrgradsfi(1,nlay,zla,'la ','la ') + call wrgradsfi(1,nlay,zld,'ld ','ld ') + call wrgradsfi(1,nlay,pt,'pt ','pt ') + call wrgradsfi(1,nlay,zh,'zh ','zh ') + call wrgradsfi(1,nlay,zha,'zha ','zha ') + call wrgradsfi(1,nlay,zua,'zua ','zua ') + call wrgradsfi(1,nlay,zva,'zva ','zva ') + call wrgradsfi(1,nlay,zu,'zu ','zu ') + call wrgradsfi(1,nlay,zv,'zv ','zv ') + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,wh,'wh ','wh ') + call wrgradsfi(1,nlay,wu,'wu ','wu ') + call wrgradsfi(1,nlay,wv,'wv ','wv ') + call wrgradsfi(1,nlay,wo,'wo ','wo ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,nlay,zdhadj,'zdhadj ','zdhadj ') + call wrgradsfi(1,nlay,pduadj,'pduadj ','pduadj ') + call wrgradsfi(1,nlay,pdvadj,'pdvadj ','pdvadj ') + call wrgradsfi(1,nlay,pdoadj,'pdoadj ','pdoadj ') + call wrgradsfi(1,nlay,entr,'entr ','entr ') + call wrgradsfi(1,nlay,detr,'detr ','detr ') + call wrgradsfi(1,nlay,fm,'fm ','fm ') + call wrgradsfi(1,nlay,fmc,'fmc ','fmc ') + call wrgradsfi(1,nlay,zw2,'zw2 ','zw2 ') + call wrgradsfi(1,nlay,ztva,'ztva ','ztva ') + call wrgradsfi(1,nlay,ztv,'ztv ','ztv ') + + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,larg_cons,'Lc ','Lc ') + call wrgradsfi(1,nlay,larg_detr,'Ldetr ','Ldetr ') + +cAM:nouveaux diagnostiques + call wrgradsfi(1,nlay,zthl,'zthl ','zthl ') + call wrgradsfi(1,nlay,zta,'zta ','zta ') + call wrgradsfi(1,nlay,zl,'zl ','zl ') + call wrgradsfi(1,nlay,zdthladj,'zdthladj ', + s 'zdthladj ') + call wrgradsfi(1,nlay,ztla,'ztla ','ztla ') + call wrgradsfi(1,nlay,zqta,'zqta ','zqta ') + call wrgradsfi(1,nlay,zqla,'zqla ','zqla ') +cCR:nouveaux diagnostiques + call wrgradsfi(1,nlay,entr_star ,'entr_star ','entr_star ') + call wrgradsfi(1,nlay,f_star ,'f_star ','f_star ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,1,zmix,'zmix ','zmix ') + zsortie1d(:)=lmax(:) + call wrgradsfi(1,1,zsortie1d,'lmax ','lmax ') + call wrgradsfi(1,1,wmax,'wmax ','wmax ') + zsortie1d(:)=lmix(:) + call wrgradsfi(1,1,zsortie1d,'lmix ','lmix ') + zsortie1d(:)=lentr(:) + call wrgradsfi(1,1,zsortie1d,'lentr ','lentr ') + +c print*,'17 OK convect8' + + do k=1,klev/10 + write(str2,'(i2.2)') k + str10='wa'//str2 + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=wa(ig,k,l) + enddo + enddo + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=larg_part(ig,k,l) + enddo + enddo + str10='la'//str2 + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + enddo + + +c print*,'18 OK convect8' +c endif + print*,'Fin des wrgradsfi' +#endif + + endif + +c if(wa_moy(1,4).gt.1.e-10) stop + +c print*,'19 OK convect8' + return + end + + SUBROUTINE thermcell(ngrid,nlay,ptimestep + s ,pplay,pplev,pphi + s ,pu,pv,pt,po + s ,pduadj,pdvadj,pdtadj,pdoadj + s ,fm0,entr0 +c s ,pu_therm,pv_therm + s ,r_aspect,l_mix,w2di,tho) + + USE dimphy + IMPLICIT NONE + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c +c Réécriture à partir d'un listing papier à Habas, le 14/02/00 +c +c le thermique est supposé homogène et dissipé par mélange avec +c son environnement. la longueur l_mix contrôle l'efficacité du +c mélange +c +c Le calcul du transport des différentes espèces se fait en prenant +c en compte: +c 1. un flux de masse montant +c 2. un flux de masse descendant +c 3. un entrainement +c 4. un detrainement +c +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" + +c arguments: +c ---------- + + INTEGER ngrid,nlay,w2di,tho + real ptimestep,l_mix,r_aspect + REAL pt(ngrid,nlay),pdtadj(ngrid,nlay) + REAL pu(ngrid,nlay),pduadj(ngrid,nlay) + REAL pv(ngrid,nlay),pdvadj(ngrid,nlay) + REAL po(ngrid,nlay),pdoadj(ngrid,nlay) + REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1) + real pphi(ngrid,nlay) + + integer idetr + save idetr + data idetr/3/ +c$OMP THREADPRIVATE(idetr) + +c local: +c ------ + + INTEGER ig,k,l,lmaxa(klon),lmix(klon) + real zsortie1d(klon) +c CR: on remplace lmax(klon,klev+1) + INTEGER lmax(klon),lmin(klon),lentr(klon) + real linter(klon) + real zmix(klon), fracazmix(klon) +c RC + real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz + + real zlev(klon,klev+1),zlay(klon,klev) + REAL zh(klon,klev),zdhadj(klon,klev) + REAL ztv(klon,klev) + real zu(klon,klev),zv(klon,klev),zo(klon,klev) + REAL wh(klon,klev+1) + real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1) + real zla(klon,klev+1) + real zwa(klon,klev+1) + real zld(klon,klev+1) + real zwd(klon,klev+1) + real zsortie(klon,klev) + real zva(klon,klev) + real zua(klon,klev) + real zoa(klon,klev) + + real zha(klon,klev) + real wa_moy(klon,klev+1) + real fraca(klon,klev+1) + real fracc(klon,klev+1) + real zf,zf2 + real thetath2(klon,klev),wth2(klon,klev) +! common/comtherm/thetath2,wth2 + + real count_time + integer isplit,nsplit,ialt + parameter (nsplit=10) + data isplit/0/ + save isplit +c$OMP THREADPRIVATE(isplit) + + logical sorties + real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev) + real zpspsk(klon,klev) + +c real wmax(klon,klev),wmaxa(klon) + real wmax(klon),wmaxa(klon) + real wa(klon,klev,klev+1) + real wd(klon,klev+1) + real larg_part(klon,klev,klev+1) + real fracd(klon,klev+1) + real xxx(klon,klev+1) + real larg_cons(klon,klev+1) + real larg_detr(klon,klev+1) + real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev) + real pu_therm(klon,klev),pv_therm(klon,klev) + real fm(klon,klev+1),entr(klon,klev) + real fmc(klon,klev+1) + +cCR:nouvelles variables + real f_star(klon,klev+1),entr_star(klon,klev) + real entr_star_tot(klon),entr_star2(klon) + real f(klon), f0(klon) + real zlevinter(klon) + logical first + data first /.false./ + save first +c$OMP THREADPRIVATE(first) +cRC + + character*2 str2 + character*10 str10 + + LOGICAL vtest(klon),down + + EXTERNAL SCOPY + + integer ncorrec,ll + save ncorrec + data ncorrec/0/ +c$OMP THREADPRIVATE(ncorrec) + +c +c----------------------------------------------------------------------- +c initialisation: +c --------------- +c + sorties=.true. + IF(ngrid.NE.klon) THEN + PRINT* + PRINT*,'STOP dans convadj' + PRINT*,'ngrid =',ngrid + PRINT*,'klon =',klon + ENDIF +c +c----------------------------------------------------------------------- +c incrementation eventuelle de tendances precedentes: +c --------------------------------------------------- + + print*,'0 OK convect8' + + DO 1010 l=1,nlay + DO 1015 ig=1,ngrid + zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA + zh(ig,l)=pt(ig,l)/zpspsk(ig,l) + zu(ig,l)=pu(ig,l) + zv(ig,l)=pv(ig,l) + zo(ig,l)=po(ig,l) + ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l)) +1015 CONTINUE +1010 CONTINUE + + print*,'1 OK convect8' +c -------------------- +c +c +c + + + + + + + + + + + +c +c +c wa, fraca, wd, fracd -------------------- zlev(2), rhobarz +c wh,wt,wo ... +c +c + + + + + + + + + + + zh,zu,zv,zo,rho +c +c +c -------------------- zlev(1) +c \\\\\\\\\\\\\\\\\\\\ +c +c + +c----------------------------------------------------------------------- +c Calcul des altitudes des couches +c----------------------------------------------------------------------- + + do l=2,nlay + do ig=1,ngrid + zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG + enddo + enddo + do ig=1,ngrid + zlev(ig,1)=0. + zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG + enddo + do l=1,nlay + do ig=1,ngrid + zlay(ig,l)=pphi(ig,l)/RG + enddo + enddo + +c print*,'2 OK convect8' +c----------------------------------------------------------------------- +c Calcul des densites +c----------------------------------------------------------------------- + + do l=1,nlay + do ig=1,ngrid + rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l)) + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1)) + enddo + enddo + + do k=1,nlay + do l=1,nlay+1 + do ig=1,ngrid + wa(ig,k,l)=0. + enddo + enddo + enddo + +c print*,'3 OK convect8' +c------------------------------------------------------------------ +c Calcul de w2, quarre de w a partir de la cape +c a partir de w2, on calcule wa, vitesse de l'ascendance +c +c ATTENTION: Dans cette version, pour cause d'economie de memoire, +c w2 est stoke dans wa +c +c ATTENTION: dans convect8, on n'utilise le calcule des wa +c independants par couches que pour calculer l'entrainement +c a la base et la hauteur max de l'ascendance. +c +c Indicages: +c l'ascendance provenant du niveau k traverse l'interface l avec +c une vitesse wa(k,l). +c +c -------------------- +c +c + + + + + + + + + + +c +c wa(k,l) ---- -------------------- l +c /\ +c /||\ + + + + + + + + + + +c || +c || -------------------- +c || +c || + + + + + + + + + + +c || +c || -------------------- +c ||__ +c |___ + + + + + + + + + + k +c +c -------------------- +c +c +c +c------------------------------------------------------------------ + +cCR: ponderation entrainement des couches instables +cdef des entr_star tels que entr=f*entr_star + do l=1,klev + do ig=1,ngrid + entr_star(ig,l)=0. + enddo + enddo +c determination de la longueur de la couche d entrainement + do ig=1,ngrid + lentr(ig)=1 + enddo + +con ne considere que les premieres couches instables + do k=nlay-2,1,-1 + do ig=1,ngrid + if (ztv(ig,k).gt.ztv(ig,k+1).and. + s ztv(ig,k+1).le.ztv(ig,k+2)) then + lentr(ig)=k + endif + enddo + enddo + +c determination du lmin: couche d ou provient le thermique + do ig=1,ngrid + lmin(ig)=1 + enddo + do ig=1,ngrid + do l=nlay,2,-1 + if (ztv(ig,l-1).gt.ztv(ig,l)) then + lmin(ig)=l-1 + endif + enddo + enddo +c +c definition de l'entrainement des couches + do l=1,klev-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. + s l.ge.lmin(ig).and.l.le.lentr(ig)) then + entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))* + s (zlev(ig,l+1)-zlev(ig,l)) + endif + enddo + enddo +c pas de thermique si couches 1->5 stables + do ig=1,ngrid + if (lmin(ig).gt.5) then + do l=1,klev + entr_star(ig,l)=0. + enddo + endif + enddo +c calcul de l entrainement total + do ig=1,ngrid + entr_star_tot(ig)=0. + enddo + do ig=1,ngrid + do k=1,klev + entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k) + enddo + enddo +c + print*,'fin calcul entr_star' + do k=1,klev + do ig=1,ngrid + ztva(ig,k)=ztv(ig,k) + enddo + enddo +cRC +c print*,'7 OK convect8' + do k=1,klev+1 + do ig=1,ngrid + zw2(ig,k)=0. + fmc(ig,k)=0. +cCR + f_star(ig,k)=0. +cRC + larg_cons(ig,k)=0. + larg_detr(ig,k)=0. + wa_moy(ig,k)=0. + enddo + enddo + +c print*,'8 OK convect8' + do ig=1,ngrid + linter(ig)=1. + lmaxa(ig)=1 + lmix(ig)=1 + wmaxa(ig)=0. + enddo + +cCR: + do l=1,nlay-2 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1) + s .and.entr_star(ig,l).gt.1.e-10 + s .and.zw2(ig,l).lt.1e-10) then + f_star(ig,l+1)=entr_star(ig,l) +ctest:calcul de dteta + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) + s *(zlev(ig,l+1)-zlev(ig,l)) + s *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + larg_detr(ig,l)=0. + else if ((zw2(ig,l).ge.1e-10).and. + s (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then + f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l) + ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l) + s *ztv(ig,l))/f_star(ig,l+1) + zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+ + s 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + endif +c determination de zmax continu par interpolation lineaire + if (zw2(ig,l+1).lt.0.) then +ctest + if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then + print*,'pb linter' + endif + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) + s -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. + lmaxa(ig)=l + else + if (zw2(ig,l+1).lt.0.) then + print*,'pb1 zw2<0' + endif + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + endif + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +c lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo + print*,'fin calcul zw2' +c +c Calcul de la couche correspondant a la hauteur du thermique + do ig=1,ngrid + lmax(ig)=lentr(ig) + enddo + do ig=1,ngrid + do l=nlay,lentr(ig)+1,-1 + if (zw2(ig,l).le.1.e-10) then + lmax(ig)=l-1 + endif + enddo + enddo +c pas de thermique si couches 1->5 stables + do ig=1,ngrid + if (lmin(ig).gt.5) then + lmax(ig)=1 + lmin(ig)=1 + endif + enddo +c +c Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (zw2(ig,l).lt.0.)then + print*,'pb2 zw2<0' + endif + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +c Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=0. + zlevinter(ig)=zlev(ig,1) + enddo + do ig=1,ngrid +c calcul de zlevinter + zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* + s linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) + s -zlev(ig,lmax(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + enddo + + print*,'avant fermeture' +c Fermeture,determination de f + do ig=1,ngrid + entr_star2(ig)=0. + enddo + do ig=1,ngrid + if (entr_star_tot(ig).LT.1.e-10) then + f(ig)=0. + else + do k=lmin(ig),lentr(ig) + entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2 + s /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))) + enddo +c Nouvelle fermeture + f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect + s *entr_star2(ig))*entr_star_tot(ig) +ctest +c if (first) then +c f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig) +c s *wmax(ig)) +c endif + endif +c f0(ig)=f(ig) +c first=.true. + enddo + print*,'apres fermeture' + +c Calcul de l'entrainement + do k=1,klev + do ig=1,ngrid + entr(ig,k)=f(ig)*entr_star(ig,k) + enddo + enddo +c Calcul des flux + do ig=1,ngrid + do l=1,lmax(ig)-1 + fmc(ig,l+1)=fmc(ig,l)+entr(ig,l) + enddo + enddo + +cRC + + +c print*,'9 OK convect8' +c print*,'WA1 ',wa_moy + +c determination de l'indice du debut de la mixed layer ou w decroit + +c calcul de la largeur de chaque ascendance dans le cas conservatif. +c dans ce cas simple, on suppose que la largeur de l'ascendance provenant +c d'une couche est égale à la hauteur de la couche alimentante. +c La vitesse maximale dans l'ascendance est aussi prise comme estimation +c de la vitesse d'entrainement horizontal dans la couche alimentante. + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then + zw=max(wa_moy(ig,l),1.e-10) + larg_cons(ig,l)=zmax(ig)*r_aspect + s *fmc(ig,l)/(rhobarz(ig,l)*zw) + endif + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then +c if (idetr.eq.0) then +c cette option est finalement en dur. + if ((l_mix*zlev(ig,l)).lt.0.)then + print*,'pb l_mix*zlev<0' + endif + larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c else if (idetr.eq.1) then +c larg_detr(ig,l)=larg_cons(ig,l) +c s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) +c else if (idetr.eq.2) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *sqrt(wa_moy(ig,l)) +c else if (idetr.eq.4) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *wa_moy(ig,l) +c endif + endif + enddo + enddo + +c print*,'10 OK convect8' +c print*,'WA2 ',wa_moy +c calcul de la fraction de la maille concernée par l'ascendance en tenant +c compte de l'epluchage du thermique. +c +cCR def de zmix continu (profil parabolique des vitesses) + do ig=1,ngrid + if (lmix(ig).gt.1.) then +c test + if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10) + s then +c + zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2)) + s /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + else + zmix(ig)=zlev(ig,lmix(ig)) + print*,'pb zmix' + endif + else + zmix(ig)=0. + endif +ctest + if ((zmax(ig)-zmix(ig)).lt.0.) then + zmix(ig)=0.99*zmax(ig) +c print*,'pb zmix>zmax' + endif + enddo +c +c calcul du nouveau lmix correspondant + do ig=1,ngrid + do l=1,klev + if (zmix(ig).ge.zlev(ig,l).and. + s zmix(ig).lt.zlev(ig,l+1)) then + lmix(ig)=l + endif + enddo + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then +c print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l)) + s /(r_aspect*zmax(ig)) +c test + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + else +c wa_moy(ig,l)=0. + fraca(ig,l)=0. + fracc(ig,l)=0. + fracd(ig,l)=1. + endif + enddo + enddo +cCR: calcul de fracazmix + do ig=1,ngrid + fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ + s (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + s +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1) + s -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then + if (l.gt.lmix(ig)) then +ctest + if (zmax(ig)-zmix(ig).lt.1.e-10) then +c print*,'pb xxx' + xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig)) + else + xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) + endif + if (idetr.eq.0) then + fraca(ig,l)=fracazmix(ig) + else if (idetr.eq.1) then + fraca(ig,l)=fracazmix(ig)*xxx(ig,l) + else if (idetr.eq.2) then + fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) + else + fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2 + endif +c print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + endif + endif + enddo + enddo + + print*,'fin calcul fraca' +c print*,'11 OK convect8' +c print*,'Ea3 ',wa_moy +c------------------------------------------------------------------ +c Calcul de fracd, wd +c somme wa - wd = 0 +c------------------------------------------------------------------ + + + do ig=1,ngrid + fm(ig,1)=0. + fm(ig,nlay+1)=0. + enddo + + do l=2,nlay + do ig=1,ngrid + fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l) +cCR:test + if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1) + s .and.l.gt.lmix(ig)) then + fm(ig,l)=fm(ig,l-1) +c write(1,*)'ajustement fm, l',l + endif +c write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) +cRC + enddo + do ig=1,ngrid + if(fracd(ig,l).lt.0.1) then + stop'fracd trop petit' + else +c vitesse descendante "diagnostique" + wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l)) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid +c masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG + enddo + enddo + + print*,'12 OK convect8' +c print*,'WA4 ',wa_moy +cc------------------------------------------------------------------ +c calcul du transport vertical +c------------------------------------------------------------------ + + go to 4444 +c print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + do l=2,nlay-1 + do ig=1,ngrid + if(fm(ig,l+1)*ptimestep.gt.masse(ig,l) + s .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then +c print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' +c s ,fm(ig,l+1)*ptimestep +c s ,' M=',masse(ig,l),masse(ig,l+1) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then +c print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' +c s ,entr(ig,l)*ptimestep +c s ,' M=',masse(ig,l) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then +c print*,'WARN!!! fm exagere ig=',ig,' l=',l +c s ,' FM=',fm(ig,l) + endif + if(.not.masse(ig,l).ge.1.e-10 + s .or..not.masse(ig,l).le.1.e4) then +c print*,'WARN!!! masse exagere ig=',ig,' l=',l +c s ,' M=',masse(ig,l) +c print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', +c s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) +c print*,'zlev(ig,l+1),zlev(ig,l)' +c s ,zlev(ig,l+1),zlev(ig,l) +c print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' +c s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + endif + if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then +c print*,'WARN!!! entr exagere ig=',ig,' l=',l +c s ,' E=',entr(ig,l) + endif + enddo + enddo + +4444 continue + +cCR:redefinition du entr + do l=1,nlay + do ig=1,ngrid + detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) + if (detr(ig,l).lt.0.) then + entr(ig,l)=entr(ig,l)-detr(ig,l) + detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l + endif + enddo + enddo +cRC + if (w2di.eq.1) then + fm0=fm0+ptimestep*(fm-fm0)/float(tho) + entr0=entr0+ptimestep*(entr-entr0)/float(tho) + else + fm0=fm + entr0=entr + endif + + if (1.eq.1) then + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zh,zdhadj,zha) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zo,pdoadj,zoa) + else + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zh,zdhadj,zha) + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zo,pdoadj,zoa) + endif + + if (1.eq.0) then + call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,fraca,zmax + . ,zu,zv,pduadj,pdvadj,zua,zva) + else + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zu,pduadj,zua) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zv,pdvadj,zva) + endif + + do l=1,nlay + do ig=1,ngrid + zf=0.5*(fracc(ig,l)+fracc(ig,l+1)) + zf2=zf/(1.-zf) + thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2 + wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 + enddo + enddo + + + +c print*,'13 OK convect8' +c print*,'WA5 ',wa_moy + do l=1,nlay + do ig=1,ngrid + pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l) + enddo + enddo + + +c do l=1,nlay +c do ig=1,ngrid +c if(abs(pdtadj(ig,l))*86400..gt.500.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdtadj=',pdtadj(ig,l) +c endif +c if(abs(pdoadj(ig,l))*86400..gt.1.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdoadj=',pdoadj(ig,l) +c endif +c enddo +c enddo + + print*,'14 OK convect8' +c------------------------------------------------------------------ +c Calculs pour les sorties +c------------------------------------------------------------------ + + if(sorties) then + do l=1,nlay + do ig=1,ngrid + zla(ig,l)=(1.-fracd(ig,l))*zmax(ig) + zld(ig,l)=fracd(ig,l)*zmax(ig) + if(1.-fracd(ig,l).gt.1.e-10) + s zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l)) + enddo + enddo + +cdeja fait +c do l=1,nlay +c do ig=1,ngrid +c detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) +c if (detr(ig,l).lt.0.) then +c entr(ig,l)=entr(ig,l)-detr(ig,l) +c detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l +c endif +c enddo +c enddo + +c print*,'15 OK convect8' + + isplit=isplit+1 + + +c #define und + goto 123 +#ifdef und + CALL writeg1d(1,nlay,wd,'wd ','wd ') + CALL writeg1d(1,nlay,zwa,'wa ','wa ') + CALL writeg1d(1,nlay,fracd,'fracd ','fracd ') + CALL writeg1d(1,nlay,fraca,'fraca ','fraca ') + CALL writeg1d(1,nlay,wa_moy,'wam ','wam ') + CALL writeg1d(1,nlay,zla,'la ','la ') + CALL writeg1d(1,nlay,zld,'ld ','ld ') + CALL writeg1d(1,nlay,pt,'pt ','pt ') + CALL writeg1d(1,nlay,zh,'zh ','zh ') + CALL writeg1d(1,nlay,zha,'zha ','zha ') + CALL writeg1d(1,nlay,zu,'zu ','zu ') + CALL writeg1d(1,nlay,zv,'zv ','zv ') + CALL writeg1d(1,nlay,zo,'zo ','zo ') + CALL writeg1d(1,nlay,wh,'wh ','wh ') + CALL writeg1d(1,nlay,wu,'wu ','wu ') + CALL writeg1d(1,nlay,wv,'wv ','wv ') + CALL writeg1d(1,nlay,wo,'w15uo ','wXo ') + CALL writeg1d(1,nlay,zdhadj,'zdhadj ','zdhadj ') + CALL writeg1d(1,nlay,pduadj,'pduadj ','pduadj ') + CALL writeg1d(1,nlay,pdvadj,'pdvadj ','pdvadj ') + CALL writeg1d(1,nlay,pdoadj,'pdoadj ','pdoadj ') + CALL writeg1d(1,nlay,entr ,'entr ','entr ') + CALL writeg1d(1,nlay,detr ,'detr ','detr ') + CALL writeg1d(1,nlay,fm ,'fm ','fm ') + + CALL writeg1d(1,nlay,pdtadj,'pdtadj ','pdtadj ') + CALL writeg1d(1,nlay,pplay,'pplay ','pplay ') + CALL writeg1d(1,nlay,pplev,'pplev ','pplev ') + +c recalcul des flux en diagnostique... +c print*,'PAS DE TEMPS ',ptimestep + call dt2F(pplev,pplay,pt,pdtadj,wh) + CALL writeg1d(1,nlay,wh,'wh2 ','wh2 ') +#endif +123 continue +#define troisD +#ifdef troisD +c if (sorties) then + print*,'Debut des wrgradsfi' + +c print*,'16 OK convect8' + call wrgradsfi(1,nlay,wd,'wd ','wd ') + call wrgradsfi(1,nlay,zwa,'wa ','wa ') + call wrgradsfi(1,nlay,fracd,'fracd ','fracd ') + call wrgradsfi(1,nlay,fraca,'fraca ','fraca ') + call wrgradsfi(1,nlay,xxx,'xxx ','xxx ') + call wrgradsfi(1,nlay,wa_moy,'wam ','wam ') +c print*,'WA6 ',wa_moy + call wrgradsfi(1,nlay,zla,'la ','la ') + call wrgradsfi(1,nlay,zld,'ld ','ld ') + call wrgradsfi(1,nlay,pt,'pt ','pt ') + call wrgradsfi(1,nlay,zh,'zh ','zh ') + call wrgradsfi(1,nlay,zha,'zha ','zha ') + call wrgradsfi(1,nlay,zua,'zua ','zua ') + call wrgradsfi(1,nlay,zva,'zva ','zva ') + call wrgradsfi(1,nlay,zu,'zu ','zu ') + call wrgradsfi(1,nlay,zv,'zv ','zv ') + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,wh,'wh ','wh ') + call wrgradsfi(1,nlay,wu,'wu ','wu ') + call wrgradsfi(1,nlay,wv,'wv ','wv ') + call wrgradsfi(1,nlay,wo,'wo ','wo ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,nlay,zdhadj,'zdhadj ','zdhadj ') + call wrgradsfi(1,nlay,pduadj,'pduadj ','pduadj ') + call wrgradsfi(1,nlay,pdvadj,'pdvadj ','pdvadj ') + call wrgradsfi(1,nlay,pdoadj,'pdoadj ','pdoadj ') + call wrgradsfi(1,nlay,entr,'entr ','entr ') + call wrgradsfi(1,nlay,detr,'detr ','detr ') + call wrgradsfi(1,nlay,fm,'fm ','fm ') + call wrgradsfi(1,nlay,fmc,'fmc ','fmc ') + call wrgradsfi(1,nlay,zw2,'zw2 ','zw2 ') + call wrgradsfi(1,nlay,ztva,'ztva ','ztva ') + call wrgradsfi(1,nlay,ztv,'ztv ','ztv ') + + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,larg_cons,'Lc ','Lc ') + call wrgradsfi(1,nlay,larg_detr,'Ldetr ','Ldetr ') + +cCR:nouveaux diagnostiques + call wrgradsfi(1,nlay,entr_star ,'entr_star ','entr_star ') + call wrgradsfi(1,nlay,f_star ,'f_star ','f_star ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,1,zmix,'zmix ','zmix ') + zsortie1d(:)=lmax(:) + call wrgradsfi(1,1,zsortie1d,'lmax ','lmax ') + call wrgradsfi(1,1,wmax,'wmax ','wmax ') + zsortie1d(:)=lmix(:) + call wrgradsfi(1,1,zsortie1d,'lmix ','lmix ') + zsortie1d(:)=lentr(:) + call wrgradsfi(1,1,zsortie1d,'lentr ','lentr ') + +c print*,'17 OK convect8' + + do k=1,klev/10 + write(str2,'(i2.2)') k + str10='wa'//str2 + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=wa(ig,k,l) + enddo + enddo + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=larg_part(ig,k,l) + enddo + enddo + str10='la'//str2 + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + enddo + + +c print*,'18 OK convect8' +c endif + print*,'Fin des wrgradsfi' +#endif + + endif + +c if(wa_moy(1,4).gt.1.e-10) stop + + print*,'19 OK convect8' + return + end + + subroutine dqthermcell(ngrid,nlay,ptimestep,fm,entr, + . masse,q,dq,qa) + USE dimphy + implicit none + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c calcul du dq/dt une fois qu'on connait les ascendances +c +c======================================================================= + +#include "dimensions.h" +cccc#include "dimphy.h" + + integer ngrid,nlay + + real ptimestep + real masse(ngrid,nlay),fm(ngrid,nlay+1) + real entr(ngrid,nlay) + real q(ngrid,nlay) + real dq(ngrid,nlay) + + real qa(klon,klev),detr(klon,klev),wqd(klon,klev+1) + + integer ig,k + +c calcul du detrainement + + do k=1,nlay + do ig=1,ngrid + detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) +ctest + if (detr(ig,k).lt.0.) then + entr(ig,k)=entr(ig,k)-detr(ig,k) + detr(ig,k)=0. +c print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k), +c s 'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k) + endif + if (fm(ig,k+1).lt.0.) then +c print*,'fm2<0!!!' + endif + if (entr(ig,k).lt.0.) then +c print*,'entr2<0!!!' + endif + enddo + enddo + +c calcul de la valeur dans les ascendances + do ig=1,ngrid + qa(ig,1)=q(ig,1) + enddo + + do k=2,nlay + do ig=1,ngrid + if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt. + s 1.e-5*masse(ig,k)) then + qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k)) + s /(fm(ig,k+1)+detr(ig,k)) + else + qa(ig,k)=q(ig,k) + endif + if (qa(ig,k).lt.0.) then +c print*,'qa<0!!!' + endif + if (q(ig,k).lt.0.) then +c print*,'q<0!!!' + endif + enddo + enddo + + do k=2,nlay + do ig=1,ngrid +c wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k)) + wqd(ig,k)=fm(ig,k)*q(ig,k) + if (wqd(ig,k).lt.0.) then +c print*,'wqd<0!!!' + endif + enddo + enddo + do ig=1,ngrid + wqd(ig,1)=0. + wqd(ig,nlay+1)=0. + enddo + + do k=1,nlay + do ig=1,ngrid + dq(ig,k)=(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k) + s -wqd(ig,k)+wqd(ig,k+1)) + s /masse(ig,k) +c if (dq(ig,k).lt.0.) then +c print*,'dq<0!!!' +c endif + enddo + enddo + + return + end + subroutine dvthermcell(ngrid,nlay,ptimestep,fm,entr,masse + . ,fraca,larga + . ,u,v,du,dv,ua,va) + USE dimphy + implicit none + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c calcul du dq/dt une fois qu'on connait les ascendances +c +c======================================================================= + +#include "dimensions.h" +cccc#include "dimphy.h" + + integer ngrid,nlay + + real ptimestep + real masse(ngrid,nlay),fm(ngrid,nlay+1) + real fraca(ngrid,nlay+1) + real larga(ngrid) + real entr(ngrid,nlay) + real u(ngrid,nlay) + real ua(ngrid,nlay) + real du(ngrid,nlay) + real v(ngrid,nlay) + real va(ngrid,nlay) + real dv(ngrid,nlay) + + real qa(klon,klev),detr(klon,klev) + real wvd(klon,klev+1),wud(klon,klev+1) + real gamma0,gamma(klon,klev+1) + real dua,dva + integer iter + + integer ig,k + +c calcul du detrainement + + do k=1,nlay + do ig=1,ngrid + detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) + enddo + enddo + +c calcul de la valeur dans les ascendances + do ig=1,ngrid + ua(ig,1)=u(ig,1) + va(ig,1)=v(ig,1) + enddo + + do k=2,nlay + do ig=1,ngrid + if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt. + s 1.e-5*masse(ig,k)) then +c On itère sur la valeur du coeff de freinage. +c gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)) + gamma0=masse(ig,k) + s *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) ) + s *0.5/larga(ig) +c gamma0=0. +c la première fois on multiplie le coefficient de freinage +c par le module du vent dans la couche en dessous. + dua=ua(ig,k-1)-u(ig,k-1) + dva=va(ig,k-1)-v(ig,k-1) + do iter=1,5 + gamma(ig,k)=gamma0*sqrt(dua**2+dva**2) + ua(ig,k)=(fm(ig,k)*ua(ig,k-1) + s +(entr(ig,k)+gamma(ig,k))*u(ig,k)) + s /(fm(ig,k+1)+detr(ig,k)+gamma(ig,k)) + va(ig,k)=(fm(ig,k)*va(ig,k-1) + s +(entr(ig,k)+gamma(ig,k))*v(ig,k)) + s /(fm(ig,k+1)+detr(ig,k)+gamma(ig,k)) +c print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva + dua=ua(ig,k)-u(ig,k) + dva=va(ig,k)-v(ig,k) + enddo + else + ua(ig,k)=u(ig,k) + va(ig,k)=v(ig,k) + gamma(ig,k)=0. + endif + enddo + enddo + + do k=2,nlay + do ig=1,ngrid + wud(ig,k)=fm(ig,k)*u(ig,k) + wvd(ig,k)=fm(ig,k)*v(ig,k) + enddo + enddo + do ig=1,ngrid + wud(ig,1)=0. + wud(ig,nlay+1)=0. + wvd(ig,1)=0. + wvd(ig,nlay+1)=0. + enddo + + do k=1,nlay + do ig=1,ngrid + du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k) + s -(entr(ig,k)+gamma(ig,k))*u(ig,k) + s -wud(ig,k)+wud(ig,k+1)) + s /masse(ig,k) + dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k) + s -(entr(ig,k)+gamma(ig,k))*v(ig,k) + s -wvd(ig,k)+wvd(ig,k+1)) + s /masse(ig,k) + enddo + enddo + + return + end + subroutine dqthermcell2(ngrid,nlay,ptimestep,fm,entr,masse,frac + . ,q,dq,qa) + USE dimphy + implicit none + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c calcul du dq/dt une fois qu'on connait les ascendances +c +c======================================================================= + +#include "dimensions.h" +cccc#include "dimphy.h" + + integer ngrid,nlay + + real ptimestep + real masse(ngrid,nlay),fm(ngrid,nlay+1) + real entr(ngrid,nlay),frac(ngrid,nlay) + real q(ngrid,nlay) + real dq(ngrid,nlay) + + real qa(klon,klev),detr(klon,klev),wqd(klon,klev+1) + real qe(klon,klev),zf,zf2 + + integer ig,k + +c calcul du detrainement + + do k=1,nlay + do ig=1,ngrid + detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) + enddo + enddo + +c calcul de la valeur dans les ascendances + do ig=1,ngrid + qa(ig,1)=q(ig,1) + qe(ig,1)=q(ig,1) + enddo + + do k=2,nlay + do ig=1,ngrid + if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt. + s 1.e-5*masse(ig,k)) then + zf=0.5*(frac(ig,k)+frac(ig,k+1)) + zf2=1./(1.-zf) + qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+zf2*entr(ig,k)*q(ig,k)) + s /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2) + qe(ig,k)=(q(ig,k)-zf*qa(ig,k))*zf2 + else + qa(ig,k)=q(ig,k) + qe(ig,k)=q(ig,k) + endif + enddo + enddo + + do k=2,nlay + do ig=1,ngrid +c wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k)) + wqd(ig,k)=fm(ig,k)*qe(ig,k) + enddo + enddo + do ig=1,ngrid + wqd(ig,1)=0. + wqd(ig,nlay+1)=0. + enddo + + do k=1,nlay + do ig=1,ngrid + dq(ig,k)=(detr(ig,k)*qa(ig,k)-entr(ig,k)*qe(ig,k) + s -wqd(ig,k)+wqd(ig,k+1)) + s /masse(ig,k) + enddo + enddo + + return + end + subroutine dvthermcell2(ngrid,nlay,ptimestep,fm,entr,masse + . ,fraca,larga + . ,u,v,du,dv,ua,va) + use dimphy + implicit none + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c calcul du dq/dt une fois qu'on connait les ascendances +c +c======================================================================= + +#include "dimensions.h" +cccc#include "dimphy.h" + + integer ngrid,nlay + + real ptimestep + real masse(ngrid,nlay),fm(ngrid,nlay+1) + real fraca(ngrid,nlay+1) + real larga(ngrid) + real entr(ngrid,nlay) + real u(ngrid,nlay) + real ua(ngrid,nlay) + real du(ngrid,nlay) + real v(ngrid,nlay) + real va(ngrid,nlay) + real dv(ngrid,nlay) + + real qa(klon,klev),detr(klon,klev),zf,zf2 + real wvd(klon,klev+1),wud(klon,klev+1) + real gamma0,gamma(klon,klev+1) + real ue(klon,klev),ve(klon,klev) + real dua,dva + integer iter + + integer ig,k + +c calcul du detrainement + + do k=1,nlay + do ig=1,ngrid + detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) + enddo + enddo + +c calcul de la valeur dans les ascendances + do ig=1,ngrid + ua(ig,1)=u(ig,1) + va(ig,1)=v(ig,1) + ue(ig,1)=u(ig,1) + ve(ig,1)=v(ig,1) + enddo + + do k=2,nlay + do ig=1,ngrid + if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt. + s 1.e-5*masse(ig,k)) then +c On itère sur la valeur du coeff de freinage. +c gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)) + gamma0=masse(ig,k) + s *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) ) + s *0.5/larga(ig) + s *1. +c s *0.5 +c gamma0=0. + zf=0.5*(fraca(ig,k)+fraca(ig,k+1)) + zf=0. + zf2=1./(1.-zf) +c la première fois on multiplie le coefficient de freinage +c par le module du vent dans la couche en dessous. + dua=ua(ig,k-1)-u(ig,k-1) + dva=va(ig,k-1)-v(ig,k-1) + do iter=1,5 +c On choisit une relaxation lineaire. + gamma(ig,k)=gamma0 +c On choisit une relaxation quadratique. + gamma(ig,k)=gamma0*sqrt(dua**2+dva**2) + ua(ig,k)=(fm(ig,k)*ua(ig,k-1) + s +(zf2*entr(ig,k)+gamma(ig,k))*u(ig,k)) + s /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2 + s +gamma(ig,k)) + va(ig,k)=(fm(ig,k)*va(ig,k-1) + s +(zf2*entr(ig,k)+gamma(ig,k))*v(ig,k)) + s /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2 + s +gamma(ig,k)) +c print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva + dua=ua(ig,k)-u(ig,k) + dva=va(ig,k)-v(ig,k) + ue(ig,k)=(u(ig,k)-zf*ua(ig,k))*zf2 + ve(ig,k)=(v(ig,k)-zf*va(ig,k))*zf2 + enddo + else + ua(ig,k)=u(ig,k) + va(ig,k)=v(ig,k) + ue(ig,k)=u(ig,k) + ve(ig,k)=v(ig,k) + gamma(ig,k)=0. + endif + enddo + enddo + + do k=2,nlay + do ig=1,ngrid + wud(ig,k)=fm(ig,k)*ue(ig,k) + wvd(ig,k)=fm(ig,k)*ve(ig,k) + enddo + enddo + do ig=1,ngrid + wud(ig,1)=0. + wud(ig,nlay+1)=0. + wvd(ig,1)=0. + wvd(ig,nlay+1)=0. + enddo + + do k=1,nlay + do ig=1,ngrid + du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k) + s -(entr(ig,k)+gamma(ig,k))*ue(ig,k) + s -wud(ig,k)+wud(ig,k+1)) + s /masse(ig,k) + dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k) + s -(entr(ig,k)+gamma(ig,k))*ve(ig,k) + s -wvd(ig,k)+wvd(ig,k+1)) + s /masse(ig,k) + enddo + enddo + + return + end + SUBROUTINE thermcell_sec(ngrid,nlay,ptimestep + s ,pplay,pplev,pphi,zlev + s ,pu,pv,pt,po + s ,pduadj,pdvadj,pdtadj,pdoadj + s ,fm0,entr0 +c s ,pu_therm,pv_therm + s ,r_aspect,l_mix,w2di,tho) + + use dimphy + IMPLICIT NONE + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c +c Réécriture à partir d'un listing papier à Habas, le 14/02/00 +c +c le thermique est supposé homogène et dissipé par mélange avec +c son environnement. la longueur l_mix contrôle l'efficacité du +c mélange +c +c Le calcul du transport des différentes espèces se fait en prenant +c en compte: +c 1. un flux de masse montant +c 2. un flux de masse descendant +c 3. un entrainement +c 4. un detrainement +c +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" + +c arguments: +c ---------- + + INTEGER ngrid,nlay,w2di,tho + real ptimestep,l_mix,r_aspect + REAL pt(ngrid,nlay),pdtadj(ngrid,nlay) + REAL pu(ngrid,nlay),pduadj(ngrid,nlay) + REAL pv(ngrid,nlay),pdvadj(ngrid,nlay) + REAL po(ngrid,nlay),pdoadj(ngrid,nlay) + REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1) + real pphi(ngrid,nlay) + + integer idetr + save idetr + data idetr/3/ +c$OMP THREADPRIVATE(idetr) + +c local: +c ------ + + INTEGER ig,k,l,lmaxa(klon),lmix(klon) + real zsortie1d(klon) +c CR: on remplace lmax(klon,klev+1) + INTEGER lmax(klon),lmin(klon),lentr(klon) + real linter(klon) + real zmix(klon), fracazmix(klon) +c RC + real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz + + real zlev(klon,klev+1),zlay(klon,klev) + REAL zh(klon,klev),zdhadj(klon,klev) + REAL ztv(klon,klev) + real zu(klon,klev),zv(klon,klev),zo(klon,klev) + REAL wh(klon,klev+1) + real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1) + real zla(klon,klev+1) + real zwa(klon,klev+1) + real zld(klon,klev+1) + real zwd(klon,klev+1) + real zsortie(klon,klev) + real zva(klon,klev) + real zua(klon,klev) + real zoa(klon,klev) + + real zha(klon,klev) + real wa_moy(klon,klev+1) + real fraca(klon,klev+1) + real fracc(klon,klev+1) + real zf,zf2 + real thetath2(klon,klev),wth2(klon,klev) +! common/comtherm/thetath2,wth2 + + real count_time + integer isplit,nsplit,ialt + parameter (nsplit=10) + data isplit/0/ + save isplit +c$OMP THREADPRIVATE(isplit) + + logical sorties + real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev) + real zpspsk(klon,klev) + +c real wmax(klon,klev),wmaxa(klon) + real wmax(klon),wmaxa(klon) + real wa(klon,klev,klev+1) + real wd(klon,klev+1) + real larg_part(klon,klev,klev+1) + real fracd(klon,klev+1) + real xxx(klon,klev+1) + real larg_cons(klon,klev+1) + real larg_detr(klon,klev+1) + real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev) + real pu_therm(klon,klev),pv_therm(klon,klev) + real fm(klon,klev+1),entr(klon,klev) + real fmc(klon,klev+1) + +cCR:nouvelles variables + real f_star(klon,klev+1),entr_star(klon,klev) + real entr_star_tot(klon),entr_star2(klon) + real f(klon), f0(klon) + real zlevinter(klon) + logical first + data first /.false./ + save first +c$OMP THREADPRIVATE(first) +cRC + + character*2 str2 + character*10 str10 + + LOGICAL vtest(klon),down + + EXTERNAL SCOPY + + integer ncorrec,ll + save ncorrec + data ncorrec/0/ +c$OMP THREADPRIVATE(ncorrec) + +c +c----------------------------------------------------------------------- +c initialisation: +c --------------- +c + sorties=.true. + IF(ngrid.NE.klon) THEN + PRINT* + PRINT*,'STOP dans convadj' + PRINT*,'ngrid =',ngrid + PRINT*,'klon =',klon + ENDIF +c +c----------------------------------------------------------------------- +c incrementation eventuelle de tendances precedentes: +c --------------------------------------------------- + +c print*,'0 OK convect8' + + DO 1010 l=1,nlay + DO 1015 ig=1,ngrid + zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA + zh(ig,l)=pt(ig,l)/zpspsk(ig,l) + zu(ig,l)=pu(ig,l) + zv(ig,l)=pv(ig,l) + zo(ig,l)=po(ig,l) + ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l)) +1015 CONTINUE +1010 CONTINUE + +c print*,'1 OK convect8' +c -------------------- +c +c +c + + + + + + + + + + + +c +c +c wa, fraca, wd, fracd -------------------- zlev(2), rhobarz +c wh,wt,wo ... +c +c + + + + + + + + + + + zh,zu,zv,zo,rho +c +c +c -------------------- zlev(1) +c \\\\\\\\\\\\\\\\\\\\ +c +c + +c----------------------------------------------------------------------- +c Calcul des altitudes des couches +c----------------------------------------------------------------------- + + do l=2,nlay + do ig=1,ngrid + zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG + enddo + enddo + do ig=1,ngrid + zlev(ig,1)=0. + zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG + enddo + do l=1,nlay + do ig=1,ngrid + zlay(ig,l)=pphi(ig,l)/RG + enddo + enddo + +c print*,'2 OK convect8' +c----------------------------------------------------------------------- +c Calcul des densites +c----------------------------------------------------------------------- + + do l=1,nlay + do ig=1,ngrid + rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l)) + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1)) + enddo + enddo + + do k=1,nlay + do l=1,nlay+1 + do ig=1,ngrid + wa(ig,k,l)=0. + enddo + enddo + enddo + +c print*,'3 OK convect8' +c------------------------------------------------------------------ +c Calcul de w2, quarre de w a partir de la cape +c a partir de w2, on calcule wa, vitesse de l'ascendance +c +c ATTENTION: Dans cette version, pour cause d'economie de memoire, +c w2 est stoke dans wa +c +c ATTENTION: dans convect8, on n'utilise le calcule des wa +c independants par couches que pour calculer l'entrainement +c a la base et la hauteur max de l'ascendance. +c +c Indicages: +c l'ascendance provenant du niveau k traverse l'interface l avec +c une vitesse wa(k,l). +c +c -------------------- +c +c + + + + + + + + + + +c +c wa(k,l) ---- -------------------- l +c /\ +c /||\ + + + + + + + + + + +c || +c || -------------------- +c || +c || + + + + + + + + + + +c || +c || -------------------- +c ||__ +c |___ + + + + + + + + + + k +c +c -------------------- +c +c +c +c------------------------------------------------------------------ + +cCR: ponderation entrainement des couches instables +cdef des entr_star tels que entr=f*entr_star + do l=1,klev + do ig=1,ngrid + entr_star(ig,l)=0. + enddo + enddo +c determination de la longueur de la couche d entrainement + do ig=1,ngrid + lentr(ig)=1 + enddo + +con ne considere que les premieres couches instables + do k=nlay-2,1,-1 + do ig=1,ngrid + if (ztv(ig,k).gt.ztv(ig,k+1).and. + s ztv(ig,k+1).le.ztv(ig,k+2)) then + lentr(ig)=k + endif + enddo + enddo + +c determination du lmin: couche d ou provient le thermique + do ig=1,ngrid + lmin(ig)=1 + enddo + do ig=1,ngrid + do l=nlay,2,-1 + if (ztv(ig,l-1).gt.ztv(ig,l)) then + lmin(ig)=l-1 + endif + enddo + enddo +c +c definition de l'entrainement des couches + do l=1,klev-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. + s l.ge.lmin(ig).and.l.le.lentr(ig)) then + entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))* +c s (zlev(ig,l+1)-zlev(ig,l)) + s *sqrt(zlev(ig,l+1)) + endif + enddo + enddo +c pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.1) then + do l=1,klev + entr_star(ig,l)=0. + enddo + endif + enddo +c calcul de l entrainement total + do ig=1,ngrid + entr_star_tot(ig)=0. + enddo + do ig=1,ngrid + do k=1,klev + entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k) + enddo + enddo +c +c print*,'fin calcul entr_star' + do k=1,klev + do ig=1,ngrid + ztva(ig,k)=ztv(ig,k) + enddo + enddo +cRC +c print*,'7 OK convect8' + do k=1,klev+1 + do ig=1,ngrid + zw2(ig,k)=0. + fmc(ig,k)=0. +cCR + f_star(ig,k)=0. +cRC + larg_cons(ig,k)=0. + larg_detr(ig,k)=0. + wa_moy(ig,k)=0. + enddo + enddo + +c print*,'8 OK convect8' + do ig=1,ngrid + linter(ig)=1. + lmaxa(ig)=1 + lmix(ig)=1 + wmaxa(ig)=0. + enddo + +cCR: + do l=1,nlay-2 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1) + s .and.entr_star(ig,l).gt.1.e-10 + s .and.zw2(ig,l).lt.1e-10) then + f_star(ig,l+1)=entr_star(ig,l) +ctest:calcul de dteta + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) + s *(zlev(ig,l+1)-zlev(ig,l)) + s *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + larg_detr(ig,l)=0. + else if ((zw2(ig,l).ge.1e-10).and. + s (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then + f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l) + ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l) + s *ztv(ig,l))/f_star(ig,l+1) + zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+ + s 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + endif +c determination de zmax continu par interpolation lineaire + if (zw2(ig,l+1).lt.0.) then +ctest + if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then +c print*,'pb linter' + endif + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) + s -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. + lmaxa(ig)=l + else + if (zw2(ig,l+1).lt.0.) then +c print*,'pb1 zw2<0' + endif + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + endif + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +c lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo +c print*,'fin calcul zw2' +c +c Calcul de la couche correspondant a la hauteur du thermique + do ig=1,ngrid + lmax(ig)=lentr(ig) + enddo + do ig=1,ngrid + do l=nlay,lentr(ig)+1,-1 + if (zw2(ig,l).le.1.e-10) then + lmax(ig)=l-1 + endif + enddo + enddo +c pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.1) then + lmax(ig)=1 + lmin(ig)=1 + endif + enddo +c +c Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (zw2(ig,l).lt.0.)then +c print*,'pb2 zw2<0' + endif + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +c Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=0. + zlevinter(ig)=zlev(ig,1) + enddo + do ig=1,ngrid +c calcul de zlevinter + zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* + s linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) + s -zlev(ig,lmax(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + enddo + +c print*,'avant fermeture' +c Fermeture,determination de f + do ig=1,ngrid + entr_star2(ig)=0. + enddo + do ig=1,ngrid + if (entr_star_tot(ig).LT.1.e-10) then + f(ig)=0. + else + do k=lmin(ig),lentr(ig) + entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2 + s /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))) + enddo +c Nouvelle fermeture + f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect + s *entr_star2(ig))*entr_star_tot(ig) +ctest +c if (first) then +c f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig) +c s *wmax(ig)) +c endif + endif +c f0(ig)=f(ig) +c first=.true. + enddo +c print*,'apres fermeture' + +c Calcul de l'entrainement + do k=1,klev + do ig=1,ngrid + entr(ig,k)=f(ig)*entr_star(ig,k) + enddo + enddo +cCR:test pour entrainer moins que la masse + do ig=1,ngrid + do l=1,lentr(ig) + if ((entr(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then + entr(ig,l+1)=entr(ig,l+1)+entr(ig,l) + s -0.9*masse(ig,l)/ptimestep + entr(ig,l)=0.9*masse(ig,l)/ptimestep + endif + enddo + enddo +cCR: fin test +c Calcul des flux + do ig=1,ngrid + do l=1,lmax(ig)-1 + fmc(ig,l+1)=fmc(ig,l)+entr(ig,l) + enddo + enddo + +cRC + + +c print*,'9 OK convect8' +c print*,'WA1 ',wa_moy + +c determination de l'indice du debut de la mixed layer ou w decroit + +c calcul de la largeur de chaque ascendance dans le cas conservatif. +c dans ce cas simple, on suppose que la largeur de l'ascendance provenant +c d'une couche est égale à la hauteur de la couche alimentante. +c La vitesse maximale dans l'ascendance est aussi prise comme estimation +c de la vitesse d'entrainement horizontal dans la couche alimentante. + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then + zw=max(wa_moy(ig,l),1.e-10) + larg_cons(ig,l)=zmax(ig)*r_aspect + s *fmc(ig,l)/(rhobarz(ig,l)*zw) + endif + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then +c if (idetr.eq.0) then +c cette option est finalement en dur. + if ((l_mix*zlev(ig,l)).lt.0.)then +c print*,'pb l_mix*zlev<0' + endif +cCR: test: nouvelle def de lambda +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + if (zw2(ig,l).gt.1.e-10) then + larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l)) + else + larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + endif +cRC +c else if (idetr.eq.1) then +c larg_detr(ig,l)=larg_cons(ig,l) +c s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) +c else if (idetr.eq.2) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *sqrt(wa_moy(ig,l)) +c else if (idetr.eq.4) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *wa_moy(ig,l) +c endif + endif + enddo + enddo + +c print*,'10 OK convect8' +c print*,'WA2 ',wa_moy +c calcul de la fraction de la maille concernée par l'ascendance en tenant +c compte de l'epluchage du thermique. +c +cCR def de zmix continu (profil parabolique des vitesses) + do ig=1,ngrid + if (lmix(ig).gt.1.) then +c test + if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10) + s then +c + zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2)) + s /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + else + zmix(ig)=zlev(ig,lmix(ig)) +c print*,'pb zmix' + endif + else + zmix(ig)=0. + endif +ctest + if ((zmax(ig)-zmix(ig)).lt.0.) then + zmix(ig)=0.99*zmax(ig) +c print*,'pb zmix>zmax' + endif + enddo +c +c calcul du nouveau lmix correspondant + do ig=1,ngrid + do l=1,klev + if (zmix(ig).ge.zlev(ig,l).and. + s zmix(ig).lt.zlev(ig,l+1)) then + lmix(ig)=l + endif + enddo + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then +c print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l)) + s /(r_aspect*zmax(ig)) +c test + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + else +c wa_moy(ig,l)=0. + fraca(ig,l)=0. + fracc(ig,l)=0. + fracd(ig,l)=1. + endif + enddo + enddo +cCR: calcul de fracazmix + do ig=1,ngrid + fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ + s (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + s +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1) + s -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then + if (l.gt.lmix(ig)) then +ctest + if (zmax(ig)-zmix(ig).lt.1.e-10) then +c print*,'pb xxx' + xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig)) + else + xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) + endif + if (idetr.eq.0) then + fraca(ig,l)=fracazmix(ig) + else if (idetr.eq.1) then + fraca(ig,l)=fracazmix(ig)*xxx(ig,l) + else if (idetr.eq.2) then + fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) + else + fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2 + endif +c print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + endif + endif + enddo + enddo + +c print*,'fin calcul fraca' +c print*,'11 OK convect8' +c print*,'Ea3 ',wa_moy +c------------------------------------------------------------------ +c Calcul de fracd, wd +c somme wa - wd = 0 +c------------------------------------------------------------------ + + + do ig=1,ngrid + fm(ig,1)=0. + fm(ig,nlay+1)=0. + enddo + + do l=2,nlay + do ig=1,ngrid + fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l) +cCR:test + if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1) + s .and.l.gt.lmix(ig)) then + fm(ig,l)=fm(ig,l-1) +c write(1,*)'ajustement fm, l',l + endif +c write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) +cRC + enddo + do ig=1,ngrid + if(fracd(ig,l).lt.0.1) then + stop'fracd trop petit' + else +c vitesse descendante "diagnostique" + wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l)) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid +c masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG + enddo + enddo + +c print*,'12 OK convect8' +c print*,'WA4 ',wa_moy +cc------------------------------------------------------------------ +c calcul du transport vertical +c------------------------------------------------------------------ + + go to 4444 +c print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + do l=2,nlay-1 + do ig=1,ngrid + if(fm(ig,l+1)*ptimestep.gt.masse(ig,l) + s .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then +c print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' +c s ,fm(ig,l+1)*ptimestep +c s ,' M=',masse(ig,l),masse(ig,l+1) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then +c print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' +c s ,entr(ig,l)*ptimestep +c s ,' M=',masse(ig,l) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then +c print*,'WARN!!! fm exagere ig=',ig,' l=',l +c s ,' FM=',fm(ig,l) + endif + if(.not.masse(ig,l).ge.1.e-10 + s .or..not.masse(ig,l).le.1.e4) then +c print*,'WARN!!! masse exagere ig=',ig,' l=',l +c s ,' M=',masse(ig,l) +c print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', +c s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) +c print*,'zlev(ig,l+1),zlev(ig,l)' +c s ,zlev(ig,l+1),zlev(ig,l) +c print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' +c s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + endif + if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then +c print*,'WARN!!! entr exagere ig=',ig,' l=',l +c s ,' E=',entr(ig,l) + endif + enddo + enddo + +4444 continue + +cCR:redefinition du entr + do l=1,nlay + do ig=1,ngrid + detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) + if (detr(ig,l).lt.0.) then + entr(ig,l)=entr(ig,l)-detr(ig,l) + detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l + endif + enddo + enddo +cRC + if (w2di.eq.1) then + fm0=fm0+ptimestep*(fm-fm0)/float(tho) + entr0=entr0+ptimestep*(entr-entr0)/float(tho) + else + fm0=fm + entr0=entr + endif + + if (1.eq.1) then + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zh,zdhadj,zha) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zo,pdoadj,zoa) + else + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zh,zdhadj,zha) + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zo,pdoadj,zoa) + endif + + if (1.eq.0) then + call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,fraca,zmax + . ,zu,zv,pduadj,pdvadj,zua,zva) + else + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zu,pduadj,zua) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zv,pdvadj,zva) + endif + + do l=1,nlay + do ig=1,ngrid + zf=0.5*(fracc(ig,l)+fracc(ig,l+1)) + zf2=zf/(1.-zf) + thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2 + wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 + enddo + enddo + + + +c print*,'13 OK convect8' +c print*,'WA5 ',wa_moy + do l=1,nlay + do ig=1,ngrid + pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l) + enddo + enddo + + +c do l=1,nlay +c do ig=1,ngrid +c if(abs(pdtadj(ig,l))*86400..gt.500.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdtadj=',pdtadj(ig,l) +c endif +c if(abs(pdoadj(ig,l))*86400..gt.1.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdoadj=',pdoadj(ig,l) +c endif +c enddo +c enddo + +c print*,'14 OK convect8' +c------------------------------------------------------------------ +c Calculs pour les sorties +c------------------------------------------------------------------ + + if(sorties) then + do l=1,nlay + do ig=1,ngrid + zla(ig,l)=(1.-fracd(ig,l))*zmax(ig) + zld(ig,l)=fracd(ig,l)*zmax(ig) + if(1.-fracd(ig,l).gt.1.e-10) + s zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l)) + enddo + enddo + +cdeja fait +c do l=1,nlay +c do ig=1,ngrid +c detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) +c if (detr(ig,l).lt.0.) then +c entr(ig,l)=entr(ig,l)-detr(ig,l) +c detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l +c endif +c enddo +c enddo + +c print*,'15 OK convect8' + + isplit=isplit+1 + + +c #define und + goto 123 +#ifdef und + CALL writeg1d(1,nlay,wd,'wd ','wd ') + CALL writeg1d(1,nlay,zwa,'wa ','wa ') + CALL writeg1d(1,nlay,fracd,'fracd ','fracd ') + CALL writeg1d(1,nlay,fraca,'fraca ','fraca ') + CALL writeg1d(1,nlay,wa_moy,'wam ','wam ') + CALL writeg1d(1,nlay,zla,'la ','la ') + CALL writeg1d(1,nlay,zld,'ld ','ld ') + CALL writeg1d(1,nlay,pt,'pt ','pt ') + CALL writeg1d(1,nlay,zh,'zh ','zh ') + CALL writeg1d(1,nlay,zha,'zha ','zha ') + CALL writeg1d(1,nlay,zu,'zu ','zu ') + CALL writeg1d(1,nlay,zv,'zv ','zv ') + CALL writeg1d(1,nlay,zo,'zo ','zo ') + CALL writeg1d(1,nlay,wh,'wh ','wh ') + CALL writeg1d(1,nlay,wu,'wu ','wu ') + CALL writeg1d(1,nlay,wv,'wv ','wv ') + CALL writeg1d(1,nlay,wo,'w15uo ','wXo ') + CALL writeg1d(1,nlay,zdhadj,'zdhadj ','zdhadj ') + CALL writeg1d(1,nlay,pduadj,'pduadj ','pduadj ') + CALL writeg1d(1,nlay,pdvadj,'pdvadj ','pdvadj ') + CALL writeg1d(1,nlay,pdoadj,'pdoadj ','pdoadj ') + CALL writeg1d(1,nlay,entr ,'entr ','entr ') + CALL writeg1d(1,nlay,detr ,'detr ','detr ') + CALL writeg1d(1,nlay,fm ,'fm ','fm ') + + CALL writeg1d(1,nlay,pdtadj,'pdtadj ','pdtadj ') + CALL writeg1d(1,nlay,pplay,'pplay ','pplay ') + CALL writeg1d(1,nlay,pplev,'pplev ','pplev ') + +c recalcul des flux en diagnostique... +c print*,'PAS DE TEMPS ',ptimestep + call dt2F(pplev,pplay,pt,pdtadj,wh) + CALL writeg1d(1,nlay,wh,'wh2 ','wh2 ') +#endif +123 continue +! #define troisD +#ifdef troisD +c if (sorties) then + print*,'Debut des wrgradsfi' + +c print*,'16 OK convect8' + call wrgradsfi(1,nlay,wd,'wd ','wd ') + call wrgradsfi(1,nlay,zwa,'wa ','wa ') + call wrgradsfi(1,nlay,fracd,'fracd ','fracd ') + call wrgradsfi(1,nlay,fraca,'fraca ','fraca ') + call wrgradsfi(1,nlay,xxx,'xxx ','xxx ') + call wrgradsfi(1,nlay,wa_moy,'wam ','wam ') +c print*,'WA6 ',wa_moy + call wrgradsfi(1,nlay,zla,'la ','la ') + call wrgradsfi(1,nlay,zld,'ld ','ld ') + call wrgradsfi(1,nlay,pt,'pt ','pt ') + call wrgradsfi(1,nlay,zh,'zh ','zh ') + call wrgradsfi(1,nlay,zha,'zha ','zha ') + call wrgradsfi(1,nlay,zua,'zua ','zua ') + call wrgradsfi(1,nlay,zva,'zva ','zva ') + call wrgradsfi(1,nlay,zu,'zu ','zu ') + call wrgradsfi(1,nlay,zv,'zv ','zv ') + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,wh,'wh ','wh ') + call wrgradsfi(1,nlay,wu,'wu ','wu ') + call wrgradsfi(1,nlay,wv,'wv ','wv ') + call wrgradsfi(1,nlay,wo,'wo ','wo ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,nlay,zdhadj,'zdhadj ','zdhadj ') + call wrgradsfi(1,nlay,pduadj,'pduadj ','pduadj ') + call wrgradsfi(1,nlay,pdvadj,'pdvadj ','pdvadj ') + call wrgradsfi(1,nlay,pdoadj,'pdoadj ','pdoadj ') + call wrgradsfi(1,nlay,entr,'entr ','entr ') + call wrgradsfi(1,nlay,detr,'detr ','detr ') + call wrgradsfi(1,nlay,fm,'fm ','fm ') + call wrgradsfi(1,nlay,fmc,'fmc ','fmc ') + call wrgradsfi(1,nlay,zw2,'zw2 ','zw2 ') + call wrgradsfi(1,nlay,ztva,'ztva ','ztva ') + call wrgradsfi(1,nlay,ztv,'ztv ','ztv ') + + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,larg_cons,'Lc ','Lc ') + call wrgradsfi(1,nlay,larg_detr,'Ldetr ','Ldetr ') + +cCR:nouveaux diagnostiques + call wrgradsfi(1,nlay,entr_star ,'entr_star ','entr_star ') + call wrgradsfi(1,nlay,f_star ,'f_star ','f_star ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,1,zmix,'zmix ','zmix ') + zsortie1d(:)=lmax(:) + call wrgradsfi(1,1,zsortie1d,'lmax ','lmax ') + call wrgradsfi(1,1,wmax,'wmax ','wmax ') + zsortie1d(:)=lmix(:) + call wrgradsfi(1,1,zsortie1d,'lmix ','lmix ') + zsortie1d(:)=lentr(:) + call wrgradsfi(1,1,zsortie1d,'lentr ','lentr ') + +c print*,'17 OK convect8' + + do k=1,klev/10 + write(str2,'(i2.2)') k + str10='wa'//str2 + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=wa(ig,k,l) + enddo + enddo + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=larg_part(ig,k,l) + enddo + enddo + str10='la'//str2 + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + enddo + + +c print*,'18 OK convect8' +c endif + print*,'Fin des wrgradsfi' +#endif + + endif + +c if(wa_moy(1,4).gt.1.e-10) stop + +c print*,'19 OK convect8' + return + end + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_out3d.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_out3d.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_out3d.h (revision 1280) @@ -0,0 +1,71 @@ +! if (sorties) then + +! print*,'16 OK convect8' + call wrgradsfi(1,nlay,pt(igout,1:klev),'pt ','pt ') + call wrgradsfi(1,nlay,fraca(igout,1:klev),'fraca ','fraca ') + call wrgradsfi(1,nlay,zh(igout,1:klev),'zh ','zh ') + call wrgradsfi(1,nlay,zha(igout,1:klev),'zha ','zha ') + call wrgradsfi(1,nlay,zua(igout,1:klev),'zua ','zua ') + call wrgradsfi(1,nlay,zva(igout,1:klev),'zva ','zva ') + call wrgradsfi(1,nlay,zu(igout,1:klev),'zu ','zu ') + call wrgradsfi(1,nlay,zv(igout,1:klev),'zv ','zv ') + call wrgradsfi(1,nlay,zo(igout,1:klev),'zo ','zo ') + call wrgradsfi(1,1,zmax(igout),'zmax ','zmax ') +! call wrgradsfi(1,nlay,zdhadj(igout,1:klev),'zdhadj ','zdhadj ') + call wrgradsfi(1,nlay,pduadj(igout,1:klev),'pduadj ','pduadj ') + call wrgradsfi(1,nlay,pdvadj(igout,1:klev),'pdvadj ','pdvadj ') + call wrgradsfi(1,nlay,pdoadj(igout,1:klev),'pdoadj ','pdoadj ') + call wrgradsfi(1,nlay,entr(igout,1:klev),'entr ','entr ') + call wrgradsfi(1,nlay,detr(igout,1:klev),'detr ','detr ') + call wrgradsfi(1,nlay,fm(igout,1:klev),'fm ','fm ') + call wrgradsfi(1,nlay,zw2(igout,1:klev),'zw2 ','zw2 ') + call wrgradsfi(1,nlay,zw_est(igout,1:klev),'w_est ','w_est ') +!on sort les moments + call wrgradsfi(1,nlay,thetath2(igout,1:klev),'zh2 ','zh2 ') + call wrgradsfi(1,nlay,wth2(igout,1:klev),'w2 ','w2 ') + call wrgradsfi(1,nlay,wth3(igout,1:klev),'w3 ','w3 ') + call wrgradsfi(1,nlay,q2(igout,1:klev),'q2 ','q2 ') +! + call wrgradsfi(1,nlay,ztva(igout,1:klev),'ztva ','ztva ') + call wrgradsfi(1,nlay,ztv(igout,1:klev),'ztv ','ztv ') + + call wrgradsfi(1,nlay,zo(igout,1:klev),'zo ','zo ') + call wrgradsfi(1,nlay,zoa(igout,1:klev),'zoa ','zoa ') + +!nouveaux diagnostiques + call wrgradsfi(1,nlay,zthl(igout,1:klev),'zthl ','zthl ') + call wrgradsfi(1,nlay,zta(igout,1:klev),'zta ','zta ') + call wrgradsfi(1,nlay,zl(igout,1:klev),'zl ','zl ') + call wrgradsfi(1,nlay,zdthladj(igout,1:klev),'zdthladj ', & + & 'zdthladj ') + call wrgradsfi(1,nlay,ztla(igout,1:klev),'ztla ','ztla ') + call wrgradsfi(1,nlay,zqta(igout,1:klev),'zqta ','zqta ') + call wrgradsfi(1,nlay,zqla(igout,1:klev),'zqla ','zqla ') + call wrgradsfi(1,nlay,deltaz(igout,1:klev),'deltaz ','deltaz ') +!nouveaux diagnostiques + call wrgradsfi(1,nlay,entr_star (igout,1:klev),'entr_star ','entr_star ') + call wrgradsfi(1,nlay,detr_star (igout,1:klev),'detr_star ','detr_star ') + call wrgradsfi(1,nlay,f_star (igout,1:klev),'f_star ','f_star ') + call wrgradsfi(1,nlay,zqsat (igout,1:klev),'zqsat ','zqsat ') + call wrgradsfi(1,nlay,zqsatth (igout,1:klev),'qsath ','qsath ') + call wrgradsfi(1,nlay,alim_star (igout,1:klev),'alim_star ','alim_star ') +! call wrgradsfi(1,nlay,alim (igout,1:klev),'alim ','alim ') + call wrgradsfi(1,1,f(igout),'f ','f ') + call wrgradsfi(1,1,alim_star_tot(igout),'a_s_t ','a_s_t ') + call wrgradsfi(1,1,alim_star2(igout),'a_2 ','a_2 ') + call wrgradsfi(1,1,zmax(igout),'zmax ','zmax ') + call wrgradsfi(1,1,zmax_sec(igout),'z_sec ','z_sec ') + call wrgradsfi(1,1,zmix(igout),'zmix ','zmix ') +! call wrgradsfi(1,1,nivcon(igout),'nivcon ','nivcon ') + call wrgradsfi(1,1,zcon(igout),'zcon ','zcon ') + call wrgradsfi(1,1,zcon2(igout),'zcon2 ','zcon2 ') + zsortie1d(:)=lmax(:) + call wrgradsfi(1,1,zsortie1d(igout),'lmax ','lmax ') + call wrgradsfi(1,1,wmax(igout),'wmax ','wmax ') + call wrgradsfi(1,1,wmax_sec(igout),'w_sec ','w_sec ') +! zsortie1d(:)=lmix(:) +! call wrgradsfi(1,1,zsortie1d(igout),'lmix ','lmix ') +! zsortie1d(:)=lentr(:) +! call wrgradsfi(1,1,zsortie1d(igout),'lentr ','lentr ') + + print*,'Fin des wrgradsfi' Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_plume.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_plume.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/thermcell_plume.F90 (revision 1280) @@ -0,0 +1,802 @@ + SUBROUTINE thermcell_plume(itap,ngrid,klev,ptimestep,ztv,zthl,po,zl,rhobarz, & + & zlev,pplev,pphi,zpspsk,l_mix,r_aspect,alim_star,alim_star_tot, & + & lalim,zmax_sec,f0,detr_star,entr_star,f_star,ztva, & + & ztla,zqla,zqta,zha,zw2,w_est,zqsatth,lmix,lmix_bis,linter & + & ,lev_out,lunout1,igout) + +!-------------------------------------------------------------------------- +!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance +!-------------------------------------------------------------------------- + + IMPLICIT NONE + +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +#include "iniprint.h" +#include "thermcell.h" + + INTEGER itap + INTEGER lunout1,igout + INTEGER ngrid,klev + REAL ptimestep + REAL ztv(ngrid,klev) + REAL zthl(ngrid,klev) + REAL po(ngrid,klev) + REAL zl(ngrid,klev) + REAL rhobarz(ngrid,klev) + REAL zlev(ngrid,klev+1) + REAL pplev(ngrid,klev+1) + REAL pphi(ngrid,klev) + REAL zpspsk(ngrid,klev) + REAL alim_star(ngrid,klev) + REAL zmax_sec(ngrid) + REAL f0(ngrid) + REAL l_mix + REAL r_aspect + INTEGER lalim(ngrid) + integer lev_out ! niveau pour les print + real zcon2(ngrid) + + real alim_star_tot(ngrid) + + REAL ztva(ngrid,klev) + REAL ztla(ngrid,klev) + REAL zqla(ngrid,klev) + REAL zqla0(ngrid,klev) + REAL zqta(ngrid,klev) + REAL zha(ngrid,klev) + + REAL detr_star(ngrid,klev) + REAL coefc + REAL detr_stara(ngrid,klev) + REAL detr_starb(ngrid,klev) + REAL detr_starc(ngrid,klev) + REAL detr_star0(ngrid,klev) + REAL detr_star1(ngrid,klev) + REAL detr_star2(ngrid,klev) + + REAL entr_star(ngrid,klev) + REAL entr_star1(ngrid,klev) + REAL entr_star2(ngrid,klev) + REAL detr(ngrid,klev) + REAL entr(ngrid,klev) + + REAL zw2(ngrid,klev+1) + REAL w_est(ngrid,klev+1) + REAL f_star(ngrid,klev+1) + REAL wa_moy(ngrid,klev+1) + + REAL ztva_est(ngrid,klev) + REAL zqla_est(ngrid,klev) + REAL zqsatth(ngrid,klev) + REAL zta_est(ngrid,klev) + + REAL linter(ngrid) + INTEGER lmix(ngrid) + INTEGER lmix_bis(ngrid) + REAL wmaxa(ngrid) + + INTEGER ig,l,k + + real zcor,zdelta,zcvm5,qlbef + real Tbef,qsatbef + real dqsat_dT,DT,num,denom + REAL REPS,RLvCp,DDT0 + PARAMETER (DDT0=.01) + logical Zsat + REAL fact_gamma,fact_epsilon + REAL c2(ngrid,klev) + + Zsat=.false. +! Initialisation + RLvCp = RLVTT/RCPD + + if (iflag_thermals_ed==0) then + fact_gamma=1. + fact_epsilon=1. + else if (iflag_thermals_ed==1) then + fact_gamma=1. + fact_epsilon=1. + else if (iflag_thermals_ed==2) then + fact_gamma=1. + fact_epsilon=2. + endif + + do l=1,klev + do ig=1,ngrid + zqla_est(ig,l)=0. + ztva_est(ig,l)=ztva(ig,l) + zqsatth(ig,l)=0. + enddo + enddo + +!CR: attention test couche alim +! do l=2,klev +! do ig=1,ngrid +! alim_star(ig,l)=0. +! enddo +! enddo +!AM:initialisations du thermique + do k=1,klev + do ig=1,ngrid + ztva(ig,k)=ztv(ig,k) + ztla(ig,k)=zthl(ig,k) + zqla(ig,k)=0. + zqta(ig,k)=po(ig,k) +! + ztva(ig,k) = ztla(ig,k)*zpspsk(ig,k)+RLvCp*zqla(ig,k) + ztva(ig,k) = ztva(ig,k)/zpspsk(ig,k) + zha(ig,k) = ztva(ig,k) +! + enddo + enddo + do k=1,klev + do ig=1,ngrid + detr_star(ig,k)=0. + entr_star(ig,k)=0. + + detr_stara(ig,k)=0. + detr_starb(ig,k)=0. + detr_starc(ig,k)=0. + detr_star0(ig,k)=0. + zqla0(ig,k)=0. + detr_star1(ig,k)=0. + detr_star2(ig,k)=0. + entr_star1(ig,k)=0. + entr_star2(ig,k)=0. + + detr(ig,k)=0. + entr(ig,k)=0. + enddo + enddo + if (prt_level.ge.1) print*,'7 OK convect8' + do k=1,klev+1 + do ig=1,ngrid + zw2(ig,k)=0. + w_est(ig,k)=0. + f_star(ig,k)=0. + wa_moy(ig,k)=0. + enddo + enddo + + if (prt_level.ge.1) print*,'8 OK convect8' + do ig=1,ngrid + linter(ig)=1. + lmix(ig)=1 + lmix_bis(ig)=2 + wmaxa(ig)=0. + enddo + +!----------------------------------------------------------------------------------- +!boucle de calcul de la vitesse verticale dans le thermique +!----------------------------------------------------------------------------------- + do l=1,klev-1 + do ig=1,ngrid + + + +! Calcul dans la premiere couche active du thermique (ce qu'on teste +! en disant que la couche est instable et que w2 en bas de la couche +! est nulle. + + if (ztv(ig,l).gt.ztv(ig,l+1) & + & .and.alim_star(ig,l).gt.1.e-10 & + & .and.zw2(ig,l).lt.1e-10) then + + +! Le panache va prendre au debut les caracteristiques de l'air contenu +! dans cette couche. + ztla(ig,l)=zthl(ig,l) + zqta(ig,l)=po(ig,l) + zqla(ig,l)=zl(ig,l) + f_star(ig,l+1)=alim_star(ig,l) + + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) & + & *(zlev(ig,l+1)-zlev(ig,l)) & + & *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + w_est(ig,l+1)=zw2(ig,l+1) +! + + + else if ((zw2(ig,l).ge.1e-10).and. & + & (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then +!estimation du detrainement a partir de la geometrie du pas precedent +!tests sur la definition du detr +!calcul de detr_star et entr_star + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH le test miraculeux de Catherine ? Le bout du tunel ? +! w_est(ig,3)=zw2(ig,2)* & +! & ((f_star(ig,2))**2) & +! & /(f_star(ig,2)+alim_star(ig,2))**2+ & +! & 2.*RG*(ztva(ig,1)-ztv(ig,2))/ztv(ig,2) & +! & *(zlev(ig,3)-zlev(ig,2)) +! if (l.gt.2) then +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + +! Premier calcul de la vitesse verticale a partir de la temperature +! potentielle virtuelle + +! FH CESTQUOI CA ???? +#define int1d2 +!#undef int1d2 +#ifdef int1d2 + if (l.ge.2) then +#else + if (l.gt.2) then +#endif + + if (1.eq.1) then + w_est(ig,3)=zw2(ig,2)* & + & ((f_star(ig,2))**2) & + & /(f_star(ig,2)+alim_star(ig,2))**2+ & + & 2.*RG*(ztva(ig,2)-ztv(ig,2))/ztv(ig,2) & +! & *1./3. & + & *(zlev(ig,3)-zlev(ig,2)) + endif + + +!--------------------------------------------------------------------------- +!calcul de l entrainement et du detrainement lateral +!--------------------------------------------------------------------------- +! +!test:estimation de ztva_new_est sans entrainement + + Tbef=ztla(ig,l-1)*zpspsk(ig,l) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l) + qsatbef=MIN(0.5,qsatbef) + zcor=1./(1.-retv*qsatbef) + qsatbef=qsatbef*zcor + Zsat = (max(0.,zqta(ig,l-1)-qsatbef) .gt. 1.e-10) + if (Zsat) then + qlbef=max(0.,zqta(ig,l-1)-qsatbef) + DT = 0.5*RLvCp*qlbef + do while (abs(DT).gt.DDT0) + Tbef=Tbef+DT + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l) + qsatbef=MIN(0.5,qsatbef) + zcor=1./(1.-retv*qsatbef) + qsatbef=qsatbef*zcor + qlbef=zqta(ig,l-1)-qsatbef + + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta + zcor=1./(1.-retv*qsatbef) + dqsat_dT=FOEDE(Tbef,zdelta,zcvm5,qsatbef,zcor) + num=-Tbef+ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*qlbef + denom=1.+RLvCp*dqsat_dT + DT=num/denom + enddo + zqla_est(ig,l) = max(0.,zqta(ig,l-1)-qsatbef) + endif + ztva_est(ig,l) = ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*zqla_est(ig,l) + ztva_est(ig,l) = ztva_est(ig,l)/zpspsk(ig,l) + zta_est(ig,l)=ztva_est(ig,l) + ztva_est(ig,l) = ztva_est(ig,l)*(1.+RETV*(zqta(ig,l-1) & + & -zqla_est(ig,l))-zqla_est(ig,l)) + + w_est(ig,l+1)=zw2(ig,l)* & + & ((f_star(ig,l))**2) & + & /(f_star(ig,l)+alim_star(ig,l))**2+ & + & 2.*RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) & +! & *1./3. & + & *(zlev(ig,l+1)-zlev(ig,l)) + if (w_est(ig,l+1).lt.0.) then + w_est(ig,l+1)=zw2(ig,l) + endif +! +!calcul du detrainement +!======================= + +!CR:on vire les modifs + if (iflag_thermals_ed==0) then + +! Modifications du calcul du detrainement. +! Dans la version de la these de Catherine, on passe brusquement +! de la version seche a la version nuageuse pour le detrainement +! ce qui peut occasioner des oscillations. +! dans la nouvelle version, on commence par calculer un detrainement sec. +! Puis un autre en cas de nuages. +! Puis on combine les deux lineairement en fonction de la quantite d'eau. + +#define int1d3 +!#undef int1d3 +#define RIO_TH +#ifdef RIO_TH +!1. Cas non nuageux +! 1.1 on est sous le zmax_sec et w croit + if ((w_est(ig,l+1).gt.w_est(ig,l)).and. & + & (zlev(ig,l+1).lt.zmax_sec(ig)).and. & +#ifdef int1d3 + & (zqla_est(ig,l).lt.1.e-10)) then +#else + & (zqla(ig,l-1).lt.1.e-10)) then +#endif + detr_star(ig,l)=MAX(0.,(rhobarz(ig,l+1) & + & *sqrt(w_est(ig,l+1))*sqrt(l_mix*zlev(ig,l+1)) & + & -rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(l_mix*zlev(ig,l))) & + & /(r_aspect*zmax_sec(ig))) + detr_stara(ig,l)=detr_star(ig,l) + + if (prt_level.ge.20) print*,'coucou calcul detr 1: ig, l',ig,l + +! 1.2 on est sous le zmax_sec et w decroit + else if ((zlev(ig,l+1).lt.zmax_sec(ig)).and. & +#ifdef int1d3 + & (zqla_est(ig,l).lt.1.e-10)) then +#else + & (zqla(ig,l-1).lt.1.e-10)) then +#endif + detr_star(ig,l)=-f0(ig)*f_star(ig,lmix(ig)) & + & /(rhobarz(ig,lmix(ig))*wmaxa(ig))* & + & (rhobarz(ig,l+1)*sqrt(w_est(ig,l+1)) & + & *((zmax_sec(ig)-zlev(ig,l+1))/ & + & ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2. & + & -rhobarz(ig,l)*sqrt(w_est(ig,l)) & + & *((zmax_sec(ig)-zlev(ig,l))/ & + & ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.) + detr_starb(ig,l)=detr_star(ig,l) + + if (prt_level.ge.20) print*,'coucou calcul detr 2: ig, l',ig,l + + else + +! 1.3 dans les autres cas + detr_star(ig,l)=0.002*f0(ig)*f_star(ig,l) & + & *(zlev(ig,l+1)-zlev(ig,l)) + detr_starc(ig,l)=detr_star(ig,l) + + if (prt_level.ge.20) print*,'coucou calcul detr 3 n: ig, l',ig, l + + endif + +#else + +! 1.1 on est sous le zmax_sec et w croit + if ((w_est(ig,l+1).gt.w_est(ig,l)).and. & + & (zlev(ig,l+1).lt.zmax_sec(ig)) ) then + detr_star(ig,l)=MAX(0.,(rhobarz(ig,l+1) & + & *sqrt(w_est(ig,l+1))*sqrt(l_mix*zlev(ig,l+1)) & + & -rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(l_mix*zlev(ig,l))) & + & /(r_aspect*zmax_sec(ig))) + + if (prt_level.ge.20) print*,'coucou calcul detr 1: ig, l', ig, l + +! 1.2 on est sous le zmax_sec et w decroit + else if ((zlev(ig,l+1).lt.zmax_sec(ig)) ) then + detr_star(ig,l)=-f0(ig)*f_star(ig,lmix(ig)) & + & /(rhobarz(ig,lmix(ig))*wmaxa(ig))* & + & (rhobarz(ig,l+1)*sqrt(w_est(ig,l+1)) & + & *((zmax_sec(ig)-zlev(ig,l+1))/ & + & ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2. & + & -rhobarz(ig,l)*sqrt(w_est(ig,l)) & + & *((zmax_sec(ig)-zlev(ig,l))/ & + & ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.) + if (prt_level.ge.20) print*,'coucou calcul detr 1: ig, l', ig, l + + else + detr_star=0. + endif + +! 1.3 dans les autres cas + detr_starc(ig,l)=0.002*f0(ig)*f_star(ig,l) & + & *(zlev(ig,l+1)-zlev(ig,l)) + + coefc=min(zqla(ig,l-1)/1.e-3,1.) + if (zlev(ig,l+1).ge.zmax_sec(ig)) coefc=1. + coefc=1. +! il semble qu'il soit important de baser le calcul sur +! zqla_est(ig,l-1) plutot que sur zqla_est(ig,l) + detr_star(ig,l)=detr_starc(ig,l)*coefc+detr_star(ig,l)*(1.-coefc) + + if (prt_level.ge.20) print*,'coucou calcul detr 2: ig, l', ig, l + +#endif + + + if (prt_level.ge.20) print*,'coucou calcul detr 444: ig, l', ig, l +!IM 730508 beg +! if(itap.GE.7200) THEN +! print*,'th_plume ig,l,itap,zqla_est=',ig,l,itap,zqla_est(ig,l) +! endif +!IM 730508 end + + zqla0(ig,l)=zqla_est(ig,l) + detr_star0(ig,l)=detr_star(ig,l) +!IM 060508 beg +! if(detr_star(ig,l).GT.1.) THEN +! print*,'th_plumeBEF ig l detr_star detr_starc coefc',ig,l,detr_star(ig,l) & +! & ,detr_starc(ig,l),coefc +! endif +!IM 060508 end +!IM 160508 beg +!IM 160508 IF (f0(ig).NE.0.) THEN + detr_star(ig,l)=detr_star(ig,l)/f0(ig) +!IM 160508 ELSE IF(detr_star(ig,l).EQ.0.) THEN +!IM 160508 print*,'WARNING1 : th_plume f0=0, detr_star=0: ig, l, itap',ig,l,itap +!IM 160508 ELSE +!IM 160508 print*,'WARNING2 : th_plume f0=0, ig, l, itap, detr_star',ig,l,itap,detr_star(ig,l) +!IM 160508 ENDIF +!IM 160508 end +!IM 060508 beg +! if(detr_star(ig,l).GT.1.) THEN +! print*,'th_plumeAFT ig l detr_star f0 1/f0',ig,l,detr_star(ig,l),f0(ig), & +! & float(1)/f0(ig) +! endif +!IM 060508 end + if (prt_level.ge.20) print*,'coucou calcul detr 445: ig, l', ig, l +! +!calcul de entr_star + +! #undef test2 +! #ifdef test2 +! La version test2 destabilise beaucoup le modele. +! Il semble donc que ca aide d'avoir un entrainement important sous +! le nuage. +! if (zqla_est(ig,l-1).ge.1.e-10.and.l.gt.lalim(ig)) then +! entr_star(ig,l)=0.4*detr_star(ig,l) +! else +! entr_star(ig,l)=0. +! endif +! #else +! +! Deplacement du calcul de entr_star pour eviter d'avoir aussi +! entr_star > fstar. +! Redeplacer suite a la transformation du cas detr>f +! FH + + if (prt_level.ge.20) print*,'coucou calcul detr 446: ig, l', ig, l +#define int1d +!FH 070508 #define int1d4 +!#undef int1d4 +! L'option int1d4 correspond au choix dans le cas ou le detrainement +! devient trop grand. + +#ifdef int1d + +#ifdef int1d4 +#else + detr_star(ig,l)=min(detr_star(ig,l),f_star(ig,l)) +!FH 070508 plus + detr_star(ig,l)=min(detr_star(ig,l),1.) +#endif + + entr_star(ig,l)=max(0.4*detr_star(ig,l)-alim_star(ig,l),0.) + + if (prt_level.ge.20) print*,'coucou calcul detr 447: ig, l', ig, l +#ifdef int1d4 +! Si le detrainement excede le flux en bas + l'entrainement, le thermique +! doit disparaitre. + if (detr_star(ig,l)>f_star(ig,l)+entr_star(ig,l)) then + detr_star(ig,l)=f_star(ig,l)+entr_star(ig,l) + f_star(ig,l+1)=0. + linter(ig)=l+1 + zw2(ig,l+1)=-1.e-10 + endif +#endif + + +#else + + if (prt_level.ge.20) print*,'coucou calcul detr 448: ig, l', ig, l + if(l.gt.lalim(ig)) then + entr_star(ig,l)=0.4*detr_star(ig,l) + else + +! FH : +! Cette ligne doit permettre de garantir qu'on a toujours un flux = 1 +! en haut de la couche d'alimentation. +! A remettre en questoin a la premiere occasion mais ca peut aider a +! ecrire un code robuste. +! Que ce soit avec ca ou avec l'ancienne facon de faire (e* = 0 mais +! d* non nul) on a une discontinuité de e* ou d* en haut de la couche +! d'alimentation, ce qui n'est pas forcement heureux. + + if (prt_level.ge.20) print*,'coucou calcul detr 449: ig, l', ig, l +#undef pre_int1c +#ifdef pre_int1c + entr_star(ig,l)=max(detr_star(ig,l)-alim_star(ig,l),0.) + detr_star(ig,l)=entr_star(ig,l) +#else + entr_star(ig,l)=0. +#endif + + endif + +#endif + + if (prt_level.ge.20) print*,'coucou calcul detr 440: ig, l', ig, l + entr_star1(ig,l)=entr_star(ig,l) + detr_star1(ig,l)=detr_star(ig,l) +! + +#ifdef int1d +#else + if (detr_star(ig,l).gt.f_star(ig,l)) then + +! Ce test est là entre autres parce qu'on passe par des valeurs +! delirantes de detr_star. +! ca vaut sans doute le coup de verifier pourquoi. + + detr_star(ig,l)=f_star(ig,l) +#ifdef pre_int1c + if (l.gt.lalim(ig)+1) then + entr_star(ig,l)=0. + alim_star(ig,l)=0. +! FH ajout pour forcer a stoper le thermique juste sous le sommet +! de la couche (voir calcul de finter) + zw2(ig,l+1)=-1.e-10 + linter(ig)=l+1 + else + entr_star(ig,l)=0.4*detr_star(ig,l) + endif +#else + entr_star(ig,l)=0.4*detr_star(ig,l) +#endif + endif +#endif + + else !l > 2 + detr_star(ig,l)=0. + entr_star(ig,l)=0. + endif + + entr_star2(ig,l)=entr_star(ig,l) + detr_star2(ig,l)=detr_star(ig,l) + if (prt_level.ge.20) print*,'coucou calcul detr 450: ig, l', ig, l + + endif ! iflag_thermals_ed==0 + +!CR:nvlle def de entr_star et detr_star + if (iflag_thermals_ed>=1) then +! if (l.lt.lalim(ig)) then +! if (l.lt.2) then +! entr_star(ig,l)=0. +! detr_star(ig,l)=0. +! else +! if (0.001.gt.(RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l))/(2.*w_est(ig,l+1)))) then +! entr_star(ig,l)=0.001*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) +! else +! entr_star(ig,l)= & +! & f_star(ig,l)/(2.*w_est(ig,l+1)) & +! & *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)) & +! & *(zlev(ig,l+1)-zlev(ig,l)) + + + entr_star(ig,l)=MAX(0.*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)), & + & f_star(ig,l)/(2.*w_est(ig,l+1)) & + & *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) & + & *(zlev(ig,l+1)-zlev(ig,l))) & + & +0.0001*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + + if (((ztva_est(ig,l)-ztv(ig,l)).gt.1.e-10).and.(l.le.lmix_bis(ig))) then + alim_star_tot(ig)=alim_star_tot(ig)+entr_star(ig,l) + lalim(ig)=lmix_bis(ig) + if(prt_level.GE.10) print*,'alim_star_tot',alim_star_tot(ig),entr_star(ig,l) + endif + + if (((ztva_est(ig,l)-ztv(ig,l)).gt.1.e-10).and.(l.le.lmix_bis(ig))) then +! c2(ig,l)=2500000.*zqla_est(ig,l)/(1004.*zta_est(ig,l)) + c2(ig,l)=0.001 + detr_star(ig,l)=MAX(0.*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)), & + & c2(ig,l)*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) & + & -f_star(ig,l)/(2.*w_est(ig,l+1)) & + & *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) & + & *(zlev(ig,l+1)-zlev(ig,l))) & + & +0.0001*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + + else +! c2(ig,l)=2500000.*zqla_est(ig,l)/(1004.*zta_est(ig,l)) + c2(ig,l)=0.003 + + detr_star(ig,l)=MAX(0.*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)), & + & c2(ig,l)*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) & + & -f_star(ig,l)/(2.*w_est(ig,l+1)) & + & *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) & + & *(zlev(ig,l+1)-zlev(ig,l))) & + & +0.0002*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + endif + + +! detr_star(ig,l)=detr_star(ig,l)*3. +! if (l.lt.lalim(ig)) then +! entr_star(ig,l)=0. +! endif +! if (l.lt.2) then +! entr_star(ig,l)=0. +! detr_star(ig,l)=0. +! endif + + +! endif +! else if ((ztva_est(ig,l)-ztv(ig,l)).gt.1.e-10) then +! entr_star(ig,l)=MAX(0.,0.8*f_star(ig,l)/(2.*w_est(ig,l+1)) & +! & *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)) & +! & *(zlev(ig,l+1)-zlev(ig,l)) +! detr_star(ig,l)=0.002*f_star(ig,l) & +! & *(zlev(ig,l+1)-zlev(ig,l)) +! else +! entr_star(ig,l)=0.001*f_star(ig,l) & +! & *(zlev(ig,l+1)-zlev(ig,l)) +! detr_star(ig,l)=MAX(0.,-0.2*f_star(ig,l)/(2.*w_est(ig,l+1)) & +! & *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)) & +! & *(zlev(ig,l+1)-zlev(ig,l)) & +! & +0.002*f_star(ig,l) & +! & *(zlev(ig,l+1)-zlev(ig,l)) +! endif + + endif ! iflag_thermals_ed==1 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH inutile si on conserve comme on l'a fait plus haut entr=detr +! dans la couche d'alimentation +!pas d entrainement dans la couche alim +! if ((l.le.lalim(ig))) then +! entr_star(ig,l)=0. +! endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!prise en compte du detrainement et de l entrainement dans le calcul du flux + + f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l) & + & -detr_star(ig,l) + +!test sur le signe de f_star + if (prt_level.ge.20) print*,'coucou calcul detr 451: ig, l', ig, l + if (f_star(ig,l+1).gt.1.e-10) then +!---------------------------------------------------------------------------- +!calcul de la vitesse verticale en melangeant Tl et qt du thermique +!--------------------------------------------------------------------------- +! + Zsat=.false. + ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+ & + & (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l)) & + & /(f_star(ig,l+1)+detr_star(ig,l)) +! + zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+ & + & (alim_star(ig,l)+entr_star(ig,l))*po(ig,l)) & + & /(f_star(ig,l+1)+detr_star(ig,l)) +! + Tbef=ztla(ig,l)*zpspsk(ig,l) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l) + qsatbef=MIN(0.5,qsatbef) + zcor=1./(1.-retv*qsatbef) + qsatbef=qsatbef*zcor + Zsat = (max(0.,zqta(ig,l)-qsatbef) .gt. 1.e-10) + if (Zsat) then + qlbef=max(0.,zqta(ig,l)-qsatbef) + DT = 0.5*RLvCp*qlbef + do while (abs(DT).gt.DDT0) + Tbef=Tbef+DT + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l) + qsatbef=MIN(0.5,qsatbef) + zcor=1./(1.-retv*qsatbef) + qsatbef=qsatbef*zcor + qlbef=zqta(ig,l)-qsatbef + + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta + zcor=1./(1.-retv*qsatbef) + dqsat_dT=FOEDE(Tbef,zdelta,zcvm5,qsatbef,zcor) + num=-Tbef+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef + denom=1.+RLvCp*dqsat_dT + DT=num/denom + enddo + zqla(ig,l) = max(0.,qlbef) + endif +! + if (prt_level.ge.20) print*,'coucou calcul detr 4512: ig, l', ig, l +! on ecrit de maniere conservative (sat ou non) +! T = Tl +Lv/Cp ql + ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) + ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) +!on rajoute le calcul de zha pour diagnostiques (temp potentielle) + zha(ig,l) = ztva(ig,l) + ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) & + & -zqla(ig,l))-zqla(ig,l)) + +!on ecrit zqsat + zqsatth(ig,l)=qsatbef +!calcul de vitesse + zw2(ig,l+1)=zw2(ig,l)* & + & ((f_star(ig,l))**2) & +! Tests de Catherine +! & /(f_star(ig,l+1)+detr_star(ig,l))**2+ & + & /(f_star(ig,l+1)+detr_star(ig,l)-entr_star(ig,l)*(1.-fact_epsilon))**2+ & + & 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) & + & *fact_gamma & + & *(zlev(ig,l+1)-zlev(ig,l)) +!prise en compte des forces de pression que qd flottabilité<0 +! zw2(ig,l+1)=zw2(ig,l)* & +! & 1./(1.+2.*entr_star(ig,l)/f_star(ig,l)) + & +! & (f_star(ig,l))**2 & +! & /(f_star(ig,l)+entr_star(ig,l))**2+ & +! & (f_star(ig,l)-2.*entr_star(ig,l))**2/(f_star(ig,l)+2.*entr_star(ig,l))**2+ & +! & /(f_star(ig,l+1)+detr_star(ig,l)-entr_star(ig,l)*(1.-2.))**2+ & +! & /(f_star(ig,l)**2+2.*2.*detr_star(ig,l)*f_star(ig,l)+2.*entr_star(ig,l)*f_star(ig,l))+ & +! & 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) & +! & *1./3. & +! & *(zlev(ig,l+1)-zlev(ig,l)) + +! write(30,*),l+1,zw2(ig,l+1)-zw2(ig,l), & +! & -2.*entr_star(ig,l)/f_star(ig,l)*zw2(ig,l), & +! & 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + + +! zw2(ig,l+1)=zw2(ig,l)* & +! & (2.-2.*entr_star(ig,l)/f_star(ig,l)) & +! & -zw2(ig,l-1)+ & +! & 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) & +! & *1./3. & +! & *(zlev(ig,l+1)-zlev(ig,l)) + + endif + endif + if (prt_level.ge.20) print*,'coucou calcul detr 460: ig, l',ig, l +! +!initialisations pour le calcul de la hauteur du thermique, de l'inversion et de la vitesse verticale max + + if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then +! stop'On tombe sur le cas particulier de thermcell_dry' + print*,'On tombe sur le cas particulier de thermcell_plume' + zw2(ig,l+1)=0. + linter(ig)=l+1 + endif + +! if ((zw2(ig,l).gt.0.).and. (zw2(ig,l+1).le.0.)) then + if (zw2(ig,l+1).lt.0.) then + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) & + & -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. + endif + + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +! lmix est le niveau de la couche ou w (wa_moy) est maximum +!on rajoute le calcul de lmix_bis + if (zqla(ig,l).lt.1.e-10) then + lmix_bis(ig)=l+1 + endif + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo + +!on remplace a* par e* ds premiere couche +! if (iflag_thermals_ed.ge.1) then +! do ig=1,ngrid +! do l=2,klev +! if (l.lt.lalim(ig)) then +! alim_star(ig,l)=entr_star(ig,l) +! endif +! enddo +! enddo +! do ig=1,ngrid +! lalim(ig)=lmix_bis(ig) +! enddo +! endif + if (iflag_thermals_ed.ge.1) then + do ig=1,ngrid + do l=2,lalim(ig) + alim_star(ig,l)=entr_star(ig,l) + entr_star(ig,l)=0. + enddo + enddo + endif + if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l + +! print*,'thermcell_plume OK' + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/tilft43.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/tilft43.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/tilft43.F (revision 1280) @@ -0,0 +1,95 @@ +! +! $Header$ +! + SUBROUTINE TLIFT43(P,T,Q,QS,GZ,ICB,NK,TVP,TPK,CLW,ND,NL,KK) + REAL GZ(ND),TPK(ND),CLW(ND),P(ND) + REAL T(ND),Q(ND),QS(ND),TVP(ND),LV0 +C +C *** ASSIGN VALUES OF THERMODYNAMIC CONSTANTS *** +C +c -- sb: +c! CPD=1005.7 +c! CPV=1870.0 +c! CL=4190.0 +c! RV=461.5 +c! RD=287.04 +c! LV0=2.501E6 +c! G=9.8 +c! ROWL=1000.0 +c ajouts: +#include "YOMCST.h" + CPD = RCPD + CPV = RCPV + CL = RCW + LV0 = RLVTT + G = RG + ROWL= RATM/100. + GRAVITY = RG !sb: Pr que gravite ne devienne pas humidite! +C sb -- +C + CPVMCL=CL-CPV + EPS=RD/RV + EPSI=1./EPS +C +C *** CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY *** +C + AH0=(CPD*(1.-Q(NK))+CL*Q(NK))*T(NK)+Q(NK)*(LV0-CPVMCL*( + 1 T(NK)-273.15))+GZ(NK) + CPP=CPD*(1.-Q(NK))+Q(NK)*CPV + CPINV=1./CPP +C + IF(KK.EQ.1)THEN +C +C *** CALCULATE LIFTED PARCEL QUANTITIES BELOW CLOUD BASE *** +C + DO 50 I=1,ICB-1 + CLW(I)=0.0 + 50 CONTINUE + DO 100 I=NK,ICB-1 + TPK(I)=T(NK)-(GZ(I)-GZ(NK))*CPINV + TVP(I)=TPK(I)*(1.+Q(NK)*EPSI) + 100 CONTINUE + END IF +C +C *** FIND LIFTED PARCEL QUANTITIES ABOVE CLOUD BASE *** +C + NST=ICB + NSB=ICB + IF(KK.EQ.2)THEN + NST=NL + NSB=ICB+1 + END IF + DO 300 I=NSB,NST + TG=T(I) + QG=QS(I) + ALV=LV0-CPVMCL*(T(I)-273.15) + DO 200 J=1,2 + S=CPD+ALV*ALV*QG/(RV*T(I)*T(I)) + S=1./S + AHG=CPD*TG+(CL-CPD)*Q(NK)*T(I)+ALV*QG+GZ(I) + TG=TG+S*(AH0-AHG) + TG=MAX(TG,35.0) + TC=TG-273.15 + DENOM=243.5+TC + IF(TC.GE.0.0)THEN + ES=6.112*EXP(17.67*TC/DENOM) + ELSE + ES=EXP(23.33086-6111.72784/TG+0.15215*LOG(TG)) + END IF + QG=EPS*ES/(P(I)-ES*(1.-EPS)) + 200 CONTINUE + ALV=LV0-CPVMCL*(T(I)-273.15) + TPK(I)=(AH0-(CL-CPD)*Q(NK)*T(I)-GZ(I)-ALV*QG)/CPD + CLW(I)=Q(NK)-QG + CLW(I)=MAX(0.0,CLW(I)) + RG=QG/(1.-Q(NK)) + TVP(I)=TPK(I)*(1.+RG*EPSI) + 300 CONTINUE + +c -- sb: + RG = GRAVITY ! RG redevient la gravite de YOMCST (sb) +c sb -- + + RETURN + END + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/tlift.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/tlift.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/tlift.F (revision 1280) @@ -0,0 +1,245 @@ +! +! $Header$ +! + SUBROUTINE TLIFT(P,T,RR,RS,GZ,PLCL,ICB,NK, + . TVP,TPK,CLW,ND,NL, + . DTVPDT1,DTVPDQ1) +C +C Argument NK ajoute (jyg) = Niveau de depart de la +C convection +C + PARAMETER (NA=60) + REAL GZ(ND),TPK(ND),CLW(ND) + REAL T(ND),RR(ND),RS(ND),TVP(ND),P(ND) + REAL DTVPDT1(ND),DTVPDQ1(ND) ! Derivatives of parcel virtual +C temperature wrt T1 and Q1 +C + REAL CLW_NEW(NA),QI(NA) + REAL DTPDT1(NA),DTPDQ1(NA) ! Derivatives of parcel temperature +C wrt T1 and Q1 + +C + LOGICAL ICE_CONV +C +C *** ASSIGN VALUES OF THERMODYNAMIC CONSTANTS *** +C +c sb CPD=1005.7 +c sb CPV=1870.0 +c sb CL=4190.0 +c sb CPVMCL=2320.0 +c sb RV=461.5 +c sb RD=287.04 +c sb EPS=RD/RV +c sb ALV0=2.501E6 +ccccccccccccccccccccccc +c constantes coherentes avec le modele du Centre Europeen +c sb RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644 +c sb RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153 +c sb CPD = 3.5 * RD +c sb CPV = 4.0 * RV +c sb CL = 4218.0 +c sb CI=2090.0 +c sb CPVMCL=CL-CPV +c sb CLMCI=CL-CI +c sb EPS=RD/RV +c sb ALV0=2.5008E+06 +c sb ALF0=3.34E+05 + +cccccccccccc +c on utilise les constantes thermo du Centre Europeen: (SB) +c +#include "YOMCST.h" + GRAVITY = RG !sb: Pr que gravite ne devienne pas humidite! +c + CPD = RCPD + CPV = RCPV + CL = RCW + CI = RCS + CPVMCL = CL-CPV + CLMCI = CL-CI + EPS = RD/RV + ALV0 = RLVTT + ALF0 = RLMLT ! (ALF0 = RLSTT-RLVTT) +c +cccccccccccccccccccccc +C +C *** CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY *** +C + ICB1=MAX(ICB,2) + ICB1=MIN(ICB,NL) +C +Cjyg1 +CC CPP=CPD*(1.-RR(1))+RR(1)*CPV + CPP=CPD*(1.-RR(NK))+RR(NK)*CPV +Cjyg2 + CPINV=1./CPP +Cjyg1 +C ICB may be below condensation level +CCC DO 100 I=1,ICB1-1 +CCC TPK(I)=T(1)-GZ(I)*CPINV +CCC TVP(I)=TPK(I)*(1.+RR(1)/EPS) + DO 50 I=1,ICB1 + CLW(I)=0.0 +50 CONTINUE +C + DO 100 I=NK,ICB1 + TPK(I)=T(NK)-(GZ(I) - GZ(NK))*CPINV +Cjyg1 +CCC TVP(I)=TPK(I)*(1.+RR(NK)/EPS) + TVP(I)=TPK(I)*(1.+RR(NK)/EPS-RR(NK)) +Cjyg2 + DTVPDT1(I) = 1.+RR(NK)/EPS-RR(NK) + DTVPDQ1(I) = TPK(I)*(1./EPS-1.) +C +Cjyg2 + + 100 CONTINUE + +C +C *** FIND LIFTED PARCEL TEMPERATURE AND MIXING RATIO *** +C +Cjyg1 +CC AH0=(CPD*(1.-RR(1))+CL*RR(1))*T(1) +CC $ +RR(1)*(ALV0-CPVMCL*(T(1)-273.15)) + AH0=(CPD*(1.-RR(NK))+CL*RR(NK))*T(NK) + $ +RR(NK)*(ALV0-CPVMCL*(T(NK)-273.15)) + GZ(NK) +Cjyg2 +C +Cjyg1 + IMIN = ICB1 +C If ICB is below LCL, start loop at ICB+1 + IF (PLCL .LT. P(ICB1)) IMIN = MIN(IMIN+1,NL) +C +CCC DO 300 I=ICB1,NL + DO 300 I=IMIN,NL +Cjyg2 + ALV=ALV0-CPVMCL*(T(I)-273.15) + ALF=ALF0+CLMCI*(T(I)-273.15) + + RG=RS(I) + TG=T(I) +C S=CPD+ALV*ALV*RG/(RV*T(I)*T(I)) +Cjyg1 +CC S=CPD*(1.-RR(1))+CL*RR(1)+ALV*ALV*RG/(RV*T(I)*T(I)) + S=CPD*(1.-RR(NK))+CL*RR(NK)+ALV*ALV*RG/(RV*T(I)*T(I)) +Cjyg2 + S=1./S + + DO 200 J=1,2 +Cjyg1 +CC AHG=CPD*TG+(CL-CPD)*RR(1)*TG+ALV*RG+GZ(I) + AHG=CPD*TG+(CL-CPD)*RR(NK)*TG+ALV*RG+GZ(I) +Cjyg2 + TG=TG+S*(AH0-AHG) + TC=TG-273.15 + DENOM=243.5+TC + DENOM=MAX(DENOM,1.0) +C +C FORMULE DE BOLTON POUR PSAT +C + ES=6.112*EXP(17.67*TC/DENOM) + RG=EPS*ES/(P(I)-ES*(1.-EPS)) + + + 200 CONTINUE + +Cjyg1 +CC TPK(I)=(AH0-GZ(I)-ALV*RG)/(CPD+(CL-CPD)*RR(1)) + TPK(I)=(AH0-GZ(I)-ALV*RG)/(CPD+(CL-CPD)*RR(NK)) +Cjyg2 +C TPK(I)=(AH0-GZ(I)-ALV*RG-(CL-CPD)*T(I)*RR(1))/CPD + +Cjyg1 +CC CLW(I)=RR(1)-RG + CLW(I)=RR(NK)-RG +Cjyg2 + CLW(I)=MAX(0.0,CLW(I)) +Cjyg1 +CCC TVP(I)=TPK(I)*(1.+RG/EPS) + TVP(I)=TPK(I)*(1.+RG/EPS-RR(NK)) +Cjyg2 +C +Cjyg1 Derivatives +C + DTPDT1(I) = CPD*S + DTPDQ1(I) = ALV*S +C + DTVPDT1(I) = DTPDT1(I)*(1. + RG/EPS - + . RR(NK) + ALV*RG/(RD*TPK(I)) ) + DTVPDQ1(I) = DTPDQ1(I)*(1. + RG/EPS - + . RR(NK) + ALV*RG/(RD*TPK(I)) ) - TPK(I) +C +Cjyg2 + + 300 CONTINUE +C + ICE_CONV = .FALSE. + + IF (ICE_CONV) THEN +C +CJAM +C RAJOUT DE LA PROCEDURE ICEFRAC +C +c sb CALL ICEFRAC(T,CLW,CLW_NEW,QI,ND,NL) + + DO 400 I=ICB1,NL + IF (T(I).LT.263.15) THEN + TG=TPK(I) + TC=TPK(I)-273.15 + DENOM=243.5+TC + ES=6.112*EXP(17.67*TC/DENOM) + ALV=ALV0-CPVMCL*(T(I)-273.15) + ALF=ALF0+CLMCI*(T(I)-273.15) + + DO J=1,4 + ESI=EXP(23.33086-(6111.72784/TPK(I))+0.15215*LOG(TPK(I))) + QSAT_NEW=EPS*ESI/(P(I)-ESI*(1.-EPS)) +CCC SNEW= CPD*(1.-RR(1))+CL*RR(1)+ALV*ALV*QSAT_NEW/(RV*TPK(I)*TPK(I)) + SNEW= CPD*(1.-RR(NK))+CL*RR(NK) + . +ALV*ALV*QSAT_NEW/(RV*TPK(I)*TPK(I)) +C + SNEW=1./SNEW + TPK(I)=TG+(ALF*QI(I)+ALV*RG*(1.-(ESI/ES)))*SNEW +c@$$ PRINT*,'################################' +c@$$ PRINT*,TPK(I) +c@$$ PRINT*,(ALF*QI(I)+ALV*RG*(1.-(ESI/ES)))*SNEW + ENDDO +CCC CLW(I)=RR(1)-QSAT_NEW + CLW(I)=RR(NK)-QSAT_NEW + CLW(I)=MAX(0.0,CLW(I)) +Cjyg1 +CCC TVP(I)=TPK(I)*(1.+QSAT_NEW/EPS) + TVP(I)=TPK(I)*(1.+QSAT_NEW/EPS-RR(NK)) +Cjyg2 + ELSE + CONTINUE + ENDIF + + 400 CONTINUE +C + ENDIF +C + +****************************************************** +** BK : RAJOUT DE LA TEMPERATURE DES ASCENDANCES +** NON DILUES AU NIVEAU KLEV = ND +** POSONS LE ENVIRON EGAL A CELUI DE KLEV-1 +******************************************************** + + TPK(NL+1)=TPK(NL) + +******************************************************* + + RG = GRAVITY ! RG redevient la gravite de YOMCST (sb) + + + RETURN + END + + + + + + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/tracinca_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/tracinca_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/tracinca_mod.F90 (revision 1280) @@ -0,0 +1,191 @@ +!$Id $ +! +MODULE tracinca_mod +! +! This module prepares and calls the INCA main subroutines. +! + +CONTAINS + + SUBROUTINE tracinca_init(aerosol,lessivage) + ! This subroutine initialize some control varaibles. + + USE infotrac + IMPLICIT NONE + + ! Output variables + LOGICAL,DIMENSION(nbtr), INTENT(OUT) :: aerosol + LOGICAL,INTENT(OUT) :: lessivage + + + ! Initialization + lessivage =.FALSE. + aerosol(:) = .FALSE. + + END SUBROUTINE tracinca_init + + SUBROUTINE tracinca( & + nstep, julien, gmtime, lafin, & + pdtphys, t_seri, paprs, pplay, & + pmfu, ftsol, pctsrf, pphis, & + pphi, albsol, sh, rh, & + cldfra, rneb, diafra, cldliq, & + itop_con, ibas_con, pmflxr, pmflxs, & + prfl, psfl, aerosol_couple, flxmass_w, & + tau_aero, piz_aero, cg_aero, ccm, & + rfname, & + tr_seri, source, solsym) + +!======================================================== +! -- CHIMIE INCA -- +!======================================================== + + USE dimphy + USE infotrac + USE vampir + USE comgeomphy + + IMPLICIT NONE + + INCLUDE "indicesol.h" + INCLUDE "control.h" + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + +!========================================================================== +! -- DESCRIPTION DES ARGUMENTS -- +!========================================================================== + + +! EN ENTREE ... +! +!Configuration grille,temps: + INTEGER,INTENT(IN) :: nstep ! Appel physique + INTEGER,INTENT(IN) :: julien ! Jour julien + REAL,INTENT(IN) :: gmtime + REAL,INTENT(IN) :: pdtphys ! Pas d'integration pour la physique (seconde) + LOGICAL,INTENT(IN) :: lafin ! le flag de la fin de la physique + + +!Physique: +!-------- + REAL,DIMENSION(klon,klev),INTENT(IN) :: t_seri ! Temperature + REAL,DIMENSION(klon,klev),INTENT(IN) :: sh ! humidite specifique + REAL,DIMENSION(klon,klev),INTENT(IN) :: rh ! humidite relative + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs ! pression pour chaque inter-couche (en Pa) + REAL,DIMENSION(klon,klev),INTENT(IN) :: pplay ! pression pour le mileu de chaque couche (en Pa) + REAL,DIMENSION(klon,klev),INTENT(IN) :: pphi ! geopotentiel + REAL,DIMENSION(klon),INTENT(IN) :: pphis + REAL,DIMENSION(klon,klev),INTENT(IN) :: cldliq ! eau liquide nuageuse + REAL,DIMENSION(klon,klev),INTENT(IN) :: cldfra ! fraction nuageuse (tous les nuages) + REAL,DIMENSION(klon,klev),INTENT(IN) :: diafra ! fraction nuageuse (convection ou stratus artificiels) + REAL,DIMENSION(klon,klev),INTENT(IN) :: rneb ! fraction nuageuse (grande echelle) + INTEGER,DIMENSION(klon),INTENT(IN) :: itop_con + INTEGER,DIMENSION(klon),INTENT(IN) :: ibas_con + REAL,DIMENSION(klon),INTENT(IN) :: albsol ! albedo surface +! +!Convection: +!---------- + REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfu ! flux de masse dans le panache montant + +!...Tiedke + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: pmflxr, pmflxs ! Flux precipitant de pluie, neige aux interfaces [convection] + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: prfl, psfl ! Flux precipitant de pluie, neige aux interfaces [large-scale] + + LOGICAL,INTENT(IN) :: aerosol_couple + REAL,DIMENSION(klon,klev),INTENT(IN) :: flxmass_w + REAL,DIMENSION(klon,klev,9,2),INTENT(IN) :: tau_aero + REAL,DIMENSION(klon,klev,9,2),INTENT(IN) :: piz_aero + REAL,DIMENSION(klon,klev,9,2),INTENT(IN) :: cg_aero + CHARACTER(len=4),DIMENSION(9),INTENT(IN) :: rfname + REAL,DIMENSION(klon,klev,2),INTENT(IN) :: ccm + +! Arguments necessaires pour les sources et puits de traceur: + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol ! Temperature du sol (surf)(Kelvin) + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Pourcentage de sol f(nature du sol) + + + ! InOutput argument + REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT) :: tr_seri ! Concentration Traceur [U/KgA] + + ! Output arguments + REAL,DIMENSION(klon,nbtr), INTENT(OUT) :: source ! a voir lorsque le flux de surface est prescrit + CHARACTER(len=8),DIMENSION(nbtr), INTENT(OUT) :: solsym + +!======================================================================================= +! -- VARIABLES LOCALES TRACEURS -- +!======================================================================================= + + INTEGER :: k + REAL,DIMENSION(klon,klev) :: pdel + REAL :: calday + INTEGER :: ncsec + + CALL VTe(VTphysiq) + CALL VTb(VTinca) + + calday = FLOAT(julien) + gmtime + ncsec = NINT (86400.*gmtime) + + DO k = 1, klev + pdel(:,k) = paprs(:,k) - paprs (:,k+1) + END DO + + IF (config_inca == 'aero') THEN +#ifdef INCA + CALL aerosolmain( & + aerosol_couple,tr_seri,pdtphys, & + pplay,pdel,prfl,pmflxr,psfl, & + pmflxs,pmfu,itop_con,ibas_con, & + pphi,airephy,nstep,rneb,t_seri, & + rh,tau_aero,piz_aero,cg_aero, & + rfname,ccm,lafin) +#endif + END IF + +#ifdef INCA + CALL chemmain (tr_seri, & !mmr + nstep, & !nstep + calday, & !calday + julien, & !ncdate + ncsec, & !ncsec + 1, & !lat + pdtphys, & !delt + paprs(1,1), & !ps + pplay, & !pmid + pdel, & !pdel + airephy, & + pctsrf(1,1),& !oro + ftsol, & !tsurf + albsol, & !albs + pphi, & !zma + pphis, & !phis + cldfra, & !cldfr + rneb, & !cldfr_st + diafra, & !cldfr_cv + itop_con, & !cldtop + ibas_con, & !cldbot + cldliq, & !cwat + prfl, & !flxrst + pmflxr, & !flxrcv + psfl, & !flxsst + pmflxs, & !flxscv + pmfu, & !flxupd + flxmass_w, & !flxmass_w + t_seri, & !tfld + sh, & !sh + rh, & !rh + iip1, & !nx + jjp1, & !ny + source, & + solsym) +#endif + + CALL VTe(VTinca) + CALL VTb(VTphysiq) + + + END SUBROUTINE tracinca + + +END MODULE tracinca_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/traclmdz_mod.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/traclmdz_mod.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/traclmdz_mod.F90 (revision 1280) @@ -0,0 +1,344 @@ +!$Id $ +! +MODULE traclmdz_mod +! +! In this module all tracers specific to LMDZ are treated. This module is used +! only if running without any other chemestry model as INCA or REPROBUS. +! + + REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: masktr ! Masque reservoir de sol traceur +!$OMP THREADPRIVATE(masktr) ! Masque de l'echange avec la surface (1 = reservoir) ou (possible >= 1 ) + REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: fshtr ! Flux surfacique dans le reservoir de sol +!$OMP THREADPRIVATE(fshtr) + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: hsoltr ! Epaisseur equivalente du reservoir de sol +!$OMP THREADPRIVATE(hsoltr) +! +!Radioelements: +!-------------- +! + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tautr ! Constante de decroissance radioactive +!$OMP THREADPRIVATE(tautr) + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: vdeptr ! Vitesse de depot sec dans la couche Brownienne +!$OMP THREADPRIVATE(vdeptr) + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: scavtr ! Coefficient de lessivage +!$OMP THREADPRIVATE(scavtr) + REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: srcbe ! Production du beryllium7 dans l atmosphere (U/s/kgA) +!$OMP THREADPRIVATE(srcbe) + + LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: radio ! radio(it) = true => decroisssance radioactive +!$OMP THREADPRIVATE(radio) + + REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: trs ! Conc. radon ds le sol +!$OMP THREADPRIVATE(trs) + + INTEGER,SAVE :: id_be ! Activation et position du traceur Be7 [ id_be=0 -> desactive ] +!$OMP THREADPRIVATE(id_be) + + LOGICAL,SAVE :: rnpb=.TRUE. ! Presence du couple Rn222, Pb210 +!$OMP THREADPRIVATE(rnpb) + + +CONTAINS + + SUBROUTINE traclmdz_from_restart(trs_in) + ! This subroutine initialize the module saved variable trs with values from restart file (startphy.nc). + ! This subroutine is called from phyetat0 after the field trs_in has been read. + + USE dimphy + USE infotrac + IMPLICIT NONE + + ! Input argument + REAL,DIMENSION(klon,nbtr), INTENT(IN) :: trs_in + + ! Local variables + INTEGER :: ierr + + ! Allocate restart variables trs + ALLOCATE( trs(klon,nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('traclmdz_from_restart', 'pb in allocation 1',1) + + ! Initialize trs with values read from restart file + trs(:,:) = trs_in(:,:) + + END SUBROUTINE traclmdz_from_restart + + + SUBROUTINE traclmdz_init(pctsrf, ftsol, tr_seri, aerosol, lessivage) + ! This subroutine allocates and initialize module variables and control variables. + USE dimphy + USE infotrac + USE carbon_cycle_mod, ONLY : carbon_cycle_init, carbon_cycle_tr, carbon_cycle_cpl + + IMPLICIT NONE + + INCLUDE "indicesol.h" + +! Input variables + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Pourcentage de sol f(nature du sol) + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol ! Temperature du sol (surf)(Kelvin) + REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr_seri! Concentration Traceur [U/KgA] + +! Output variables + LOGICAL,DIMENSION(nbtr), INTENT(OUT) :: aerosol + LOGICAL,INTENT(OUT) :: lessivage + +! Local variables + INTEGER :: ierr, it, iiq + +! -------------------------------------------- +! Allocation +! -------------------------------------------- + + ALLOCATE( scavtr(nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 9',1) + scavtr(:)=1. + + ALLOCATE( radio(nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 11',1) + radio(:) = .false. ! Par defaut pas decroissance radioactive + + ALLOCATE( masktr(klon,nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 2',1) + + ALLOCATE( fshtr(klon,nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 3',1) + + ALLOCATE( hsoltr(nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 4',1) + + ALLOCATE( tautr(nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 5',1) + tautr(:) = 0. + + ALLOCATE( vdeptr(nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 6',1) + vdeptr(:) = 0. + + + lessivage = .TRUE. + aerosol(:) = .FALSE. ! Tous les traceurs sont des gaz par defaut + +! +! Recherche des traceurs connus : Be7, CO2,... +! -------------------------------------------- + id_be=0 + DO it=1,nbtr + iiq=niadv(it+2) + IF ( tname(iiq) == "BE" .OR. tname(iiq) == "Be" .OR. & + tname(iiq) == "BE7" .OR. tname(iiq) == "Be7" ) THEN + ! Recherche du Beryllium 7 + id_be=it + ALLOCATE( srcbe(klon,klev) ) + radio(id_be) = .TRUE. + aerosol(id_be) = .TRUE. ! le Be est un aerosol + CALL init_be(pctsrf,masktr(:,id_be),tautr(id_be),vdeptr(id_be),scavtr(id_be),srcbe) + WRITE(*,*) 'Initialisation srcBe: OK' + END IF + END DO +! +! Valeurs specifiques pour les traceurs Rn222 et Pb210 +! ---------------------------------------------- + IF (rnpb) THEN + + radio(1)= .TRUE. + radio(2)= .TRUE. + pbl_flg(1) = 0 ! au lieu de clsol=true ! CL au sol calcule + pbl_flg(2) = 0 ! au lieu de clsol=true + + aerosol(2) = .TRUE. ! le Pb est un aerosol + + CALL initrrnpb (ftsol,pctsrf,masktr,fshtr,hsoltr,tautr,vdeptr,scavtr) + END IF + +! +! Initialisation de module carbon_cycle_mod +! ---------------------------------------------- + IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN + CALL carbon_cycle_init(tr_seri, aerosol, radio) + END IF + + END SUBROUTINE traclmdz_init + + SUBROUTINE traclmdz( & + nstep, pdtphys, t_seri, & + paprs, pplay, cdragh, coefh, & + yu1, yv1, ftsol, pctsrf, & + xlat, couchelimite, & + tr_seri, source, solsym, d_tr_cl) + + USE dimphy + USE infotrac + USE carbon_cycle_mod, ONLY : carbon_cycle, carbon_cycle_tr, carbon_cycle_cpl + + IMPLICIT NONE + + INCLUDE "YOMCST.h" + INCLUDE "indicesol.h" + +!========================================================================== +! -- DESCRIPTION DES ARGUMENTS -- +!========================================================================== + +! Input arguments +! +!Configuration grille,temps: + INTEGER,INTENT(IN) :: nstep ! nombre d'appels de la physiq + REAL,INTENT(IN) :: pdtphys ! Pas d'integration pour la physique (seconde) + REAL,DIMENSION(klon),INTENT(IN) :: xlat ! latitudes pour chaque point + +! +!Physique: +!-------- + REAL,DIMENSION(klon,klev),INTENT(IN) :: t_seri ! Temperature + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs ! pression pour chaque inter-couche (en Pa) + REAL,DIMENSION(klon,klev),INTENT(IN) :: pplay ! pression pour le mileu de chaque couche (en Pa) + + +!Couche limite: +!-------------- +! + REAL,DIMENSION(klon,klev),INTENT(IN) :: cdragh ! coeff drag pour T et Q + REAL,DIMENSION(klon,klev),INTENT(IN) :: coefh ! coeff melange CL (m**2/s) + REAL,DIMENSION(klon),INTENT(IN) :: yu1 ! vents au premier niveau + REAL,DIMENSION(klon),INTENT(IN) :: yv1 ! vents au premier niveau + LOGICAL,INTENT(IN) :: couchelimite + +! Arguments necessaires pour les sources et puits de traceur: + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol ! Temperature du sol (surf)(Kelvin) + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Pourcentage de sol f(nature du sol) + + +! InOutput argument + REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT) :: tr_seri ! Concentration Traceur [U/KgA] + +! Output argument + CHARACTER(len=8),DIMENSION(nbtr), INTENT(OUT) :: solsym + REAL,DIMENSION(klon,nbtr), INTENT(OUT) :: source ! a voir lorsque le flux de surface est prescrit + REAL,DIMENSION(klon,klev,nbtr), INTENT(OUT) :: d_tr_cl ! Td couche limite/traceur + +!======================================================================================= +! -- VARIABLES LOCALES TRACEURS -- +!======================================================================================= + + INTEGER :: i, k, it + + REAL,DIMENSION(klon) :: d_trs ! Td dans le reservoir + REAL,DIMENSION(klon,klev) :: delp ! epaisseur de couche (Pa) + + REAL,DIMENSION(klon,klev,nbtr) :: d_tr_dec ! Td radioactive + REAL :: zrho ! Masse Volumique de l'air KgA/m3 + +! +! +!================================================================= +! Ajout de la production en Be7 (Beryllium) srcbe U/s/kgA +!================================================================= +! + IF ( id_be /= 0 ) THEN + DO k = 1, klev + DO i = 1, klon + tr_seri(i,k,id_be) = tr_seri(i,k,id_be)+srcbe(i,k)*pdtphys + END DO + END DO + WRITE(*,*) 'Ajout srcBe dans tr_seri: OK' + END IF + + + DO it=1,nbtr + WRITE(solsym(it),'(i2)') it + END DO +!====================================================================== +! -- Calcul de l'effet de la couche limite -- +!====================================================================== + + IF (couchelimite) THEN + source(:,:) = 0.0 + + IF (id_be /=0) THEN + DO i=1, klon + zrho = pplay(i,1)/t_seri(i,1)/RD + source(i,id_be) = - vdeptr(id_be)*tr_seri(i,1,id_be)*zrho + END DO + END IF + + END IF + + + DO k = 1, klev + DO i = 1, klon + delp(i,k) = paprs(i,k)-paprs(i,k+1) + END DO + END DO + + DO it=1, nbtr + IF (couchelimite .AND. pbl_flg(it) == 0 ) THEN ! couche limite avec quantite dans le sol calculee + CALL cltracrn(it, pdtphys, yu1, yv1, & + cdragh, coefh,t_seri,ftsol,pctsrf, & + tr_seri(:,:,it),trs(:,it), & + paprs, pplay, delp, & + masktr(:,it),fshtr(:,it),hsoltr(it),& + tautr(it),vdeptr(it), & + xlat,d_tr_cl(:,:,it),d_trs) + + DO k = 1, klev + DO i = 1, klon + tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cl(i,k,it) + END DO + END DO + + ! Traceur dans le reservoir sol + DO i = 1, klon + trs(i,it) = trs(i,it) + d_trs(i) + END DO + END IF + END DO + +!====================================================================== +! Calcul de l'effet du puits radioactif +!====================================================================== + CALL radio_decay (radio,rnpb,pdtphys,tautr,tr_seri,d_tr_dec) + + DO it=1,nbtr + IF(radio(it)) then + DO k = 1, klev + DO i = 1, klon + tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_dec(i,k,it) + END DO + END DO + CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'puits rn it='//solsym(it)) + END IF + END DO + +!====================================================================== +! Calcul de cycle de carbon +!====================================================================== + IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN + CALL carbon_cycle(nstep, pdtphys, pctsrf, tr_seri) + END IF + + END SUBROUTINE traclmdz + + + SUBROUTINE traclmdz_to_restart(trs_out) + ! This subroutine is called from phyredem.F where the module + ! variable trs is written to restart file (restartphy.nc) + USE dimphy + USE infotrac + + IMPLICIT NONE + + REAL,DIMENSION(klon,nbtr), INTENT(OUT) :: trs_out + INTEGER :: ierr + + IF ( ALLOCATED(trs) ) THEN + trs_out(:,:) = trs(:,:) + ELSE + ! No previous allocate of trs. This is the case for create_etat0_limit. + trs_out(:,:) = 0.0 + END IF + + END SUBROUTINE traclmdz_to_restart + + +END MODULE traclmdz_mod Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/transp.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/transp.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/transp.F (revision 1280) @@ -0,0 +1,48 @@ +! +! $Header$ +! + SUBROUTINE transp (paprs,tsol, + e t, q, u, v, geom, + s vtran_e, vtran_q, utran_e, utran_q) +c + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X.Li (LMD/CNRS) +c Date: le 25 avril 1994 +c Objet: Calculer le transport de l'energie et de la vapeur d'eau +c====================================================================== +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c + REAL paprs(klon,klev+1), tsol(klon) + REAL t(klon,klev), q(klon,klev), u(klon,klev), v(klon,klev) + REAL utran_e(klon), utran_q(klon), vtran_e(klon), vtran_q(klon) +c + INTEGER i, l +c ------------------------------------------------------------------ + REAL geom(klon,klev), e +c ------------------------------------------------------------------ + DO i = 1, klon + utran_e(i) = 0.0 + utran_q(i) = 0.0 + vtran_e(i) = 0.0 + vtran_q(i) = 0.0 + ENDDO +c + DO l = 1, klev + DO i = 1, klon + e = RCPD*t(i,l) + RLVTT*q(i,l) + geom(i,l) + utran_e(i)=utran_e(i)+ u(i,l)*e*(paprs(i,l)-paprs(i,l+1))/RG + utran_q(i)=utran_q(i)+ u(i,l)*q(i,l) + . *(paprs(i,l)-paprs(i,l+1))/RG + vtran_e(i)=vtran_e(i)+ v(i,l)*e*(paprs(i,l)-paprs(i,l+1))/RG + vtran_q(i)=vtran_q(i)+ v(i,l)*q(i,l) + . *(paprs(i,l)-paprs(i,l+1))/RG + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/transp_lay.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/transp_lay.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/transp_lay.F (revision 1280) @@ -0,0 +1,53 @@ +! +! $Header$ +! + SUBROUTINE transp_lay (paprs,tsol, + e t, q, u, v, geom, + s vtran_e, vtran_q, utran_e, utran_q) +c + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X.Li (LMD/CNRS) +c Date: le 25 avril 1994 +c Objet: Calculer le transport de l'energie et de la vapeur d'eau +c====================================================================== +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c + REAL paprs(klon,klev+1), tsol(klon) + REAL t(klon,klev), q(klon,klev), u(klon,klev), v(klon,klev) + REAL utran_e(klon,klev), utran_q(klon,klev) + REAL vtran_e(klon,klev), vtran_q(klon,klev) +c + INTEGER i, l +c ------------------------------------------------------------------ + REAL geom(klon,klev), esh +c ------------------------------------------------------------------ + DO l = 1, klev + DO i = 1, klon + utran_e(i,l) = 0.0 + utran_q(i,l) = 0.0 + vtran_e(i,l) = 0.0 + vtran_q(i,l) = 0.0 + ENDDO + ENDDO +c + DO l = 1, klev + DO i = 1, klon + esh = RCPD*t(i,l) + RLVTT*q(i,l) + geom(i,l) + utran_e(i,l)=utran_e(i,l)+ u(i,l)*esh* + . (paprs(i,l)-paprs(i,l+1))/RG + utran_q(i,l)=utran_q(i,l)+ u(i,l)*q(i,l) + . *(paprs(i,l)-paprs(i,l+1))/RG + vtran_e(i,l)=vtran_e(i,l)+ v(i,l)*esh* + . (paprs(i,l)-paprs(i,l+1))/RG + vtran_q(i,l)=vtran_q(i,l)+ v(i,l)*q(i,l) + . *(paprs(i,l)-paprs(i,l+1))/RG + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/undefSTD.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/undefSTD.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/undefSTD.F (revision 1280) @@ -0,0 +1,93 @@ +! +! $Header$ +! + SUBROUTINE undefSTD(nlevSTD,itap,tlevSTD, + $ dtime,ecrit_hf, + $ oknondef,tnondef,tsumSTD) + USE netcdf + USE dimphy + IMPLICIT none +c +c==================================================================== +c +c I. Musat : 09.2004 +c +c Calcul * du nombre de pas de temps (FLOAT(ecrit_XXX)-tnondef)) +c ou la variable tlevSTD est bien definie (.NE.1.E+20), +c et +c * de la somme de tlevSTD => tsumSTD +c +c nout=1 !var. journaliere "day" moyenne sur tous les pas de temps +c ! de la physique +c nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps +c ! de la physique +c nout=3 !var. mensuelle "NMC" moyennee toutes les 6heures +c +c +c NB: mettre "inst(X)" dans le write_histXXX.h ! +c==================================================================== +c +cym#include "dimensions.h" +cym integer jjmp1 +cym parameter (jjmp1=jjm+1-1/jjm) +cym#include "dimphy.h" +c variables Input +c + INTEGER nlevSTD, klevSTD, itap + PARAMETER(klevSTD=17) + REAL dtime, ecrit_hf +c +c variables locales + INTEGER i, k, nout + PARAMETER(nout=3) !nout=1 : day; =2 : mth; =3 : NMC +c +c variables Output + REAL tlevSTD(klon,klevSTD), tsumSTD(klon,klevSTD,nout) + LOGICAL oknondef(klon,klevSTD,nout) + REAL tnondef(klon,klevSTD,nout) +c + REAL missing_val +c + missing_val=nf90_fill_real +c +c calcul variables tous les pas de temps de la physique +c + DO k=1, nlevSTD + DO i=1, klon + IF(tlevSTD(i,k).EQ.missing_val) THEN + IF(oknondef(i,k,1)) THEN + tnondef(i,k,1)=tnondef(i,k,1)+1. + ENDIF !oknondef(i,k) +c + IF(oknondef(i,k,2)) THEN + tnondef(i,k,2)=tnondef(i,k,2)+1. + ENDIF !oknondef(i,k) +c + ELSE IF(tlevSTD(i,k).NE.missing_val) THEN + tsumSTD(i,k,1)=tsumSTD(i,k,1)+tlevSTD(i,k) + tsumSTD(i,k,2)=tsumSTD(i,k,2)+tlevSTD(i,k) + ENDIF + ENDDO !i + ENDDO !k +c +c calcul variables toutes les 6h +c + IF(MOD(itap,NINT(ecrit_hf/dtime)).EQ.0) THEN +c + DO k=1, nlevSTD + DO i=1, klon + IF(tlevSTD(i,k).EQ.missing_val) THEN + IF(oknondef(i,k,3)) THEN + tnondef(i,k,3)=tnondef(i,k,3)+1. + ENDIF !oknondef(i,k) +c + ELSE IF(tlevSTD(i,k).NE.missing_val) THEN + tsumSTD(i,k,3)=tsumSTD(i,k,3)+tlevSTD(i,k) + ENDIF + ENDDO !i + ENDDO !k + + ENDIF !MOD(itap,NINT(ecrit_hf/dtime)).EQ.0 +c + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ustarhb.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ustarhb.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/ustarhb.F (revision 1280) @@ -0,0 +1,54 @@ +! +! $Header$ +! + SUBROUTINE ustarhb(knon,u,v,cd_m, ustar) + use dimphy + IMPLICIT none +c====================================================================== +c Laurent Li (LMD/CNRS), le 30 septembre 1998 +c Couche limite non-locale. Adaptation du code du CCM3. +c Code non teste, donc a ne pas utiliser. +c====================================================================== +c Nonlocal scheme that determines eddy diffusivities based on a +c diagnosed boundary layer height and a turbulent velocity scale. +c Also countergradient effects for heat and moisture are included. +c +c For more information, see Holtslag, A.A.M., and B.A. Boville, 1993: +c Local versus nonlocal boundary-layer diffusion in a global climate +c model. J. of Climate, vol. 6, 1825-1842. +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c Arguments: +c + INTEGER knon ! nombre de points a calculer + REAL u(klon,klev) ! vitesse U (m/s) + REAL v(klon,klev) ! vitesse V (m/s) + REAL cd_m(klon) ! coefficient de friction au sol pour vitesse + REAL ustar(klon) +c + INTEGER i, k + REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy + REAL zx_alf1, zx_alf2 ! parametres pour extrapolation + LOGICAL unssrf(klon) ! unstb pbl w/lvls within srf pbl lyr + LOGICAL unsout(klon) ! unstb pbl w/lvls in outer pbl lyr + LOGICAL check(klon) ! True=>chk if Richardson no.>critcal +c +#include "YOETHF.h" +#include "FCTTRE.h" + DO i = 1, knon + zx_alf1 = 1.0 + zx_alf2 = 1.0 - zx_alf1 + zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2 + zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2 + zxmod = 1.0+SQRT(zxu**2+zxv**2) + taux = zxu *zxmod*cd_m(i) + tauy = zxv *zxmod*cd_m(i) + ustar(i) = SQRT(taux**2+tauy**2) +c print*,'Ust ',zxu,zxmod,taux,ustar(i) + ENDDO +c + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/vdif_kcay.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/vdif_kcay.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/vdif_kcay.F (revision 1280) @@ -0,0 +1,743 @@ +! +! $Header$ +! + SUBROUTINE vdif_kcay(ngrid,dt,g,rconst,plev,temp + s ,zlev,zlay,u,v,teta,cd,q2,q2diag,km,kn,ustar + s ,l_mix) + use dimphy + IMPLICIT NONE +c....................................................................... +cym#include "dimensions.h" +cym#include "dimphy.h" +c....................................................................... +c +c dt : pas de temps +c g : g +c zlev : altitude a chaque niveau (interface inferieure de la couche +c de meme indice) +c zlay : altitude au centre de chaque couche +c u,v : vitesse au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c teta : temperature potentielle au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c cd : cdrag +c (en entree : la valeur au debut du pas de temps) +c q2 : $q^2$ au bas de chaque couche +c (en entree : la valeur au debut du pas de temps) +c (en sortie : la valeur a la fin du pas de temps) +c km : diffusivite turbulente de quantite de mouvement (au bas de chaque +c couche) +c (en sortie : la valeur a la fin du pas de temps) +c kn : diffusivite turbulente des scalaires (au bas de chaque couche) +c (en sortie : la valeur a la fin du pas de temps) +c +c....................................................................... + REAL dt,g,rconst + real plev(klon,klev+1),temp(klon,klev) + real ustar(klon),snstable + REAL zlev(klon,klev+1) + REAL zlay(klon,klev) + REAL u(klon,klev) + REAL v(klon,klev) + REAL teta(klon,klev) + REAL cd(klon) + REAL q2(klon,klev+1),q2s(klon,klev+1) + REAL q2diag(klon,klev+1) + REAL km(klon,klev+1) + REAL kn(klon,klev+1) + real sq(klon),sqz(klon),zz(klon,klev+1),zq,long0(klon) + + integer l_mix,iii +c....................................................................... +c +c nlay : nombre de couches +c nlev : nombre de niveaux +c ngrid : nombre de points de grille +c unsdz : 1 sur l'epaisseur de couche +c unsdzdec : 1 sur la distance entre le centre de la couche et le +c centre de la couche inferieure +c q : echelle de vitesse au bas de chaque couche +c (valeur a la fin du pas de temps) +c +c....................................................................... + INTEGER nlay,nlev,ngrid + REAL unsdz(klon,klev) + REAL unsdzdec(klon,klev+1) + REAL q(klon,klev+1) + +c....................................................................... +c +c kmpre : km au debut du pas de temps +c qcstat : q : solution stationnaire du probleme couple +c (valeur a la fin du pas de temps) +c q2cstat : q2 : solution stationnaire du probleme couple +c (valeur a la fin du pas de temps) +c +c....................................................................... + REAL kmpre(klon,klev+1) + REAL qcstat + REAL q2cstat + real sss,sssq +c....................................................................... +c +c long : longueur de melange calculee selon Blackadar +c +c....................................................................... + REAL long(klon,klev+1) +c....................................................................... +c +c kmq3 : terme en q^3 dans le developpement de km +c (valeur au debut du pas de temps) +c kmcstat : valeur de km solution stationnaire du systeme {q2 ; du/dz} +c (valeur a la fin du pas de temps) +c knq3 : terme en q^3 dans le developpement de kn +c mcstat : valeur de m solution stationnaire du systeme {q2 ; du/dz} +c (valeur a la fin du pas de temps) +c m2cstat : valeur de m2 solution stationnaire du systeme {q2 ; du/dz} +c (valeur a la fin du pas de temps) +c m : valeur a la fin du pas de temps +c mpre : valeur au debut du pas de temps +c m2 : valeur a la fin du pas de temps +c n2 : valeur a la fin du pas de temps +c +c....................................................................... + REAL kmq3 + REAL kmcstat + REAL knq3 + REAL mcstat + REAL m2cstat + REAL m(klon,klev+1) + REAL mpre(klon,klev+1) + REAL m2(klon,klev+1) + REAL n2(klon,klev+1) +c....................................................................... +c +c gn : intermediaire pour les coefficients de stabilite +c gnmin : borne inferieure de gn (-0.23 ou -0.28) +c gnmax : borne superieure de gn (0.0233) +c gninf : vrai si gn est en dessous de sa borne inferieure +c gnsup : vrai si gn est en dessus de sa borne superieure +c gm : drole d'objet bien utile +c ri : nombre de Richardson +c sn : coefficient de stabilite pour n +c snq2 : premier terme du developement limite de sn en q2 +c sm : coefficient de stabilite pour m +c smq2 : premier terme du developement limite de sm en q2 +c +c....................................................................... + REAL gn + REAL gnmin + REAL gnmax + LOGICAL gninf + LOGICAL gnsup + REAL gm +c REAL ri(klon,klev+1) + REAL sn(klon,klev+1) + REAL snq2(klon,klev+1) + REAL sm(klon,klev+1) + REAL smq2(klon,klev+1) +c....................................................................... +c +c kappa : consatnte de Von Karman (0.4) +c long00 : longueur de reference pour le calcul de long (160) +c a1,a2,b1,b2,c1 : constantes d'origine pour les coefficients +c de stabilite (0.92/0.74/16.6/10.1/0.08) +c cn1,cn2 : constantes pour sn +c cm1,cm2,cm3,cm4 : constantes pour sm +c +c....................................................................... + REAL kappa + REAL long00 + REAL a1,a2,b1,b2,c1 + REAL cn1,cn2 + REAL cm1,cm2,cm3,cm4 +c....................................................................... +c +c termq : termes en $q$ dans l'equation de q2 +c termq3 : termes en $q^3$ dans l'equation de q2 +c termqm2 : termes en $q*m^2$ dans l'equation de q2 +c termq3m2 : termes en $q^3*m^2$ dans l'equation de q2 +c +c....................................................................... + REAL termq + REAL termq3 + REAL termqm2 + REAL termq3m2 +c....................................................................... +c +c q2min : borne inferieure de q2 +c q2max : borne superieure de q2 +c +c....................................................................... + REAL q2min + REAL q2max +c....................................................................... +c knmin : borne inferieure de kn +c kmmin : borne inferieure de km +c....................................................................... + REAL knmin + REAL kmmin +c....................................................................... + INTEGER ilay,ilev,igrid + REAL tmp1,tmp2 +c....................................................................... + PARAMETER (kappa=0.4E+0) + PARAMETER (long00=160.E+0) +c PARAMETER (gnmin=-10.E+0) + PARAMETER (gnmin=-0.28) + PARAMETER (gnmax=0.0233E+0) + PARAMETER (a1=0.92E+0) + PARAMETER (a2=0.74E+0) + PARAMETER (b1=16.6E+0) + PARAMETER (b2=10.1E+0) + PARAMETER (c1=0.08E+0) + PARAMETER (knmin=1.E-5) + PARAMETER (kmmin=1.E-5) + PARAMETER (q2min=1.e-5) + PARAMETER (q2max=1.E+2) +cym PARAMETER (nlay=klev) +cym PARAMETER (nlev=klev+1) +c + PARAMETER ( + & cn1=a2*(1.E+0 -6.E+0 *a1/b1) + & ) + PARAMETER ( + & cn2=-3.E+0 *a2*(6.E+0 *a1+b2) + & ) + PARAMETER ( + & cm1=a1*(1.E+0 -3.E+0 *c1-6.E+0 *a1/b1) + & ) + PARAMETER ( + & cm2=a1*(-3.E+0 *a2*((b2-3.E+0 *a2)*(1.E+0 -6.E+0 *a1/b1) + & -3.E+0 *c1*(b2+6.E+0 *a1))) + & ) + PARAMETER ( + & cm3=-3.E+0 *a2*(6.E+0 *a1+b2) + & ) + PARAMETER ( + & cm4=-9.E+0 *a1*a2 + & ) + + logical first + save first + data first/.true./ +c$OMP THREADPRIVATE(first) +c....................................................................... +c traitment des valeur de q2 en entree +c....................................................................... +c +c Initialisation de q2 + nlay=klev + nlev=klev+1 + + call yamada(ngrid,dt,g,rconst,plev,temp + s ,zlev,zlay,u,v,teta,cd,q2diag,km,kn,ustar + s ,l_mix) + if (first.and.1.eq.1) then + first=.false. + q2=q2diag + endif + + DO ilev=1,nlev + DO igrid=1,ngrid + q2(igrid,ilev)=amax1(q2(igrid,ilev),q2min) + q(igrid,ilev)=sqrt(q2(igrid,ilev)) + ENDDO + ENDDO +c + DO igrid=1,ngrid + tmp1=cd(igrid)*(u(igrid,1)**2+v(igrid,1)**2) + q2(igrid,1)=b1**(2.E+0/3.E+0)*tmp1 + q2(igrid,1)=amax1(q2(igrid,1),q2min) + q(igrid,1)=sqrt(q2(igrid,1)) + ENDDO +c +c....................................................................... +c les increments verticaux +c....................................................................... +c +c!!!!! allerte !!!!!c +c!!!!! zlev n'est pas declare a nlev !!!!!c +c!!!!! ----> + DO igrid=1,ngrid + zlev(igrid,nlev)=zlay(igrid,nlay) + & +( zlay(igrid,nlay) - zlev(igrid,nlev-1) ) + ENDDO +c!!!!! <---- +c!!!!! allerte !!!!!c +c + DO ilay=1,nlay + DO igrid=1,ngrid + unsdz(igrid,ilay)=1.E+0/(zlev(igrid,ilay+1)-zlev(igrid,ilay)) + ENDDO + ENDDO + DO igrid=1,ngrid + unsdzdec(igrid,1)=1.E+0/(zlay(igrid,1)-zlev(igrid,1)) + ENDDO + DO ilay=2,nlay + DO igrid=1,ngrid + unsdzdec(igrid,ilay)=1.E+0/(zlay(igrid,ilay)-zlay(igrid,ilay-1)) + ENDDO + ENDDO + DO igrid=1,ngrid + unsdzdec(igrid,nlay+1)=1.E+0/(zlev(igrid,nlay+1)-zlay(igrid,nlay)) + ENDDO +c +c....................................................................... +c le cisaillement et le gradient de temperature +c....................................................................... +c + DO igrid=1,ngrid + m2(igrid,1)=(unsdzdec(igrid,1) + & *u(igrid,1))**2 + & +(unsdzdec(igrid,1) + & *v(igrid,1))**2 + m(igrid,1)=sqrt(m2(igrid,1)) + mpre(igrid,1)=m(igrid,1) + ENDDO +c +c----------------------------------------------------------------------- + DO ilev=2,nlev-1 + DO igrid=1,ngrid +c----------------------------------------------------------------------- +c + n2(igrid,ilev)=g*unsdzdec(igrid,ilev) + & *(teta(igrid,ilev)-teta(igrid,ilev-1)) + & /(teta(igrid,ilev)+teta(igrid,ilev-1)) *2.E+0 +c n2(igrid,ilev)=0. +c +c ---> +c on ne sais traiter que les cas stratifies. et l'ajustement +c convectif est cense faire en sorte que seul des configurations +c stratifiees soient rencontrees en entree de cette routine. +c mais, bon ... on sait jamais (meme on sait que n2 prends +c quelques valeurs negatives ... parfois) alors : +c<--- +c + IF (n2(igrid,ilev).lt.0.E+0) THEN + n2(igrid,ilev)=0.E+0 + ENDIF +c + m2(igrid,ilev)=(unsdzdec(igrid,ilev) + & *(u(igrid,ilev)-u(igrid,ilev-1)))**2 + & +(unsdzdec(igrid,ilev) + & *(v(igrid,ilev)-v(igrid,ilev-1)))**2 + m(igrid,ilev)=sqrt(m2(igrid,ilev)) + mpre(igrid,ilev)=m(igrid,ilev) +c +c----------------------------------------------------------------------- + ENDDO + ENDDO +c----------------------------------------------------------------------- +c + DO igrid=1,ngrid + m2(igrid,nlev)=m2(igrid,nlev-1) + m(igrid,nlev)=m(igrid,nlev-1) + mpre(igrid,nlev)=m(igrid,nlev) + ENDDO +c +c....................................................................... +c calcul des fonctions de stabilite +c....................................................................... +c + if (l_mix.eq.4) then + DO igrid=1,ngrid + sqz(igrid)=1.e-10 + sq(igrid)=1.e-10 + ENDDO + do ilev=2,nlev-1 + DO igrid=1,ngrid + zq=sqrt(q2(igrid,ilev)) + sqz(igrid) + . =sqz(igrid)+zq*zlev(igrid,ilev) + . *(zlay(igrid,ilev)-zlay(igrid,ilev-1)) + sq(igrid)=sq(igrid)+zq*(zlay(igrid,ilev)-zlay(igrid,ilev-1)) + ENDDO + enddo + DO igrid=1,ngrid + long0(igrid)=0.2*sqz(igrid)/sq(igrid) + ENDDO + else if (l_mix.eq.3) then + long0(igrid)=long00 + endif + +c (abd 5 2) print*,'LONG0=',long0 + +c----------------------------------------------------------------------- + DO ilev=2,nlev-1 + DO igrid=1,ngrid +c----------------------------------------------------------------------- +c + tmp1=kappa*(zlev(igrid,ilev)-zlev(igrid,1)) + if (l_mix.ge.10) then + long(igrid,ilev)=l_mix + else + long(igrid,ilev)=tmp1/(1.E+0 + tmp1/long0(igrid)) + endif + long(igrid,ilev)=max(min(long(igrid,ilev) + s ,0.5*sqrt(q2(igrid,ilev))/sqrt(max(n2(igrid,ilev),1.e-10))) + s ,5.) + + gn=-long(igrid,ilev)**2 / q2(igrid,ilev) + & * n2(igrid,ilev) + gm=long(igrid,ilev)**2 / q2(igrid,ilev) + & * m2(igrid,ilev) +c + gninf=.false. + gnsup=.false. + long(igrid,ilev)=long(igrid,ilev) + long(igrid,ilev)=long(igrid,ilev) +c + IF (gn.lt.gnmin) THEN + gninf=.true. + gn=gnmin + ENDIF +c + IF (gn.gt.gnmax) THEN + gnsup=.true. + gn=gnmax + ENDIF +c + sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn) + sm(igrid,ilev)= + & (cm1+cm2*gn) + & /( (1.E+0 +cm3*gn) + & *(1.E+0 +cm4*gn) ) +c + IF ((gninf).or.(gnsup)) THEN + snq2(igrid,ilev)=0.E+0 + smq2(igrid,ilev)=0.E+0 + ELSE + snq2(igrid,ilev)= + & -gn + & *(-cn1*cn2/(1.E+0 +cn2*gn)**2 ) + smq2(igrid,ilev)= + & -gn + & *( cm2*(1.E+0 +cm3*gn) + & *(1.E+0 +cm4*gn) + & -( cm3*(1.E+0 +cm4*gn) + & +cm4*(1.E+0 +cm3*gn) ) + & *(cm1+cm2*gn) ) + & /( (1.E+0 +cm3*gn) + & *(1.E+0 +cm4*gn) )**2 + ENDIF +c +c abd +c if(ilev.le.57.and.ilev.ge.37) then +c print*,'L=',ilev,' GN=',gn,' SM=',sm(igrid,ilev) +c endif +c ---> +c la decomposition de Taylor en q2 n'a de sens que +c dans les cas stratifies ou sn et sm sont quasi +c proportionnels a q2. ailleurs on laisse le meme +c algorithme car l'ajustement convectif fait le travail. +c mais c'est delirant quand sn et snq2 n'ont pas le meme +c signe : dans ces cas, on ne fait pas la decomposition. +c<--- +c + IF (snq2(igrid,ilev)*sn(igrid,ilev).le.0.E+0) + & snq2(igrid,ilev)=0.E+0 + IF (smq2(igrid,ilev)*sm(igrid,ilev).le.0.E+0) + & smq2(igrid,ilev)=0.E+0 +c +C Correction pour les couches stables. +C Schema repris de JHoltzlag Boville, lui meme venant de... + + if (1.eq.1) then + snstable=1.-zlev(igrid,ilev) + s /(700.*max(ustar(igrid),0.0001)) + snstable=1.-zlev(igrid,ilev)/400. + snstable=max(snstable,0.) + snstable=snstable*snstable + +c abde print*,'SN ',ilev,sn(1,ilev),snstable + if (sn(igrid,ilev).lt.snstable) then + sn(igrid,ilev)=snstable + snq2(igrid,ilev)=0. + endif + + if (sm(igrid,ilev).lt.snstable) then + sm(igrid,ilev)=snstable + smq2(igrid,ilev)=0. + endif + + endif + +c sn : coefficient de stabilite pour n +c snq2 : premier terme du developement limite de sn en q2 +c----------------------------------------------------------------------- + ENDDO + ENDDO +c----------------------------------------------------------------------- +c +c....................................................................... +c calcul de km et kn au debut du pas de temps +c....................................................................... +c + DO igrid=1,ngrid + kn(igrid,1)=knmin + km(igrid,1)=kmmin + kmpre(igrid,1)=km(igrid,1) + ENDDO +c +c----------------------------------------------------------------------- + DO ilev=2,nlev-1 + DO igrid=1,ngrid +c----------------------------------------------------------------------- +c + kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) + & *sn(igrid,ilev) + km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) + & *sm(igrid,ilev) + kmpre(igrid,ilev)=km(igrid,ilev) +c +c----------------------------------------------------------------------- + ENDDO + ENDDO +c----------------------------------------------------------------------- +c + DO igrid=1,ngrid + kn(igrid,nlev)=kn(igrid,nlev-1) + km(igrid,nlev)=km(igrid,nlev-1) + kmpre(igrid,nlev)=km(igrid,nlev) + ENDDO +c +c....................................................................... +c boucle sur les niveaux 2 a nlev-1 +c....................................................................... +c +c----> + DO 10001 ilev=2,nlev-1 +c----> + DO 10002 igrid=1,ngrid +c +c....................................................................... +c +c calcul des termes sources et puits de l'equation de q2 +c ------------------------------------------------------ +c + knq3=kn(igrid,ilev)*snq2(igrid,ilev) + & /sn(igrid,ilev) + kmq3=km(igrid,ilev)*smq2(igrid,ilev) + & /sm(igrid,ilev) +c + termq=0.E+0 + termq3=0.E+0 + termqm2=0.E+0 + termq3m2=0.E+0 +c + tmp1=dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev) + tmp2=dt*2.E+0 *kmq3*m2(igrid,ilev) + termqm2=termqm2 + & +dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev) + & -dt*2.E+0 *kmq3*m2(igrid,ilev) + termq3m2=termq3m2 + & +dt*2.E+0 *kmq3*m2(igrid,ilev) +c + termq=termq + & -dt*2.E+0 *kn(igrid,ilev)*n2(igrid,ilev) + & +dt*2.E+0 *knq3*n2(igrid,ilev) + termq3=termq3 + & -dt*2.E+0 *knq3*n2(igrid,ilev) +c + termq3=termq3 + & -dt*2.E+0 *q(igrid,ilev)**3 / (b1*long(igrid,ilev)) +c +c....................................................................... +c +c resolution stationnaire couplee avec le gradient de vitesse local +c ----------------------------------------------------------------- +c +c -----{on cherche le cisaillement qui annule l'equation de q^2 +c supposee en q3} +c + tmp1=termq+termq3 + tmp2=termqm2+termq3m2 + m2cstat=m2(igrid,ilev) + & -(tmp1+tmp2)/(dt*2.E+0*km(igrid,ilev)) + mcstat=sqrt(m2cstat) + +c abde print*,'M2 L=',ilev,mpre(igrid,ilev),mcstat +c +c -----{puis on ecrit la valeur de q qui annule l'equation de m +c supposee en q3} +c + IF (ilev.eq.2) THEN + kmcstat=1.E+0 / mcstat + & *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1) + & *mpre(igrid,ilev+1) + & +unsdz(igrid,ilev-1) + & *cd(igrid) + & *( sqrt(u(igrid,3)**2+v(igrid,3)**2) + & -mcstat/unsdzdec(igrid,ilev) + & -mpre(igrid,ilev+1)/unsdzdec(igrid,ilev+1) )**2) + & /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) ) + ELSE + kmcstat=1.E+0 / mcstat + & *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1) + & *mpre(igrid,ilev+1) + & +unsdz(igrid,ilev-1)*kmpre(igrid,ilev-1) + & *mpre(igrid,ilev-1) ) + & /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) ) + ENDIF + tmp2=kmcstat + & /( sm(igrid,ilev)/q2(igrid,ilev) ) + & /long(igrid,ilev) + qcstat=tmp2**(1.E+0/3.E+0) + q2cstat=qcstat**2 +c +c....................................................................... +c +c choix de la solution finale +c --------------------------- +c + q(igrid,ilev)=qcstat + q2(igrid,ilev)=q2cstat + m(igrid,ilev)=mcstat +c abd if(ilev.le.57.and.ilev.ge.37) then +c print*,'L=',ilev,' M2=',m2(igrid,ilev),m2cstat, +c s 'N2=',n2(igrid,ilev) +c abd endif + m2(igrid,ilev)=m2cstat +c +c ---> +c pour des raisons simples q2 est minore +c<--- +c + IF (q2(igrid,ilev).lt.q2min) THEN + q2(igrid,ilev)=q2min + q(igrid,ilev)=sqrt(q2min) + ENDIF +c +c....................................................................... +c +c calcul final de kn et km +c ------------------------ +c + gn=-long(igrid,ilev)**2 / q2(igrid,ilev) + & * n2(igrid,ilev) + IF (gn.lt.gnmin) gn=gnmin + IF (gn.gt.gnmax) gn=gnmax + sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn) + sm(igrid,ilev)= + & (cm1+cm2*gn) + & /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) ) + kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) + & *sn(igrid,ilev) + km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) + & *sm(igrid,ilev) +c abd +c if(ilev.le.57.and.ilev.ge.37) then +c print*,'L=',ilev,' GN=',gn,' SM=',sm(igrid,ilev) +c endif +c +c....................................................................... +c +10002 CONTINUE +c +10001 CONTINUE +c +c....................................................................... +c +c + DO igrid=1,ngrid + kn(igrid,1)=knmin + km(igrid,1)=kmmin +c kn(igrid,1)=cd(igrid) +c km(igrid,1)=cd(igrid) + q2(igrid,nlev)=q2(igrid,nlev-1) + q(igrid,nlev)=q(igrid,nlev-1) + kn(igrid,nlev)=kn(igrid,nlev-1) + km(igrid,nlev)=km(igrid,nlev-1) + ENDDO +c +c CALCUL DE LA DIFFUSION VERTICALE DE Q2 + if (1.eq.1) then + + do ilev=2,klev-1 + sss=sss+plev(1,ilev-1)-plev(1,ilev+1) + sssq=sssq+(plev(1,ilev-1)-plev(1,ilev+1))*q2(1,ilev) + enddo +c print*,'Q2moy avant',sssq/sss +c print*,'Q2q20 ',(q2(1,ilev),ilev=1,10) +c print*,'Q2km0 ',(km(1,ilev),ilev=1,10) +c ! C'est quoi ca qu'etait dans l'original??? +c do igrid=1,ngrid +c q2(igrid,1)=10. +c enddo +c q2s=q2 +c do iii=1,10 +c call vdif_q2(dt,g,rconst,plev,temp,km,q2) +c do ilev=1,klev+1 +c write(iii+49,*) q2(1,ilev),zlev(1,ilev) +c enddo +c enddo +c stop +c do ilev=1,klev +c print*,zlev(1,ilev),q2s(1,ilev),q2(1,ilev) +c enddo +c q2s=q2-q2s +c do ilev=1,klev +c print*,q2s(1,ilev),zlev(1,ilev) +c enddo + do ilev=2,klev-1 + sss=sss+plev(1,ilev-1)-plev(1,ilev+1) + sssq=sssq+(plev(1,ilev-1)-plev(1,ilev+1))*q2(1,ilev) + enddo + print*,'Q2moy apres',sssq/sss +c +c + do ilev=1,nlev + do igrid=1,ngrid + q2(igrid,ilev)=max(q2(igrid,ilev),q2min) + q(igrid,ilev)=sqrt(q2(igrid,ilev)) + +c....................................................................... +c +c calcul final de kn et km +c ------------------------ +c + gn=-long(igrid,ilev)**2 / q2(igrid,ilev) + & * n2(igrid,ilev) + IF (gn.lt.gnmin) gn=gnmin + IF (gn.gt.gnmax) gn=gnmax + sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn) + sm(igrid,ilev)= + & (cm1+cm2*gn) + & /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) ) +C Correction pour les couches stables. +C Schema repris de JHoltzlag Boville, lui meme venant de... + + if (1.eq.1) then + snstable=1.-zlev(igrid,ilev) + s /(700.*max(ustar(igrid),0.0001)) + snstable=1.-zlev(igrid,ilev)/400. + snstable=max(snstable,0.) + snstable=snstable*snstable + +c abde print*,'SN ',ilev,sn(1,ilev),snstable + if (sn(igrid,ilev).lt.snstable) then + sn(igrid,ilev)=snstable + snq2(igrid,ilev)=0. + endif + + if (sm(igrid,ilev).lt.snstable) then + sm(igrid,ilev)=snstable + smq2(igrid,ilev)=0. + endif + + endif + +c sn : coefficient de stabilite pour n + kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) + & *sn(igrid,ilev) + km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) +c + enddo + enddo +c print*,'Q2km1 ',(km(1,ilev),ilev=1,10) + + endif + + RETURN + END Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/wake.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/wake.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/wake.F (revision 1280) @@ -0,0 +1,2705 @@ + Subroutine WAKE (p,ph,ppi,dtime,sigd_con + : ,te0,qe0,omgb + : ,dtdwn,dqdwn,amdwn,amup,dta,dqa + : ,wdtPBL,wdqPBL,udtPBL,udqPBL + o ,deltatw,deltaqw,dth,hw,sigmaw,wape,fip,gfl + o ,dtls,dqls + o ,ktopw,omgbdth,dp_omgb,wdens + o ,tu,qu + o ,dtKE,dqKE + o ,dtPBL,dqPBL + o ,omg,dp_deltomg,spread + o ,Cstar,d_deltat_gw + o ,d_deltatw2,d_deltaqw2) + + +*************************************************************** +* * +* WAKE * +* retour a un Pupper fixe * +* * +* written by : GRANDPEIX Jean-Yves 09/03/2000 * +* modified by : ROEHRIG Romain 01/29/2007 * +*************************************************************** +c + use dimphy + IMPLICIT none +c============================================================================ +C +C +C But : Decrire le comportement des poches froides apparaissant dans les +C grands systemes convectifs, et fournir l'energie disponible pour +C le declenchement de nouvelles colonnes convectives. +C +C Variables d'etat : deltatw : ecart de temperature wake-undisturbed area +C deltaqw : ecart d'humidite wake-undisturbed area +C sigmaw : fraction d'aire occupee par la poche. +C +C Variable de sortie : +c +c wape : WAke Potential Energy +c fip : Front Incident Power (W/m2) - ALP +c gfl : Gust Front Length per unit area (m-1) +C dtls : large scale temperature tendency due to wake +C dqls : large scale humidity tendency due to wake +C hw : hauteur de la poche +C dp_omgb : vertical gradient of large scale omega +C omgbdth: flux of Delta_Theta transported by LS omega +C dtKE : differential heating (wake - unpertubed) +C dqKE : differential moistening (wake - unpertubed) +C omg : Delta_omg =vertical velocity diff. wake-undist. (Pa/s) +C dp_deltomg : vertical gradient of omg (s-1) +C spread : spreading term in dt_wake and dq_wake +C deltatw : updated temperature difference (T_w-T_u). +C deltaqw : updated humidity difference (q_w-q_u). +C sigmaw : updated wake fractional area. +C d_deltat_gw : delta T tendency due to GW +c +C Variables d'entree : +c +c aire : aire de la maille +c te0 : temperature dans l'environnement (K) +C qe0 : humidite dans l'environnement (kg/kg) +C omgb : vitesse verticale moyenne sur la maille (Pa/s) +C dtdwn: source de chaleur due aux descentes (K/s) +C dqdwn: source d'humidite due aux descentes (kg/kg/s) +C dta : source de chaleur due courants satures et detrain (K/s) +C dqa : source d'humidite due aux courants satures et detra (kg/kg/s) +C amdwn: flux de masse total des descentes, par unite de +C surface de la maille (kg/m2/s) +C amup : flux de masse total des ascendances, par unite de +C surface de la maille (kg/m2/s) +C p : pressions aux milieux des couches (Pa) +C ph : pressions aux interfaces (Pa) +C ppi : (p/p_0)**kapa (adim) +C dtime: increment temporel (s) +c +C Variables internes : +c +c rhow : masse volumique de la poche froide +C rho : environment density at P levels +C rhoh : environment density at Ph levels +C te : environment temperature | may change within +C qe : environment humidity | sub-time-stepping +C the : environment potential temperature +C thu : potential temperature in undisturbed area +C tu : temperature in undisturbed area +C qu : humidity in undisturbed area +C dp_omgb: vertical gradient og LS omega +C omgbw : wake average vertical omega +C dp_omgbw: vertical gradient of omgbw +C omgbdq : flux of Delta_q transported by LS omega +C dth : potential temperature diff. wake-undist. +C th1 : first pot. temp. for vertical advection (=thu) +C th2 : second pot. temp. for vertical advection (=thw) +C q1 : first humidity for vertical advection +C q2 : second humidity for vertical advection +C d_deltatw : terme de redistribution pour deltatw +C d_deltaqw : terme de redistribution pour deltaqw +C deltatw0 : deltatw initial +C deltaqw0 : deltaqw initial +C hw0 : hw initial +C sigmaw0: sigmaw initial +C amflux : horizontal mass flux through wake boundary +C wdens : number of wakes per unit area (3D) or per +C unit length (2D) +C Tgw : 1 sur la période de onde de gravité +c Cgw : vitesse de propagation de onde de gravité +c LL : distance entre 2 poches + +c------------------------------------------------------------------------- +c Déclaration de variables +c------------------------------------------------------------------------- + +#include "dimensions.h" +#include "YOMCST.h" +#include "cvthermo.h" +#include "iniprint.h" + +c Arguments en entree +c-------------------- + + REAL, dimension(klon,klev) :: p, ppi + REAL, dimension(klon,klev+1) :: ph, omgb + REAL dtime + REAL, dimension(klon,klev) :: te0,qe0 + REAL, dimension(klon,klev) :: dtdwn, dqdwn + REAL, dimension(klon,klev) :: wdtPBL,wdqPBL + REAL, dimension(klon,klev) :: udtPBL,udqPBL + REAL, dimension(klon,klev) :: amdwn, amup + REAL, dimension(klon,klev) :: dta, dqa + REAL, dimension(klon) :: sigd_con + +c Sorties +c-------- + + REAL, dimension(klon,klev) :: deltatw, deltaqw, dth + REAL, dimension(klon,klev) :: tu, qu + REAL, dimension(klon,klev) :: dtls, dqls + REAL, dimension(klon,klev) :: dtKE, dqKE + REAL, dimension(klon,klev) :: dtPBL, dqPBL + REAL, dimension(klon,klev) :: spread + REAL, dimension(klon,klev) :: d_deltatgw + REAL, dimension(klon,klev) :: d_deltatw2, d_deltaqw2 + REAL, dimension(klon,klev+1) :: omgbdth, omg + REAL, dimension(klon,klev) :: dp_omgb, dp_deltomg + REAL, dimension(klon,klev) :: d_deltat_gw + REAL, dimension(klon) :: hw, sigmaw, wape, fip, gfl, Cstar + INTEGER, dimension(klon) :: ktopw + +c Variables internes +c------------------- + +c Variables à fixer + REAL ALON + REAL coefgw + REAL :: wdens0, wdens + REAL stark + REAL alpk + REAL delta_t_min + INTEGER nsub + REAL dtimesub + REAL sigmad, hwmin + REAL :: sigmaw_max +cIM 080208 + LOGICAL, dimension(klon) :: gwake + +c Variables de sauvegarde + REAL, dimension(klon,klev) :: deltatw0 + REAL, dimension(klon,klev) :: deltaqw0 + REAL, dimension(klon,klev) :: te, qe + REAL, dimension(klon) :: sigmaw0, sigmaw1 + +c Variables pour les GW + REAL, DIMENSION(klon) :: LL + REAL, dimension(klon,klev) :: N2 + REAL, dimension(klon,klev) :: Cgw + REAL, dimension(klon,klev) :: Tgw + +c Variables liées au calcul de hw + REAL, DIMENSION(klon) :: ptop_provis, ptop, ptop_new + REAL, DIMENSION(klon) :: sum_dth + REAL, DIMENSION(klon) :: dthmin + REAL, DIMENSION(klon) :: z, dz, hw0 + INTEGER, DIMENSION(klon) :: ktop, kupper + +c Sub-timestep tendencies and related variables + REAL d_deltatw(klon,klev),d_deltaqw(klon,klev) + REAL d_te(klon,klev),d_qe(klon,klev) + REAL d_sigmaw(klon),alpha(klon) + REAL q0_min(klon),q1_min(klon) + LOGICAL wk_adv(klon), OK_qx_qw(klon) + +c Autres variables internes + INTEGER isubstep, k, i + + REAL, DIMENSION(klon) :: sum_thu, sum_tu, sum_qu,sum_thvu + REAL, DIMENSION(klon) :: sum_dq, sum_rho + REAL, DIMENSION(klon) :: sum_dtdwn, sum_dqdwn + REAL, DIMENSION(klon) :: av_thu, av_tu, av_qu, av_thvu + REAL, DIMENSION(klon) :: av_dth, av_dq, av_rho + REAL, DIMENSION(klon) :: av_dtdwn, av_dqdwn + + REAL, DIMENSION(klon,klev) :: rho, rhow + REAL, DIMENSION(klon,klev+1) :: rhoh + REAL, DIMENSION(klon,klev) :: rhow_moyen + REAL, DIMENSION(klon,klev) :: zh + REAL, DIMENSION(klon,klev+1) :: zhh + REAL, DIMENSION(klon,klev) :: epaisseur1, epaisseur2 + + REAL, DIMENSION(klon,klev) :: the, thu + +! REAL, DIMENSION(klon,klev) :: d_deltatw, d_deltaqw + + REAL, DIMENSION(klon,klev+1) :: omgbw + REAL, DIMENSION(klon) :: pupper + REAL, DIMENSION(klon) :: omgtop + REAL, DIMENSION(klon,klev) :: dp_omgbw + REAL, DIMENSION(klon) :: ztop, dztop + REAL, DIMENSION(klon,klev) :: alpha_up + + REAL, dimension(klon) :: RRe1, RRe2 + REAL :: RRd1, RRd2 + REAL, DIMENSION(klon,klev) :: Th1, Th2, q1, q2, T1 + REAL, DIMENSION(klon,klev) :: D_Th1, D_Th2, D_dth + REAL, DIMENSION(klon,klev) :: D_q1, D_q2, D_dq + REAL, DIMENSION(klon,klev) :: omgbdq + + REAL, dimension(klon) :: ff, gg + REAL, dimension(klon) :: wape2, Cstar2, heff + + REAL, DIMENSION(klon,klev) :: Crep + REAL Crep_upper, Crep_sol + +C------------------------------------------------------------------------- +c Initialisations +c------------------------------------------------------------------------- + +c print*, 'wake initialisations' + +c Essais d'initialisation avec sigmaw = 0.02 et hw = 10. +c------------------------------------------------------------------------- + + DATA sigmad, hwmin /.02,10./ + +C Longueur de maille (en m) +c------------------------------------------------------------------------- + +c ALON = 3.e5 + ALON = 1.e6 + + +C Configuration de coefgw,stark,wdens (22/02/06 by YU Jingmei) +c +c coefgw : Coefficient pour les ondes de gravité +c stark : Coefficient k dans Cstar=k*sqrt(2*WAPE) +c wdens : Densité de poche froide par maille +c------------------------------------------------------------------------- + + coefgw=10 +c coefgw=1 +c wdens0 = 1.0/(alon**2) + wdens = 1.0/(alon**2) + stark = 0.50 +cCRtest + alpk=0.1 +c alpk = 1.0 +c alpk = 0.5 +c alpk = 0.05 + Crep_upper=0.9 + Crep_sol=1.0 + +C Minimum value for |T_wake - T_undist|. Used for wake top definition +c------------------------------------------------------------------------- + + delta_t_min = 0.2 + +C 1. - Save initial values and initialize tendencies +C -------------------------------------------------- + + DO k=1,klev + DO i=1, klon + deltatw0(i,k) = deltatw(i,k) + deltaqw0(i,k)= deltaqw(i,k) + te(i,k) = te0(i,k) + qe(i,k) = qe0(i,k) + dtls(i,k) = 0. + dqls(i,k) = 0. + d_deltat_gw(i,k)=0. + d_te(i,k) = 0. + d_qe(i,k) = 0. + d_deltatw(i,k) = 0. + d_deltaqw(i,k) = 0. +!IM 060508 beg + d_deltatw2(i,k)=0. + d_deltaqw2(i,k)=0. +!IM 060508 end + ENDDO + ENDDO +c sigmaw1=sigmaw +c IF (sigd_con.GT.sigmaw1) THEN +c print*, 'sigmaw,sigd_con', sigmaw, sigd_con +c ENDIF + DO i=1, klon +cc sigmaw(i) = amax1(sigmaw(i),sigd_con(i)) + sigmaw(i) = amax1(sigmaw(i),sigmad) + sigmaw(i) = amin1(sigmaw(i),0.99) + sigmaw0(i) = sigmaw(i) + wape(i) = 0. + wape2(i) = 0. + d_sigmaw(i) = 0. + ktopw(i) = 0 + ENDDO +C +C +C 2. - Prognostic part +C -------------------- +C +C +C 2.1 - Undisturbed area and Wake integrals +C --------------------------------------------------------- + + DO i=1, klon + z(i) = 0. + ktop(i)=0 + kupper(i) = 0 + sum_thu(i) = 0. + sum_tu(i) = 0. + sum_qu(i) = 0. + sum_thvu(i) = 0. + sum_dth(i) = 0. + sum_dq(i) = 0. + sum_rho(i) = 0. + sum_dtdwn(i) = 0. + sum_dqdwn(i) = 0. + + av_thu(i) = 0. + av_tu(i) =0. + av_qu(i) =0. + av_thvu(i) = 0. + av_dth(i) = 0. + av_dq(i) = 0. + av_rho(i) =0. + av_dtdwn(i) =0. + av_dqdwn(i) = 0. + ENDDO +c +c Distance between wakes + DO i = 1,klon + LL(i) = (1-sqrt(sigmaw(i)))/sqrt(wdens) + ENDDO +C Potential temperatures and humidity +c---------------------------------------------------------- + DO k =1,klev + DO i=1, klon + rho(i,k) = p(i,k)/(rd*te(i,k)) + IF(k .eq. 1) THEN + rhoh(i,k) = ph(i,k)/(rd*te(i,k)) + zhh(i,k)=0 + ELSE + rhoh(i,k) = ph(i,k)*2./(rd*(te(i,k)+te(i,k-1))) + zhh(i,k)=(ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG)+zhh(i,k-1) + ENDIF + the(i,k) = te(i,k)/ppi(i,k) + thu(i,k) = (te(i,k) - deltatw(i,k)*sigmaw(i))/ppi(i,k) + tu(i,k) = te(i,k) - deltatw(i,k)*sigmaw(i) + qu(i,k) = qe(i,k) - deltaqw(i,k)*sigmaw(i) + rhow(i,k) = p(i,k)/(rd*(tu(i,k)+deltatw(i,k))) + dth(i,k) = deltatw(i,k)/ppi(i,k) + ENDDO + ENDDO + + DO k = 1, klev-1 + DO i=1, klon + IF(k.eq.1) THEN + N2(i,k)=0 + ELSE + N2(i,k)=amax1(0.,-RG**2/the(i,k)*rho(i,k)*(the(i,k+1)- + $ the(i,k-1))/(p(i,k+1)-p(i,k-1))) + ENDIF + ZH(i,k)=(zhh(i,k)+zhh(i,k+1))/2 + + Cgw(i,k)=sqrt(N2(i,k))*ZH(i,k) + Tgw(i,k)=coefgw*Cgw(i,k)/LL(i) + ENDDO + ENDDO + + DO i=1, klon + N2(i,klev)=0 + ZH(i,klev)=0 + Cgw(i,klev)=0 + Tgw(i,klev)=0 + ENDDO + +c Calcul de la masse volumique moyenne de la colonne (bdlmd) +c----------------------------------------------------------------- + + DO k=1,klev + DO i=1, klon + epaisseur1(i,k)=0. + epaisseur2(i,k)=0. + ENDDO + ENDDO + + DO i=1, klon + epaisseur1(i,1)= -(ph(i,2)-ph(i,1))/(rho(i,1)*rg)+1. + epaisseur2(i,1)= -(ph(i,2)-ph(i,1))/(rho(i,1)*rg)+1. + rhow_moyen(i,1) = rhow(i,1) + ENDDO + + DO k = 2, klev + DO i=1, klon + epaisseur1(i,k)= -(ph(i,k+1)-ph(i,k))/(rho(i,k)*rg) +1. + epaisseur2(i,k)=epaisseur2(i,k-1)+epaisseur1(i,k) + rhow_moyen(i,k) = (rhow_moyen(i,k-1)*epaisseur2(i,k-1)+ + $ rhow(i,k)*epaisseur1(i,k))/epaisseur2(i,k) + ENDDO + ENDDO + +C +C Choose an integration bound well above wake top +c----------------------------------------------------------------- +c +C Pupper = 50000. ! melting level +c Pupper = 60000. +c Pupper = 80000. ! essais pour case_e + DO i = 1,klon +ccc Pupper(i) = 0.6*ph(i,1) + Pupper(i) = 60000. + ENDDO + +C +C Determine Wake top pressure (Ptop) from buoyancy integral +C -------------------------------------------------------- +c +c-1/ Pressure of the level where dth becomes less than delta_t_min. + + DO i=1,klon + ptop_provis(i)=ph(i,1) + ENDDO + DO k= 2,klev + DO i=1,klon +c +cIM v3JYG; ptop_provis(i).LT. ph(i,1) +c + IF (dth(i,k) .GT. -delta_t_min .and. + $ dth(i,k-1).LT. -delta_t_min .and. + $ ptop_provis(i).EQ. ph(i,1)) THEN + ptop_provis(i) = ((dth(i,k)+delta_t_min)*p(i,k-1) + $ - (dth(i,k-1)+delta_t_min)*p(i,k)) / + $ (dth(i,k) - dth(i,k-1)) + ENDIF + ENDDO + ENDDO + +c-2/ dth integral + + DO i=1,klon + sum_dth(i) = 0. + dthmin(i) = -delta_t_min + z(i) = 0. + ENDDO + + DO k = 1,klev + DO i=1,klon + dz(i) = -(amax1(ph(i,k+1),ptop_provis(i))-Ph(i,k))/(rho(i,k)*rg) + IF (dz(i) .gt. 0) THEN + z(i) = z(i)+dz(i) + sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i) + dthmin(i) = amin1(dthmin(i),dth(i,k)) + ENDIF + ENDDO + ENDDO + +c-3/ height of triangle with area= sum_dth and base = dthmin + + DO i=1,klon + hw0(i) = 2.*sum_dth(i)/amin1(dthmin(i),-0.5) + hw0(i) = amax1(hwmin,hw0(i)) + ENDDO + +c-4/ now, get Ptop + + DO i=1,klon + z(i) = 0. + ptop(i) = ph(i,1) + ENDDO + + DO k = 1,klev + DO i=1,klon + dz(i) = amin1(-(ph(i,k+1)-ph(i,k))/(rho(i,k)*rg),hw0(i)-z(i)) + IF (dz(i) .gt. 0) THEN + z(i) = z(i)+dz(i) + ptop(i) = ph(i,k)-rho(i,k)*rg*dz(i) + ENDIF + ENDDO + ENDDO + + +C-5/ Determination de ktop et kupper + + DO k=klev,1,-1 + DO i=1,klon + IF (ph(i,k+1) .lt. ptop(i)) ktop(i)=k + IF (ph(i,k+1) .lt. pupper(i)) kupper(i)=k + ENDDO + ENDDO + +c-6/ Correct ktop and ptop + + DO i = 1,klon + ptop_new(i)=ptop(i) + ENDDO + DO k= klev,2,-1 + DO i=1,klon + IF (k .LE. ktop(i) .and. + $ ptop_new(i) .EQ. ptop(i) .and. + $ dth(i,k) .GT. -delta_t_min .and. + $ dth(i,k-1).LT. -delta_t_min) THEN + ptop_new(i) = ((dth(i,k)+delta_t_min)*p(i,k-1) + $ - (dth(i,k-1)+delta_t_min)*p(i,k)) / + $ (dth(i,k) - dth(i,k-1)) + ENDIF + ENDDO + ENDDO + + DO i=1,klon + ptop(i) = ptop_new(i) + ENDDO + + DO k=klev,1,-1 + DO i=1,klon + IF (ph(i,k+1) .lt. ptop(i)) ktop(i)=k + ENDDO + ENDDO +c +c-5/ Set deltatw & deltaqw to 0 above kupper +c + DO k = 1,klev + DO i=1,klon + IF (k.GE. kupper(i)) THEN + deltatw(i,k) = 0. + deltaqw(i,k) = 0. + ENDIF + ENDDO + ENDDO +c +C +C Vertical gradient of LS omega +C + DO k = 1,klev + DO i=1,klon + IF (k.LE. kupper(i)) THEN + dp_omgb(i,k) = (omgb(i,k+1) - omgb(i,k))/(ph(i,k+1)-ph(i,k)) + ENDIF + ENDDO + ENDDO +C +C Integrals (and wake top level number) +C -------------------------------------- +C +C Initialize sum_thvu to 1st level virt. pot. temp. + + DO i=1,klon + z(i) = 1. + dz(i) = 1. + sum_thvu(i) = thu(i,1)*(1.+eps*qu(i,1))*dz(i) + sum_dth(i) = 0. + ENDDO + + DO k = 1,klev + DO i=1,klon + dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg) + IF (dz(i) .GT. 0) THEN + z(i) = z(i)+dz(i) + sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i) + sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i) + sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i) + sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(i,k))*dz(i) + sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i) + sum_dq(i) = sum_dq(i) + deltaqw(i,k)*dz(i) + sum_rho(i) = sum_rho(i) + rhow(i,k)*dz(i) + sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i,k)*dz(i) + sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i,k)*dz(i) + ENDIF + ENDDO + ENDDO +c + DO i=1,klon + hw0(i) = z(i) + ENDDO +c +C +C 2.1 - WAPE and mean forcing computation +C --------------------------------------- +C +C --------------------------------------- +C +C Means + + DO i=1,klon + av_thu(i) = sum_thu(i)/hw0(i) + av_tu(i) = sum_tu(i)/hw0(i) + av_qu(i) = sum_qu(i)/hw0(i) + av_thvu(i) = sum_thvu(i)/hw0(i) +c av_thve = sum_thve/hw0 + av_dth(i) = sum_dth(i)/hw0(i) + av_dq(i) = sum_dq(i)/hw0(i) + av_rho(i) = sum_rho(i)/hw0(i) + av_dtdwn(i) = sum_dtdwn(i)/hw0(i) + av_dqdwn(i) = sum_dqdwn(i)/hw0(i) + + wape(i) = - rg*hw0(i)*(av_dth(i) + $ + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)+av_dth(i)* + $ av_dq(i) ))/av_thvu(i) + ENDDO +C +C 2.2 Prognostic variable update +C ------------------------------ +C +C Filter out bad wakes + + DO k = 1,klev + DO i=1,klon + IF ( wape(i) .LT. 0.) THEN + deltatw(i,k) = 0. + deltaqw(i,k) = 0. + dth(i,k) = 0. + ENDIF + ENDDO + ENDDO +c + DO i=1,klon + IF ( wape(i) .LT. 0.) THEN + wape(i) = 0. + Cstar(i) = 0. + hw(i) = hwmin + sigmaw(i) = amax1(sigmad,sigd_con(i)) + fip(i) = 0. + gwake(i) = .FALSE. + ELSE + Cstar(i) = stark*sqrt(2.*wape(i)) + gwake(i) = .TRUE. + ENDIF + ENDDO + +c +c Check qx and qw positivity +c -------------------------- + DO i = 1,klon + q0_min(i)=min( (qe(i,1)-sigmaw(i)*deltaqw(i,1)), + $ (qe(i,1)+(1.-sigmaw(i))*deltaqw(i,1)) ) + ENDDO + DO k = 2,klev + DO i = 1,klon + q1_min(i)=min( (qe(i,k)-sigmaw(i)*deltaqw(i,k)), + $ (qe(i,k)+(1.-sigmaw(i))*deltaqw(i,k)) ) + IF (q1_min(i).le.q0_min(i)) THEN + q0_min(i)=q1_min(i) + ENDIF + ENDDO + ENDDO +c + DO i = 1,klon + OK_qx_qw(i) = q0_min(i) .GE. 0. + alpha(i) = 1. + ENDDO +c +CC ----------------------------------------------------------------- +C Sub-time-stepping +C ----------------- +C + nsub=10 + dtimesub=dtime/nsub +c +c------------------------------------------------------------ + DO isubstep = 1,nsub +c------------------------------------------------------------ +c +c wk_adv is the logical flag enabling wake evolution in the time advance loop + DO i = 1,klon + wk_adv(i) = OK_qx_qw(i) .AND. alpha(i) .GE. 1. + ENDDO +c + DO i=1,klon + IF (wk_adv(i)) THEN + gfl(i) = 2.*sqrt(3.14*wdens*sigmaw(i)) + ENDIF + ENDDO + DO i=1,klon + IF (wk_adv(i)) THEN + d_sigmaw(i) = gfl(i)*Cstar(i)*dtimesub +c sigmaw(i) =sigmaw(i) + gfl(i)*Cstar(i)*dtimesub +c sigmaw(i) =min(sigmaw(i),0.99) !!!!!!!! +c wdens = wdens0/(10.*sigmaw) +c sigmaw =max(sigmaw,sigd_con) +c sigmaw =max(sigmaw,sigmad) + ENDIF + ENDDO +C +C +c calcul de la difference de vitesse verticale poche - zone non perturbee +cIM 060208 differences par rapport au code initial; init. a 0 dp_deltomg +cIM 060208 et omg sur les niveaux de 1 a klev+1, alors que avant l'on definit +cIM 060208 au niveau k=1..? + DO k= 1,klev + DO i = 1,klon + dp_deltomg(i,k)=0. + ENDDO + ENDDO + DO k= 1,klev+1 + DO i = 1,klon + omg(i,k)=0. + ENDDO + ENDDO +c + DO i=1,klon + IF (wk_adv(i)) THEN + z(i)= 0. + omg(i,1) = 0. + dp_deltomg(i,1) = -(gfl(i)*Cstar(i))/(sigmaw(i) * (1-sigmaw(i))) + ENDIF + ENDDO +c + DO k= 2,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. ktop(i)) THEN + dz(i) = -(ph(i,k)-ph(i,k-1))/(rho(i,k-1)*rg) + z(i) = z(i)+dz(i) + dp_deltomg(i,k)= dp_deltomg(i,1) + omg(i,k)= dp_deltomg(i,1)*z(i) + ENDIF + ENDDO + ENDDO +c + DO i = 1,klon + IF (wk_adv(i)) THEN + dztop(i)=-(ptop(i)-ph(i,ktop(i)))/(rho(i,ktop(i))*rg) + ztop(i) = z(i)+dztop(i) + omgtop(i)=dp_deltomg(i,1)*ztop(i) + ENDIF + ENDDO +c +c ----------------- +c From m/s to Pa/s +c ----------------- +c + DO i=1,klon + IF (wk_adv(i)) THEN + omgtop(i) = -rho(i,ktop(i))*rg*omgtop(i) + dp_deltomg(i,1) = omgtop(i)/(ptop(i)-ph(i,1)) + ENDIF + ENDDO +c + DO k= 1,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. ktop(i)) THEN + omg(i,k) = - rho(i,k)*rg*omg(i,k) + dp_deltomg(i,k) = dp_deltomg(i,1) + ENDIF + ENDDO + ENDDO +c +c raccordement lineaire de omg de ptop a pupper + + DO i=1,klon + IF ( wk_adv(i) .AND. kupper(i) .GT. ktop(i)) THEN + omg(i,kupper(i)+1) = - Rg*amdwn(i,kupper(i)+1)/sigmaw(i) + $ + Rg*amup(i,kupper(i)+1)/(1.-sigmaw(i)) + dp_deltomg(i,kupper(i)) = (omgtop(i)-omg(i,kupper(i)+1))/ + $ (ptop(i)-pupper(i)) + ENDIF + ENDDO +c + DO k= 1,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .GT. ktop(i) .AND. k .LE. kupper(i)) THEN + dp_deltomg(i,k) = dp_deltomg(i,kupper(i)) + omg(i,k) = omgtop(i)+(ph(i,k)-ptop(i))*dp_deltomg(i,kupper(i)) + ENDIF + ENDDO + ENDDO +c +c +c-- Compute wake average vertical velocity omgbw +c +c + DO k = 1,klev+1 + DO i=1,klon + IF ( wk_adv(i)) THEN + omgbw(i,k) = omgb(i,k)+(1.-sigmaw(i))*omg(i,k) + ENDIF + ENDDO + ENDDO +c-- and its vertical gradient dp_omgbw +c + DO k = 1,klev + DO i=1,klon + IF ( wk_adv(i)) THEN + dp_omgbw(i,k) = (omgbw(i,k+1)-omgbw(i,k))/(ph(i,k+1)-ph(i,k)) + ENDIF + ENDDO + ENDDO +C +c-- Upstream coefficients for omgb velocity +c-- (alpha_up(k) is the coefficient of the value at level k) +c-- (1-alpha_up(k) is the coefficient of the value at level k-1) + DO k = 1,klev + DO i=1,klon + IF ( wk_adv(i)) THEN + alpha_up(i,k) = 0. + IF (omgb(i,k) .GT. 0.) alpha_up(i,k) = 1. + ENDIF + ENDDO + ENDDO + +c Matrix expressing [The,deltatw] from [Th1,Th2] + + DO i=1,klon + IF ( wk_adv(i)) THEN + RRe1(i) = 1.-sigmaw(i) + RRe2(i) = sigmaw(i) + ENDIF + ENDDO + RRd1 = -1. + RRd2 = 1. +c +c-- Get [Th1,Th2], dth and [q1,q2] +c + DO k= 1,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. kupper(i)+1) THEN + dth(i,k) = deltatw(i,k)/ppi(i,k) + Th1(i,k) = the(i,k) - sigmaw(i) *dth(i,k) ! undisturbed area + Th2(i,k) = the(i,k) + (1.-sigmaw(i))*dth(i,k) ! wake + q1(i,k) = qe(i,k) - sigmaw(i) *deltaqw(i,k) ! undisturbed area + q2(i,k) = qe(i,k) + (1.-sigmaw(i))*deltaqw(i,k) ! wake + T1(i,k) = te(i,k) - sigmaw(i)*deltatw(i,k)! undisturb itlmd + ENDIF + ENDDO + ENDDO + + DO i=1,klon + D_Th1(i,1) = 0. !!!itlmd : ne pas mettre if wk_adv cf nrlmd? + D_Th2(i,1) = 0. + D_dth(i,1) = 0. + D_q1(i,1) = 0. + D_q2(i,1) = 0. + D_dq(i,1) = 0. + ENDDO + + DO k= 2,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. kupper(i)+1) THEN + D_Th1(i,k) = Th1(i,k-1)-Th1(i,k) + D_Th2(i,k) = Th2(i,k-1)-Th2(i,k) + D_dth(i,k) = dth(i,k-1)-dth(i,k) + D_q1(i,k) = q1(i,k-1)-q1(i,k) + D_q2(i,k) = q2(i,k-1)-q2(i,k) + D_dq(i,k) = deltaqw(i,k-1)-deltaqw(i,k) + ENDIF + ENDDO + ENDDO + + DO i=1,klon + IF( wk_adv(i)) THEN + omgbdth(i,1) = 0. + omgbdq(i,1) = 0. + ENDIF + ENDDO + + DO k= 2,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. kupper(i)+1) THEN ! loop on interfaces + omgbdth(i,k) = omgb(i,k)*( dth(i,k-1) - dth(i,k)) + omgbdq(i,k) = omgb(i,k)*(deltaqw(i,k-1) - deltaqw(i,k)) + ENDIF + ENDDO + ENDDO +c +c----------------------------------------------------------------- + DO k= 1,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. kupper(i)-1) THEN +c----------------------------------------------------------------- +c +c Compute redistribution (advective) term +c + d_deltatw(i,k) = + $ dtimesub/(Ph(i,k)-Ph(i,k+1))*( + $ RRd1*omg(i,k )*sigmaw(i) *D_Th1(i,k) + $ -RRd2*omg(i,k+1)*(1.-sigmaw(i))*D_Th2(i,k+1) + $ -(1.-alpha_up(i,k))*omgbdth(i,k) - alpha_up(i,k+1)* + $ omgbdth(i,k+1))*ppi(i,k) +c print*,'d_deltatw=',d_deltatw(i,k) +c + d_deltaqw(i,k) = + $ dtimesub/(Ph(i,k)-Ph(i,k+1))*( + $ RRd1*omg(i,k )*sigmaw(i) *D_q1(i,k) + $ -RRd2*omg(i,k+1)*(1.-sigmaw(i))*D_q2(i,k+1) + $ -(1.-alpha_up(i,k))*omgbdq(i,k) - alpha_up(i,k+1)* + $ omgbdq(i,k+1)) +c print*,'d_deltaqw=',d_deltaqw(i,k) +c +c and increment large scale tendencies +c + +c +C +CC ----------------------------------------------------------------- + d_te(i,k) = dtimesub*( + $ ( RRe1(i)*omg(i,k )*sigmaw(i) *D_Th1(i,k) + $ -RRe2(i)*omg(i,k+1)*(1.-sigmaw(i))*D_Th2(i,k+1) ) + $ /(Ph(i,k)-Ph(i,k+1)) + $ -sigmaw(i)*(1.-sigmaw(i))*dth(i,k)* + $ (omg(i,k)-omg(i,k+1))/(Ph(i,k)-Ph(i,k+1)) !instead of dp_deltomg(i,k) + $ )*ppi(i,k) +c + d_qe(i,k) = dtimesub*( + $ ( RRe1(i)*omg(i,k )*sigmaw(i) *D_q1(i,k) + $ -RRe2(i)*omg(i,k+1)*(1.-sigmaw(i))*D_q2(i,k+1) ) + $ /(Ph(i,k)-Ph(i,k+1)) + $ -sigmaw(i)*(1.-sigmaw(i))*deltaqw(i,k)* + $ (omg(i,k)-omg(i,k+1))/(Ph(i,k)-Ph(i,k+1))!instead of dp_deltomg(i,k) + $ ) + ELSE IF(wk_adv(i) .AND. k .EQ. kupper(i)) THEN ! corr pour conserver l'eau + + d_te(i,k) = dtimesub*( + $ ( RRe1(i)*omg(i,k )*sigmaw(i) *D_Th1(i,k)) + $ /(Ph(i,k)-Ph(i,k+1)) + $ )*ppi(i,k) + + d_qe(i,k) = dtimesub*( + $ ( RRe1(i)*omg(i,k )*sigmaw(i) *D_q1(i,k)) + $ /(Ph(i,k)-Ph(i,k+1)) + $ ) + ENDIF + +c------------------------------------------------------------------- + ENDDO + ENDDO +c------------------------------------------------------------------ +C +C Increment state variables + + DO k= 1,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. kupper(i)-1) THEN +c +c Coefficient de répartition + + Crep(i,k)=Crep_sol*(ph(i,kupper(i))-ph(i,k))/(ph(i,kupper(i)) + $ -ph(i,1)) + Crep(i,k)=Crep(i,k)+Crep_upper*(ph(i,1)-ph(i,k))/(p(i,1)- + $ ph(i,kupper(i))) + + +c Reintroduce compensating subsidence term. + +c dtKE(k)=(dtdwn(k)*Crep(k))/sigmaw +c dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)) +c . /(1-sigmaw) +c dqKE(k)=(dqdwn(k)*Crep(k))/sigmaw +c dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)) +c . /(1-sigmaw) +c +c dtKE(k)=(dtdwn(k)*Crep(k)+(1-Crep(k))*dta(k))/sigmaw +c dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)*Crep(k)) +c . /(1-sigmaw) +c dqKE(k)=(dqdwn(k)*Crep(k)+(1-Crep(k))*dqa(k))/sigmaw +c dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)*Crep(k)) +c . /(1-sigmaw) + + dtKE(i,k)=(dtdwn(i,k)/sigmaw(i) - dta(i,k)/(1.-sigmaw(i))) + dqKE(i,k)=(dqdwn(i,k)/sigmaw(i) - dqa(i,k)/(1.-sigmaw(i))) +c print*,'dtKE=',dtKE(k) +c print*,'dqKE=',dqKE(k) +c + dtPBL(i,k)=(wdtPBL(i,k)/sigmaw(i) - udtPBL(i,k)/(1.-sigmaw(i))) + dqPBL(i,k)=(wdqPBL(i,k)/sigmaw(i) - udqPBL(i,k)/(1.-sigmaw(i))) +c + spread(i,k) = (1.-sigmaw(i))*dp_deltomg(i,k)+gfl(i)*Cstar(i)/ + $ sigmaw(i) + + +c ajout d'un effet onde de gravité -Tgw(k)*deltatw(k) 03/02/06 YU Jingmei + + d_deltat_gw(i,k)=d_deltat_gw(i,k)-Tgw(i,k)*deltatw(i,k)* + $ dtimesub + ff(i)=d_deltatw(i,k)/dtimesub + +c Sans GW +c +c deltatw(k)=deltatw(k)+dtimesub*(ff+dtKE(k)-spread(k)*deltatw(k)) +c +c GW formule 1 +c +c deltatw(k) = deltatw(k)+dtimesub* +c $ (ff+dtKE(k) - spread(k)*deltatw(k)-Tgw(k)*deltatw(k)) +c +c GW formule 2 + + IF (dtimesub*Tgw(i,k).lt.1.e-10) THEN + d_deltatw(i,k) = dtimesub* + $ (ff(i)+dtKE(i,k)+dtPBL(i,k) + $ - spread(i,k)*deltatw(i,k)-Tgw(i,k)*deltatw(i,k)) + ELSE + d_deltatw(i,k) = 1/Tgw(i,k)*(1-exp(-dtimesub* + $ Tgw(i,k)))* + $ (ff(i)+dtKE(i,k)+dtPBL(i,k) + $ - spread(i,k)*deltatw(i,k)-Tgw(i,k)*deltatw(i,k)) + ENDIF + + dth(i,k) = deltatw(i,k)/ppi(i,k) + + gg(i)=d_deltaqw(i,k)/dtimesub + + d_deltaqw(i,k) = dtimesub*(gg(i)+ dqKE(i,k)+dqPBL(i,k) + $ - spread(i,k)*deltaqw(i,k)) + + d_deltatw2(i,k)=d_deltatw2(i,k)+d_deltatw(i,k) + d_deltaqw2(i,k)=d_deltaqw2(i,k)+d_deltaqw(i,k) + ENDIF + ENDDO + ENDDO + +C +C Scale tendencies so that water vapour remains positive in w and x. +C + call wake_vec_modulation(klon,klev,wk_adv,qe,d_qe,deltaqw, + $ d_deltaqw,sigmaw,d_sigmaw,alpha) +c + DO k = 1,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN + d_te(i,k)=alpha(i)*d_te(i,k) + d_qe(i,k)=alpha(i)*d_qe(i,k) + d_deltatw(i,k)=alpha(i)*d_deltatw(i,k) + d_deltaqw(i,k)=alpha(i)*d_deltaqw(i,k) + d_deltat_gw(i,k)=alpha(i)*d_deltat_gw(i,k) + ENDIF + ENDDO + ENDDO + DO i = 1,klon + IF( wk_adv(i)) THEN + d_sigmaw(i)=alpha(i)*d_sigmaw(i) + ENDIF + ENDDO + +C Update large scale variables and wake variables +cIM 060208 manque DO i + remplace DO k=1,kupper(i) +cIM 060208 DO k = 1,kupper(i) + DO k= 1,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN + dtls(i,k)=dtls(i,k)+d_te(i,k) + dqls(i,k)=dqls(i,k)+d_qe(i,k) + ENDIF + ENDDO + ENDDO + DO k= 1,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN + te(i,k) = te0(i,k) + dtls(i,k) + qe(i,k) = qe0(i,k) + dqls(i,k) + the(i,k) = te(i,k)/ppi(i,k) + deltatw(i,k) = deltatw(i,k)+d_deltatw(i,k) + deltaqw(i,k) = deltaqw(i,k)+d_deltaqw(i,k) + dth(i,k) = deltatw(i,k)/ppi(i,k) + ENDIF + ENDDO + ENDDO + DO i = 1,klon + IF( wk_adv(i)) THEN + sigmaw(i) = sigmaw(i)+d_sigmaw(i) + ENDIF + ENDDO +c +C +c Determine Ptop from buoyancy integral +c --------------------------------------- +c +c- 1/ Pressure of the level where dth changes sign. +c + DO i=1,klon + IF ( wk_adv(i)) THEN + Ptop_provis(i)=ph(i,1) + ENDIF + ENDDO +c + DO k= 2,klev + DO i=1,klon + IF ( wk_adv(i) .AND. + $ Ptop_provis(i) .EQ. ph(i,1) .AND. + $ dth(i,k) .GT. -delta_t_min .and. + $ dth(i,k-1).LT. -delta_t_min) THEN + Ptop_provis(i) = ((dth(i,k)+delta_t_min)*p(i,k-1) + $ - (dth(i,k-1)+delta_t_min)*p(i,k)) /(dth(i,k) + $ - dth(i,k-1)) + ENDIF + ENDDO + ENDDO +c +c- 2/ dth integral +c + DO i=1,klon + sum_dth(i) = 0. + dthmin(i) = -delta_t_min + z(i) = 0. + ENDDO + + DO k = 1,klev + DO i=1,klon + IF ( wk_adv(i)) THEN + dz(i) = -(amax1(ph(i,k+1),Ptop_provis(i))-Ph(i,k))/(rho(i,k)*rg) + IF (dz(i) .gt. 0) THEN + z(i) = z(i)+dz(i) + sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i) + dthmin(i) = amin1(dthmin(i),dth(i,k)) + ENDIF + ENDIF + ENDDO + ENDDO +c +c- 3/ height of triangle with area= sum_dth and base = dthmin + + DO i=1,klon + IF ( wk_adv(i)) THEN + hw(i) = 2.*sum_dth(i)/amin1(dthmin(i),-0.5) + hw(i) = amax1(hwmin,hw(i)) + ENDIF + ENDDO +c +c- 4/ now, get Ptop +c + DO i=1,klon + ktop(i) = 0 + z(i)=0. + ENDDO +c + DO k = 1,klev + DO i=1,klon + IF ( wk_adv(i)) THEN + dz(i) = amin1(-(ph(i,k+1)-Ph(i,k))/(rho(i,k)*rg),hw(i)-z(i)) + IF (dz(i) .gt. 0) THEN + z(i) = z(i)+dz(i) + Ptop(i) = Ph(i,k)-rho(i,k)*rg*dz(i) + ktop(i) = k + ENDIF + ENDIF + ENDDO + ENDDO +c +c 4.5/Correct ktop and ptop +c + DO i=1,klon + IF ( wk_adv(i)) THEN + Ptop_new(i)=ptop(i) + ENDIF + ENDDO +c + DO k= klev,2,-1 + DO i=1,klon +cIM v3JYG; IF (k .GE. ktop(i) + IF ( wk_adv(i) .AND. + $ k .LE. ktop(i) .AND. + $ ptop_new(i) .EQ. ptop(i) .AND. + $ dth(i,k) .GT. -delta_t_min .and. + $ dth(i,k-1).LT. -delta_t_min) THEN + Ptop_new(i) = ((dth(i,k)+delta_t_min)*p(i,k-1) + $ - (dth(i,k-1)+delta_t_min)*p(i,k)) /(dth(i,k) + $ - dth(i,k-1)) + ENDIF + ENDDO + ENDDO +c +c + DO i=1,klon + IF ( wk_adv(i)) THEN + ptop(i) = ptop_new(i) + ENDIF + ENDDO + + DO k=klev,1,-1 + DO i=1,klon + IF (ph(i,k+1) .LT. ptop(i)) ktop(i)=k + ENDDO + ENDDO +c +c 5/ Set deltatw & deltaqw to 0 above kupper +c + DO k = 1,klev + DO i=1,klon + IF ( wk_adv(i) .AND. k .GE. kupper(i)) THEN + deltatw(i,k) = 0. + deltaqw(i,k) = 0. + ENDIF + ENDDO + ENDDO +c +C +c-------------Cstar computation--------------------------------- + DO i=1, klon + sum_thu(i) = 0. + sum_tu(i) = 0. + sum_qu(i) = 0. + sum_thvu(i) = 0. + sum_dth(i) = 0. + sum_dq(i) = 0. + sum_rho(i) = 0. + sum_dtdwn(i) = 0. + sum_dqdwn(i) = 0. + + av_thu(i) = 0. + av_tu(i) =0. + av_qu(i) =0. + av_thvu(i) = 0. + av_dth(i) = 0. + av_dq(i) = 0. + av_rho(i) =0. + av_dtdwn(i) =0. + av_dqdwn(i) = 0. + ENDDO +C +C Integrals (and wake top level number) +C -------------------------------------- +C +C Initialize sum_thvu to 1st level virt. pot. temp. + + DO i=1,klon + z(i) = 1. + dz(i) = 1. + sum_thvu(i) = thu(i,1)*(1.+eps*qu(i,1))*dz(i) + sum_dth(i) = 0. + ENDDO + + DO k = 1,klev + DO i=1,klon + dz(i) = -(max(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg) + IF (dz(i) .GT. 0) THEN + z(i) = z(i)+dz(i) + sum_thu(i) = sum_thu(i) + th1(i,k)*dz(i) + sum_tu(i) = sum_tu(i) + t1(i,k)*dz(i) + sum_qu(i) = sum_qu(i) + q1(i,k)*dz(i) + sum_thvu(i) = sum_thvu(i) + th1(i,k)*(1.+eps*q1(i,k))*dz(i)!itlmd + + sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i) + sum_dq(i) = sum_dq(i) + deltaqw(i,k)*dz(i) + sum_rho(i) = sum_rho(i) + rhow(i,k)*dz(i) + sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i,k)*dz(i) + sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i,k)*dz(i) + ENDIF + ENDDO + ENDDO +c + DO i=1,klon + hw0(i) = z(i) + ENDDO +c +C +C - WAPE and mean forcing computation +C --------------------------------------- +C +C --------------------------------------- +C +C Means + + DO i=1,klon + av_thu(i) = sum_thu(i)/hw0(i) + av_tu(i) = sum_tu(i)/hw0(i) + av_qu(i) = sum_qu(i)/hw0(i) + av_thvu(i) = sum_thvu(i)/hw0(i) + av_dth(i) = sum_dth(i)/hw0(i) + av_dq(i) = sum_dq(i)/hw0(i) + av_rho(i) = sum_rho(i)/hw0(i) + av_dtdwn(i) = sum_dtdwn(i)/hw0(i) + av_dqdwn(i) = sum_dqdwn(i)/hw0(i) +c + wape(i) = - rg*hw0(i)*(av_dth(i) + $ + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)+av_dth(i)* + $ av_dq(i) ))/av_thvu(i) + ENDDO +C +C Filter out bad wakes + + DO k = 1,klev + DO i=1,klon + IF ( wape(i) .LT. 0.) THEN + deltatw(i,k) = 0. + deltaqw(i,k) = 0. + dth(i,k) = 0. + ENDIF + ENDDO + ENDDO +c + DO i=1,klon + IF ( wape(i) .LT. 0.) THEN + wape(i) = 0. + Cstar(i) = 0. + hw(i) = hwmin + sigmaw(i) = max(sigmad,sigd_con(i)) + fip(i) = 0. + gwake(i) = .FALSE. + ELSE + Cstar(i) = stark*sqrt(2.*wape(i)) + gwake(i) = .TRUE. + ENDIF + ENDDO + + ENDDO ! end sub-timestep loop +C +C ----------------------------------------------------------------- +c Get back to tendencies per second +c + DO k = 1,klev + DO i=1,klon + IF ( wk_adv(i) .AND. k .LE. kupper(i)) THEN !! corr conservation eau + dtls(i,k) = dtls(i,k)/dtime + dqls(i,k) = dqls(i,k)/dtime + d_deltatw2(i,k)=d_deltatw2(i,k)/dtime + d_deltaqw2(i,k)=d_deltaqw2(i,k)/dtime + d_deltat_gw(i,k) = d_deltat_gw(i,k)/dtime + ENDIF + ENDDO + ENDDO +c +c +c---------------------------------------------------------- +c Determine wake final state; recompute wape, cstar, ktop; +c filter out bad wakes. +c---------------------------------------------------------- +c +C 2.1 - Undisturbed area and Wake integrals +C --------------------------------------------------------- + + DO i=1,klon + z(i) = 0. + sum_thu(i) = 0. + sum_tu(i) = 0. + sum_qu(i) = 0. + sum_thvu(i) = 0. + sum_dth(i) = 0. + sum_dq(i) = 0. + sum_rho(i) = 0. + sum_dtdwn(i) = 0. + sum_dqdwn(i) = 0. + + av_thu(i) = 0. + av_tu(i) =0. + av_qu(i) =0. + av_thvu(i) = 0. + av_dth(i) = 0. + av_dq(i) = 0. + av_rho(i) =0. + av_dtdwn(i) =0. + av_dqdwn(i) = 0. + ENDDO +C Potential temperatures and humidity +c---------------------------------------------------------- + + DO k =1,klev + DO i=1,klon + IF ( wk_adv(i)) THEN + rho(i,k) = p(i,k)/(rd*te(i,k)) + IF(k .eq. 1) THEN + rhoh(i,k) = ph(i,k)/(rd*te(i,k)) + zhh(i,k)=0 + ELSE + rhoh(i,k) = ph(i,k)*2./(rd*(te(i,k)+te(i,k-1))) + zhh(i,k)=(ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG)+zhh(i,k-1) + ENDIF + the(i,k) = te(i,k)/ppi(i,k) + thu(i,k) = (te(i,k) - deltatw(i,k)*sigmaw(i))/ppi(i,k) + tu(i,k) = te(i,k) - deltatw(i,k)*sigmaw(i) + qu(i,k) = qe(i,k) - deltaqw(i,k)*sigmaw(i) + rhow(i,k) = p(i,k)/(rd*(tu(i,k)+deltatw(i,k))) + dth(i,k) = deltatw(i,k)/ppi(i,k) + ENDIF + ENDDO + ENDDO + +C Integrals (and wake top level number) +C ----------------------------------------------------------- + +C Initialize sum_thvu to 1st level virt. pot. temp. + + DO i=1,klon + IF ( wk_adv(i)) THEN + z(i) = 1. + dz(i) = 1. + sum_thvu(i) = thu(i,1)*(1.+eps*qu(i,1))*dz(i) + sum_dth(i) = 0. + ENDIF + ENDDO + + DO k = 1,klev + DO i=1,klon + IF ( wk_adv(i)) THEN + dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg) + IF (dz(i) .GT. 0) THEN + z(i) = z(i)+dz(i) + sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i) + sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i) + sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i) + sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(i,k))*dz(i) + sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i) + sum_dq(i) = sum_dq(i) + deltaqw(i,k)*dz(i) + sum_rho(i) = sum_rho(i) + rhow(i,k)*dz(i) + sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i,k)*dz(i) + sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i,k)*dz(i) + ENDIF + ENDIF + ENDDO + ENDDO +c + DO i=1,klon + IF ( wk_adv(i)) THEN + hw0(i) = z(i) + ENDIF + ENDDO +c +C - WAPE and mean forcing computation +C------------------------------------------------------------- + +C Means + + DO i=1, klon + IF ( wk_adv(i)) THEN + av_thu(i) = sum_thu(i)/hw0(i) + av_tu(i) = sum_tu(i)/hw0(i) + av_qu(i) = sum_qu(i)/hw0(i) + av_thvu(i) = sum_thvu(i)/hw0(i) + av_dth(i) = sum_dth(i)/hw0(i) + av_dq(i) = sum_dq(i)/hw0(i) + av_rho(i) = sum_rho(i)/hw0(i) + av_dtdwn(i) = sum_dtdwn(i)/hw0(i) + av_dqdwn(i) = sum_dqdwn(i)/hw0(i) + + wape2(i) = - rg*hw0(i)*(av_dth(i) + $ + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)+ + $ av_dth(i)*av_dq(i) ))/av_thvu(i) + ENDIF + ENDDO + +C Prognostic variable update +C ------------------------------------------------------------ + +C Filter out bad wakes +c + DO k = 1,klev + DO i=1,klon + IF ( wk_adv(i) .AND. wape2(i) .LT. 0.) THEN + deltatw(i,k) = 0. + deltaqw(i,k) = 0. + dth(i,k) = 0. + ENDIF + ENDDO + ENDDO +c + + DO i=1, klon + IF ( wk_adv(i)) THEN + IF ( wape2(i) .LT. 0.) THEN + wape2(i) = 0. + Cstar2(i) = 0. + hw(i) = hwmin + sigmaw(i) = amax1(sigmad,sigd_con(i)) + fip(i) = 0. + gwake(i) = .FALSE. + ELSE + if(prt_level.ge.10) print*,'wape2>0' + Cstar2(i) = stark*sqrt(2.*wape2(i)) + gwake(i) = .TRUE. + ENDIF + ENDIF + ENDDO +c + DO i=1, klon + IF ( wk_adv(i)) THEN + ktopw(i) = ktop(i) + ENDIF + ENDDO +c + DO i=1, klon + IF ( wk_adv(i)) THEN + IF (ktopw(i) .gt. 0 .and. gwake(i)) then + +Cjyg1 Utilisation d'un h_efficace constant ( ~ feeding layer) +ccc heff = 600. +C Utilisation de la hauteur hw +cc heff = 0.7*hw + heff(i) = hw(i) + + FIP(i) = 0.5*rho(i,ktopw(i))*Cstar2(i)**3*heff(i)*2* + $ sqrt(sigmaw(i)*wdens*3.14) + FIP(i) = alpk * FIP(i) +Cjyg2 + ELSE + FIP(i) = 0. + ENDIF + ENDIF + ENDDO +c +C Limitation de sigmaw +c +C sécurité : si le wake occuppe plus de 90 % de la surface de la maille, +C alors il disparait en se mélangeant à la partie undisturbed +c + sigmaw_max = 0.9 + DO k = 1,klev + DO i=1, klon +c correction NICOLAS $ ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0))) THEN +! print*,'wape wape2 ktopw OK_qx_qw =', +! $ wape(i),wape2(i),ktopw(i),OK_qx_qw(i) + IF ((sigmaw(i).GT.sigmaw_max).or. + $ ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0)).or. + $ (ktopw(i).le.2) .OR. + $ .not. OK_qx_qw(i)) THEN +cIM cf NR/JYG 251108 $ ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0))) THEN +ccc IF (sigmaw(i).GT.0.9) THEN + dtls(i,k) = 0. + dqls(i,k) = 0. + deltatw(i,k) = 0. + deltaqw(i,k) = 0. + ENDIF + ENDDO + ENDDO +c + DO i=1, klon + IF ( (sigmaw(i).GT.sigmaw_max).or. + $ ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0)).or. + $ (ktopw(i).le.2) .OR. + $ .not. OK_qx_qw(i)) THEN +! correction NICOLAS $ ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0))) THEN +ccc IF (sigmaw(i).GT.0.9) THEN + wape(i) = 0. + cstar(i)= 0. !!corr itlmd + hw(i) = hwmin + sigmaw(i) = sigmad + fip(i) = 0. + ELSE + wape(i) = wape2(i) + cstar(i)= cstar2(i) !!corr itlmd + ENDIF + ENDDO +c +c + RETURN + END + + SUBROUTINE wake_vec_modulation(nlon,nl,wk_adv,qe,d_qe, + $ deltaqw,d_deltaqw,sigmaw,d_sigmaw,alpha) +c------------------------------------------------------ +cDtermination du coefficient alpha tel que les tendances +c corriges alpha*d_G, pour toutes les grandeurs G, correspondent +c a une humidite positive dans la zone (x) et dans la zone (w). +c------------------------------------------------------ +c + +c Input + REAL qe(nlon,nl),d_qe(nlon,nl) + REAL deltaqw(nlon,nl),d_deltaqw(nlon,nl) + REAL sigmaw(nlon),d_sigmaw(nlon) + LOGICAL wk_adv(nlon) + INTEGER nl,nlon +c Output + REAL alpha(nlon) +c Internal variables + REAL alpha1(nlon) + REAL x,a,b,c,discrim,zeta(nlon) + REAL epsilon + DATA epsilon/1.e-15/ +c + DO k=1,nl + DO i = 1,nlon + IF (wk_adv(i)) THEN + IF ((deltaqw(i,k)+d_deltaqw(i,k)).ge.0.) then + zeta(i)=0. + ELSE + zeta(i)=1. + END IF + ENDIF + ENDDO + DO i = 1,nlon + IF (wk_adv(i)) THEN + x = qe(i,k)+(zeta(i)-sigmaw(i))*deltaqw(i,k) + $ +d_qe(i,k)+(zeta(i)-sigmaw(i))*d_deltaqw(i,k) + $ -d_sigmaw(i)*(deltaqw(i,k)+d_deltaqw(i,k)) + a=-d_sigmaw(i)*d_deltaqw(i,k) + b=d_qe(i,k)+(zeta(i)-sigmaw(i))*d_deltaqw(i,k) + $ -deltaqw(i,k)*d_sigmaw(i) + c=qe(i,k)+(zeta(i)-sigmaw(i))*deltaqw(i,k)-epsilon +! c=qe(i,k)+(zeta(i)-sigmaw(i))*deltaqw(i,k) + + discrim=b*b-4.*a*c +! print*,'ZETA *********************' +! print*,'zeta sigmaw ',zeta(:) +! print*,'SIGMA *********************' +! print*,'sigmaw ',sigmaw(:) + +! print*,' x ************************' +! print*,'x ',x +! print*,' a+b ************************' +! print*,'a+b ',a+b + +! print*,'a b c delta zeta ',a,b,c,discrim + IF (a+b .GE. 0.) THEN + alpha1(i)=1. + ELSE + IF (x .GE. 0.) THEN + alpha1(i)=1. + ELSE +! IF (a .GE. 0.) THEN + IF (a .GT. 0.) THEN +! print*,'a b c delta zeta ',a,b,c,discrim,zeta(i) +! print*,'-b+sqrt(discrim) ',-b+sqrt(discrim) + alpha1(i)=0.9*min( (2.*c)/(-b+sqrt(discrim)), + $ (-b+sqrt(discrim))/(2.*a) ) + ELSE IF (a.eq.0.) THEN + alpha1(i)=0.9*(-c/b) + ELSE +! print*,'a b c delta zeta ',a,b,c,discrim,zeta(i) +! print*,'-b+sqrt(discrim) ',-b+sqrt(discrim) + alpha1(i)=0.9*max( (2.*c)/(-b+sqrt(discrim)), + $ (-b+sqrt(discrim))/(2.*a) ) + ENDIF + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO +c + DO i = 1,nlon + IF (wk_adv(i)) THEN + alpha(i) = min(alpha(i),alpha1(i)) + ENDIF + ENDDO +c + return + end + + Subroutine WAKE_scal (p,ph,ppi,dtime,sigd_con + : ,te0,qe0,omgb + : ,dtdwn,dqdwn,amdwn,amup,dta,dqa + : ,wdtPBL,wdqPBL,udtPBL,udqPBL + o ,deltatw,deltaqw,dth,hw,sigmaw,wape,fip,gfl + o ,dtls,dqls + o ,ktopw,omgbdth,dp_omgb,wdens + o ,tu,qu + o ,dtKE,dqKE + o ,dtPBL,dqPBL + o ,omg,dp_deltomg,spread + o ,Cstar,d_deltat_gw + o ,d_deltatw2,d_deltaqw2) + +*************************************************************** +* * +* WAKE * +* retour a un Pupper fixe * +* * +* written by : GRANDPEIX Jean-Yves 09/03/2000 * +* modified by : ROEHRIG Romain 01/29/2007 * +*************************************************************** +c + USE dimphy + IMPLICIT none +c============================================================================ +C +C +C But : Decrire le comportement des poches froides apparaissant dans les +C grands systemes convectifs, et fournir l'energie disponible pour +C le declenchement de nouvelles colonnes convectives. +C +C Variables d'etat : deltatw : ecart de temperature wake-undisturbed area +C deltaqw : ecart d'humidite wake-undisturbed area +C sigmaw : fraction d'aire occupee par la poche. +C +C Variable de sortie : +c +c wape : WAke Potential Energy +c fip : Front Incident Power (W/m2) - ALP +c gfl : Gust Front Length per unit area (m-1) +C dtls : large scale temperature tendency due to wake +C dqls : large scale humidity tendency due to wake +C hw : hauteur de la poche +C dp_omgb : vertical gradient of large scale omega +C omgbdth: flux of Delta_Theta transported by LS omega +C dtKE : differential heating (wake - unpertubed) +C dqKE : differential moistening (wake - unpertubed) +C omg : Delta_omg =vertical velocity diff. wake-undist. (Pa/s) +C dp_deltomg : vertical gradient of omg (s-1) +C spread : spreading term in dt_wake and dq_wake +C deltatw : updated temperature difference (T_w-T_u). +C deltaqw : updated humidity difference (q_w-q_u). +C sigmaw : updated wake fractional area. +C d_deltat_gw : delta T tendency due to GW +c +C Variables d'entree : +c +c aire : aire de la maille +c te0 : temperature dans l'environnement (K) +C qe0 : humidite dans l'environnement (kg/kg) +C omgb : vitesse verticale moyenne sur la maille (Pa/s) +C dtdwn: source de chaleur due aux descentes (K/s) +C dqdwn: source d'humidite due aux descentes (kg/kg/s) +C dta : source de chaleur due courants satures et detrain (K/s) +C dqa : source d'humidite due aux courants satures et detra (kg/kg/s) +C amdwn: flux de masse total des descentes, par unite de +C surface de la maille (kg/m2/s) +C amup : flux de masse total des ascendances, par unite de +C surface de la maille (kg/m2/s) +C p : pressions aux milieux des couches (Pa) +C ph : pressions aux interfaces (Pa) +C ppi : (p/p_0)**kapa (adim) +C dtime: increment temporel (s) +c +C Variables internes : +c +c rhow : masse volumique de la poche froide +C rho : environment density at P levels +C rhoh : environment density at Ph levels +C te : environment temperature | may change within +C qe : environment humidity | sub-time-stepping +C the : environment potential temperature +C thu : potential temperature in undisturbed area +C tu : temperature in undisturbed area +C qu : humidity in undisturbed area +C dp_omgb: vertical gradient og LS omega +C omgbw : wake average vertical omega +C dp_omgbw: vertical gradient of omgbw +C omgbdq : flux of Delta_q transported by LS omega +C dth : potential temperature diff. wake-undist. +C th1 : first pot. temp. for vertical advection (=thu) +C th2 : second pot. temp. for vertical advection (=thw) +C q1 : first humidity for vertical advection +C q2 : second humidity for vertical advection +C d_deltatw : terme de redistribution pour deltatw +C d_deltaqw : terme de redistribution pour deltaqw +C deltatw0 : deltatw initial +C deltaqw0 : deltaqw initial +C hw0 : hw initial +C sigmaw0: sigmaw initial +C amflux : horizontal mass flux through wake boundary +C wdens : number of wakes per unit area (3D) or per +C unit length (2D) +C Tgw : 1 sur la période de onde de gravité +c Cgw : vitesse de propagation de onde de gravité +c LL : distance entre 2 poches + +c------------------------------------------------------------------------- +c Déclaration de variables +c------------------------------------------------------------------------- + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" +#include "cvthermo.h" +#include "iniprint.h" + +c Arguments en entree +c-------------------- + + REAL p(klev),ph(klev+1),ppi(klev) + REAL dtime + REAL te0(klev),qe0(klev) + REAL omgb(klev+1) + REAL dtdwn(klev), dqdwn(klev) + REAL wdtPBL(klev),wdqPBL(klev) + REAL udtPBL(klev),udqPBL(klev) + REAL amdwn(klev), amup(klev) + REAL dta(klev), dqa(klev) + REAL sigd_con + +c Sorties +c-------- + + REAL deltatw(klev), deltaqw(klev), dth(klev) + REAL tu(klev), qu(klev) + REAL dtls(klev), dqls(klev) + REAL dtKE(klev), dqKE(klev) + REAL dtPBL(klev), dqPBL(klev) + REAL spread(klev) + REAL d_deltatgw(klev) + REAL d_deltatw2(klev), d_deltaqw2(klev) + REAL omgbdth(klev+1), omg(klev+1) + REAL dp_omgb(klev), dp_deltomg(klev) + REAL d_deltat_gw(klev) + REAL hw, sigmaw, wape, fip, gfl, Cstar + INTEGER ktopw + +c Variables internes +c------------------- + +c Variables à fixer + REAL ALON + REAL coefgw + REAL wdens0, wdens + REAL stark + REAL alpk + REAL delta_t_min + REAL Pupper + INTEGER nsub + REAL dtimesub + REAL sigmad, hwmin + +c Variables de sauvegarde + REAL deltatw0(klev) + REAL deltaqw0(klev) + REAL te(klev), qe(klev) + REAL sigmaw0, sigmaw1 + +c Variables pour les GW + REAL LL + REAL N2(klev) + REAL Cgw(klev) + REAL Tgw(klev) + +c Variables liées au calcul de hw + REAL ptop_provis, ptop, ptop_new + REAL sum_dth + REAL dthmin + REAL z, dz, hw0 + INTEGER ktop, kupper + +c Autres variables internes + INTEGER isubstep, k + + REAL sum_thu, sum_tu, sum_qu,sum_thvu + REAL sum_dq, sum_rho + REAL sum_dtdwn, sum_dqdwn + REAL av_thu, av_tu, av_qu, av_thvu + REAL av_dth, av_dq, av_rho + REAL av_dtdwn, av_dqdwn + + REAL rho(klev), rhoh(klev+1), rhow(klev) + REAL rhow_moyen(klev) + REAL zh(klev), zhh(klev+1) + REAL epaisseur1(klev), epaisseur2(klev) + + REAL the(klev), thu(klev) + + REAL d_deltatw(klev), d_deltaqw(klev) + + REAL omgbw(klev+1), omgtop + REAL dp_omgbw(klev) + REAL ztop, dztop + REAL alpha_up(klev) + + REAL RRe1, RRe2, RRd1, RRd2 + REAL Th1(klev), Th2(klev), q1(klev), q2(klev) + REAL D_Th1(klev), D_Th2(klev), D_dth(klev) + REAL D_q1(klev), D_q2(klev), D_dq(klev) + REAL omgbdq(klev) + + REAL ff, gg + REAL wape2, Cstar2, heff + + REAL Crep(klev) + REAL Crep_upper, Crep_sol + +C------------------------------------------------------------------------- +c Initialisations +c------------------------------------------------------------------------- + +c print*, 'wake initialisations' + +c Essais d'initialisation avec sigmaw = 0.02 et hw = 10. +c------------------------------------------------------------------------- + + DATA sigmad, hwmin /.02,10./ + +C Longueur de maille (en m) +c------------------------------------------------------------------------- + +c ALON = 3.e5 + ALON = 1.e6 + + +C Configuration de coefgw,stark,wdens (22/02/06 by YU Jingmei) +c +c coefgw : Coefficient pour les ondes de gravité +c stark : Coefficient k dans Cstar=k*sqrt(2*WAPE) +c wdens : Densité de poche froide par maille +c------------------------------------------------------------------------- + + coefgw=10 +c coefgw=1 +c wdens0 = 1.0/(alon**2) + wdens = 1.0/(alon**2) + stark = 0.50 +cCRtest + alpk=0.1 +c alpk = 1.0 +c alpk = 0.5 +c alpk = 0.05 + Crep_upper=0.9 + Crep_sol=1.0 + + +C Minimum value for |T_wake - T_undist|. Used for wake top definition +c------------------------------------------------------------------------- + + delta_t_min = 0.2 + + +C 1. - Save initial values and initialize tendencies +C -------------------------------------------------- + + DO k=1,klev + deltatw0(k) = deltatw(k) + deltaqw0(k)= deltaqw(k) + te(k) = te0(k) + qe(k) = qe0(k) + dtls(k) = 0. + dqls(k) = 0. + d_deltat_gw(k)=0. + d_deltatw2(k)=0. + d_deltaqw2(k)=0. + ENDDO +c sigmaw1=sigmaw +c IF (sigd_con.GT.sigmaw1) THEN +c print*, 'sigmaw,sigd_con', sigmaw, sigd_con +c ENDIF + sigmaw = max(sigmaw,sigd_con) + sigmaw = max(sigmaw,sigmad) + sigmaw = min(sigmaw,0.99) + sigmaw0 = sigmaw +c wdens=wdens0/(10.*sigmaw) +c IF (sigd_con.GT.sigmaw1) THEN +c print*, 'sigmaw1,sigd1', sigmaw, sigd_con +c ENDIF + +C 2. - Prognostic part +C ========================================================= + +c print *, 'prognostic wake computation' + + +C 2.1 - Undisturbed area and Wake integrals +C --------------------------------------------------------- + + z = 0. + ktop=0 + kupper = 0 + sum_thu = 0. + sum_tu = 0. + sum_qu = 0. + sum_thvu = 0. + sum_dth = 0. + sum_dq = 0. + sum_rho = 0. + sum_dtdwn = 0. + sum_dqdwn = 0. + + av_thu = 0. + av_tu =0. + av_qu =0. + av_thvu = 0. + av_dth = 0. + av_dq = 0. + av_rho =0. + av_dtdwn =0. + av_dqdwn = 0. + +C Potential temperatures and humidity +c---------------------------------------------------------- + + DO k =1,klev + rho(k) = p(k)/(rd*te(k)) + IF(k .eq. 1) THEN + rhoh(k) = ph(k)/(rd*te(k)) + zhh(k)=0 + ELSE + rhoh(k) = ph(k)*2./(rd*(te(k)+te(k-1))) + zhh(k)=(ph(k)-ph(k-1))/(-rhoh(k)*RG)+zhh(k-1) + ENDIF + the(k) = te(k)/ppi(k) + thu(k) = (te(k) - deltatw(k)*sigmaw)/ppi(k) + tu(k) = te(k) - deltatw(k)*sigmaw + qu(k) = qe(k) - deltaqw(k)*sigmaw + rhow(k) = p(k)/(rd*(te(k)+deltatw(k))) + dth(k) = deltatw(k)/ppi(k) + LL = (1-sqrt(sigmaw))/sqrt(wdens) + ENDDO + + DO k = 1, klev-1 + IF(k.eq.1) THEN + N2(k)=0 + ELSE + N2(k)=max(0.,-RG**2/the(k)*rho(k)*(the(k+1)-the(k-1)) + $ /(p(k+1)-p(k-1))) + ENDIF + ZH(k)=(zhh(k)+zhh(k+1))/2 + + Cgw(k)=sqrt(N2(k))*ZH(k) + Tgw(k)=coefgw*Cgw(k)/LL + ENDDO + + N2(klev)=0 + ZH(klev)=0 + Cgw(klev)=0 + Tgw(klev)=0 + +c Calcul de la masse volumique moyenne de la colonne +c----------------------------------------------------------------- + + DO k=1,klev + epaisseur1(k)=0. + epaisseur2(k)=0. + ENDDO + + epaisseur1(1)= -(Ph(2)-Ph(1))/(rho(1)*rg)+1. + epaisseur2(1)= -(Ph(2)-Ph(1))/(rho(1)*rg)+1. + rhow_moyen(1) = rhow(1) + + DO k = 2, klev + epaisseur1(k)= -(Ph(k+1)-Ph(k))/(rho(k)*rg) +1. + epaisseur2(k)=epaisseur2(k-1)+epaisseur1(k) + rhow_moyen(k) = (rhow_moyen(k-1)*epaisseur2(k-1)+ + $ rhow(k)*epaisseur1(k))/epaisseur2(k) + ENDDO + + +C Choose an integration bound well above wake top +c----------------------------------------------------------------- + +c Pupper = 50000. ! melting level + Pupper = 60000. +c Pupper = 70000. + + +C Determine Wake top pressure (Ptop) from buoyancy integral +C----------------------------------------------------------------- + +c-1/ Pressure of the level where dth becomes less than delta_t_min. + + Ptop_provis=ph(1) + DO k= 2,klev + IF (dth(k) .GT. -delta_t_min .and. + $ dth(k-1).LT. -delta_t_min) THEN + Ptop_provis = ((dth(k)+delta_t_min)*p(k-1) + $ - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1)) + GO TO 25 + ENDIF + ENDDO +25 CONTINUE + +c-2/ dth integral + + sum_dth = 0. + dthmin = -delta_t_min + z = 0. + + DO k = 1,klev + dz = -(max(ph(k+1),Ptop_provis)-Ph(k))/(rho(k)*rg) + IF (dz .le. 0) GO TO 40 + z = z+dz + sum_dth = sum_dth + dth(k)*dz + dthmin = min(dthmin,dth(k)) + ENDDO +40 CONTINUE + +c-3/ height of triangle with area= sum_dth and base = dthmin + + hw0 = 2.*sum_dth/min(dthmin,-0.5) + hw0 = max(hwmin,hw0) + +c-4/ now, get Ptop + + z = 0. + ptop = ph(1) + + DO k = 1,klev + dz = min(-(ph(k+1)-Ph(k))/(rho(k)*rg),hw0-z) + IF (dz .le. 0) GO TO 45 + z = z+dz + Ptop = Ph(k)-rho(k)*rg*dz + ENDDO +45 CONTINUE + + +C-5/ Determination de ktop et kupper + + DO k=klev,1,-1 + IF (ph(k+1) .lt. ptop) ktop=k + IF (ph(k+1) .lt. pupper) kupper=k + ENDDO + +c-6/ Correct ktop and ptop + + Ptop_new=ptop + DO k= ktop,2,-1 + IF (dth(k) .GT. -delta_t_min .and. + $ dth(k-1).LT. -delta_t_min) THEN + Ptop_new = ((dth(k)+delta_t_min)*p(k-1) + $ - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1)) + GO TO 225 + ENDIF + ENDDO +225 CONTINUE + + ptop = ptop_new + + DO k=klev,1,-1 + IF (ph(k+1) .lt. ptop) ktop=k + ENDDO + +c Set deltatw & deltaqw to 0 above kupper +c----------------------------------------------------------- + + DO k = kupper,klev + deltatw(k) = 0. + deltaqw(k) = 0. + ENDDO + + +C Vertical gradient of LS omega +C------------------------------------------------------------ + + DO k = 1,kupper + dp_omgb(k) = (omgb(k+1) - omgb(k))/(ph(k+1)-ph(k)) + ENDDO + + +C Integrals (and wake top level number) +C ----------------------------------------------------------- + +C Initialize sum_thvu to 1st level virt. pot. temp. + + z = 1. + dz = 1. + sum_thvu = thu(1)*(1.+eps*qu(1))*dz + sum_dth = 0. + + DO k = 1,klev + dz = -(max(ph(k+1),Ptop)-Ph(k))/(rho(k)*rg) + IF (dz .LE. 0) GO TO 50 + z = z+dz + sum_thu = sum_thu + thu(k)*dz + sum_tu = sum_tu + tu(k)*dz + sum_qu = sum_qu + qu(k)*dz + sum_thvu = sum_thvu + thu(k)*(1.+eps*qu(k))*dz + sum_dth = sum_dth + dth(k)*dz + sum_dq = sum_dq + deltaqw(k)*dz + sum_rho = sum_rho + rhow(k)*dz + sum_dtdwn = sum_dtdwn + dtdwn(k)*dz + sum_dqdwn = sum_dqdwn + dqdwn(k)*dz + ENDDO +50 CONTINUE + + hw0 = z + +C 2.1 - WAPE and mean forcing computation +C------------------------------------------------------------- + +C Means + + av_thu = sum_thu/hw0 + av_tu = sum_tu/hw0 + av_qu = sum_qu/hw0 + av_thvu = sum_thvu/hw0 +c av_thve = sum_thve/hw0 + av_dth = sum_dth/hw0 + av_dq = sum_dq/hw0 + av_rho = sum_rho/hw0 + av_dtdwn = sum_dtdwn/hw0 + av_dqdwn = sum_dqdwn/hw0 + + wape = - rg*hw0*(av_dth + $ + eps*(av_thu*av_dq+av_dth*av_qu+av_dth*av_dq ))/av_thvu + +C 2.2 Prognostic variable update +C ------------------------------------------------------------ + +C Filter out bad wakes + + IF ( wape .LT. 0.) THEN + if(prt_level.ge.10) print*,'wape<0' + wape = 0. + hw = hwmin + sigmaw = max(sigmad,sigd_con) + fip = 0. + DO k = 1,klev + deltatw(k) = 0. + deltaqw(k) = 0. + dth(k) = 0. + ENDDO + ELSE + if(prt_level.ge.10) print*,'wape>0' + Cstar = stark*sqrt(2.*wape) + ENDIF + +C------------------------------------------------------------------ +C Sub-time-stepping +C------------------------------------------------------------------ + +c nsub=36 + nsub=10 + dtimesub=dtime/nsub + +c------------------------------------------------------------ + DO isubstep = 1,nsub +c------------------------------------------------------------ + +c print*,'---------------','substep=',isubstep,'-------------' + +c Evolution of sigmaw + + + gfl = 2.*sqrt(3.14*wdens*sigmaw) + + sigmaw =sigmaw + gfl*Cstar*dtimesub + sigmaw =min(sigmaw,0.99) !!!!!!!! +c wdens = wdens0/(10.*sigmaw) +c sigmaw =max(sigmaw,sigd_con) +c sigmaw =max(sigmaw,sigmad) + +c calcul de la difference de vitesse verticale poche - zone non perturbee + + z= 0. + dp_deltomg(1:klev)=0. + omg(1:klev+1)=0. + + omg(1) = 0. + dp_deltomg(1) = -(gfl*Cstar)/(sigmaw * (1-sigmaw)) + + DO k=2,ktop + dz = -(Ph(k)-Ph(k-1))/(rho(k-1)*rg) + z = z+dz + dp_deltomg(k)= dp_deltomg(1) + omg(k)= dp_deltomg(1)*z + ENDDO + + dztop=-(Ptop-Ph(ktop))/(rho(ktop)*rg) + ztop = z+dztop + omgtop=dp_deltomg(1)*ztop + + +c Conversion de la vitesse verticale de m/s a Pa/s + + omgtop = -rho(ktop)*rg*omgtop + dp_deltomg(1) = omgtop/(ptop-ph(1)) + + DO k = 1,ktop + omg(k) = - rho(k)*rg*omg(k) + dp_deltomg(k) = dp_deltomg(1) + ENDDO + +c raccordement lineaire de omg de ptop a pupper + + IF (kupper .GT. ktop) THEN + omg(kupper+1) = - Rg*amdwn(kupper+1)/sigmaw + $ + Rg*amup(kupper+1)/(1.-sigmaw) + dp_deltomg(kupper) = (omgtop-omg(kupper+1))/(Ptop-Pupper) + DO k=ktop+1,kupper + dp_deltomg(k) = dp_deltomg(kupper) + omg(k) = omgtop+(ph(k)-Ptop)*dp_deltomg(kupper) + ENDDO + ENDIF + +c Compute wake average vertical velocity omgbw + + DO k = 1,klev+1 + omgbw(k) = omgb(k)+(1.-sigmaw)*omg(k) + ENDDO + +c and its vertical gradient dp_omgbw + + DO k = 1,klev + dp_omgbw(k) = (omgbw(k+1)-omgbw(k))/(ph(k+1)-ph(k)) + ENDDO + + +c Upstream coefficients for omgb velocity +c-- (alpha_up(k) is the coefficient of the value at level k) +c-- (1-alpha_up(k) is the coefficient of the value at level k-1) + + DO k = 1,klev + alpha_up(k) = 0. + IF (omgb(k) .GT. 0.) alpha_up(k) = 1. + ENDDO + +c Matrix expressing [The,deltatw] from [Th1,Th2] + + RRe1 = 1.-sigmaw + RRe2 = sigmaw + RRd1 = -1. + RRd2 = 1. + +c Get [Th1,Th2], dth and [q1,q2] + + DO k = 1,kupper+1 + dth(k) = deltatw(k)/ppi(k) + Th1(k) = the(k) - sigmaw *dth(k) ! undisturbed area + Th2(k) = the(k) + (1.-sigmaw)*dth(k) ! wake + q1(k) = qe(k) - sigmaw *deltaqw(k) ! undisturbed area + q2(k) = qe(k) + (1.-sigmaw)*deltaqw(k) ! wake + ENDDO + + D_Th1(1) = 0. + D_Th2(1) = 0. + D_dth(1) = 0. + D_q1(1) = 0. + D_q2(1) = 0. + D_dq(1) = 0. + + DO k = 2,kupper+1 ! loop on interfaces + D_Th1(k) = Th1(k-1)-Th1(k) + D_Th2(k) = Th2(k-1)-Th2(k) + D_dth(k) = dth(k-1)-dth(k) + D_q1(k) = q1(k-1)-q1(k) + D_q2(k) = q2(k-1)-q2(k) + D_dq(k) = deltaqw(k-1)-deltaqw(k) + ENDDO + + omgbdth(1) = 0. + omgbdq(1) = 0. + + DO k = 2,kupper+1 ! loop on interfaces + omgbdth(k) = omgb(k)*( dth(k-1) - dth(k)) + omgbdq(k) = omgb(k)*(deltaqw(k-1) - deltaqw(k)) + ENDDO + + +c----------------------------------------------------------------- + DO k=1,kupper-1 +c----------------------------------------------------------------- +c +c Compute redistribution (advective) term +c + d_deltatw(k) = + $ dtimesub/(Ph(k)-Ph(k+1))*( + $ RRd1*omg(k )*sigmaw *D_Th1(k) + $ -RRd2*omg(k+1)*(1.-sigmaw)*D_Th2(k+1) + $ -(1.-alpha_up(k))*omgbdth(k) - alpha_up(k+1)*omgbdth(k+1) + $ )*ppi(k) +c print*,'d_deltatw=',d_deltatw(k) +c + d_deltaqw(k) = + $ dtimesub/(Ph(k)-Ph(k+1))*( + $ RRd1*omg(k )*sigmaw *D_q1(k) + $ -RRd2*omg(k+1)*(1.-sigmaw)*D_q2(k+1) + $ -(1.-alpha_up(k))*omgbdq(k) - alpha_up(k+1)*omgbdq(k+1) + $ ) +c print*,'d_deltaqw=',d_deltaqw(k) +c +c and increment large scale tendencies +c + dtls(k) = dtls(k) + + $ dtimesub*( + $ ( RRe1*omg(k )*sigmaw *D_Th1(k) + $ -RRe2*omg(k+1)*(1.-sigmaw)*D_Th2(k+1) ) + $ /(Ph(k)-Ph(k+1)) + $ -sigmaw*(1.-sigmaw)*dth(k)*dp_deltomg(k) + $ )*ppi(k) +c print*,'dtls=',dtls(k) +c + dqls(k) = dqls(k) + + $ dtimesub*( + $ ( RRe1*omg(k )*sigmaw *D_q1(k) + $ -RRe2*omg(k+1)*(1.-sigmaw)*D_q2(k+1) ) + $ /(Ph(k)-Ph(k+1)) + $ -sigmaw*(1.-sigmaw)*deltaqw(k)*dp_deltomg(k) + $ ) +c print*,'dqls=',dqls(k) + +c------------------------------------------------------------------- + ENDDO +c------------------------------------------------------------------ + +C Increment state variables + + DO k = 1,kupper-1 + +c Coefficient de répartition + + Crep(k)=Crep_sol*(ph(kupper)-ph(k))/(ph(kupper)-ph(1)) + Crep(k)=Crep(k)+Crep_upper*(ph(1)-ph(k))/(p(1)-ph(kupper)) + + +c Reintroduce compensating subsidence term. + +c dtKE(k)=(dtdwn(k)*Crep(k))/sigmaw +c dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)) +c . /(1-sigmaw) +c dqKE(k)=(dqdwn(k)*Crep(k))/sigmaw +c dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)) +c . /(1-sigmaw) +c +c dtKE(k)=(dtdwn(k)*Crep(k)+(1-Crep(k))*dta(k))/sigmaw +c dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)*Crep(k)) +c . /(1-sigmaw) +c dqKE(k)=(dqdwn(k)*Crep(k)+(1-Crep(k))*dqa(k))/sigmaw +c dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)*Crep(k)) +c . /(1-sigmaw) + + dtKE(k)=(dtdwn(k)/sigmaw - dta(k)/(1.-sigmaw)) + dqKE(k)=(dqdwn(k)/sigmaw - dqa(k)/(1.-sigmaw)) +c print*,'dtKE=',dtKE(k) +c print*,'dqKE=',dqKE(k) +c + dtPBL(k)=(wdtPBL(k)/sigmaw - udtPBL(k)/(1.-sigmaw)) + dqPBL(k)=(wdqPBL(k)/sigmaw - udqPBL(k)/(1.-sigmaw)) +c + spread(k) = (1.-sigmaw)*dp_deltomg(k)+gfl*Cstar/sigmaw +c print*,'spread=',spread(k) + + +c ajout d'un effet onde de gravité -Tgw(k)*deltatw(k) 03/02/06 YU Jingmei + + d_deltat_gw(k)=d_deltat_gw(k)-Tgw(k)*deltatw(k)* dtimesub +c print*,'d_delta_gw=',d_deltat_gw(k) + ff=d_deltatw(k)/dtimesub + +c Sans GW +c +c deltatw(k)=deltatw(k)+dtimesub*(ff+dtKE(k)-spread(k)*deltatw(k)) +c +c GW formule 1 +c +c deltatw(k) = deltatw(k)+dtimesub* +c $ (ff+dtKE(k) - spread(k)*deltatw(k)-Tgw(k)*deltatw(k)) +c +c GW formule 2 + + IF (dtimesub*Tgw(k).lt.1.e-10) THEN + deltatw(k) = deltatw(k)+dtimesub* + $ (ff+dtKE(k)+dtPBL(k) + $ - spread(k)*deltatw(k)-Tgw(k)*deltatw(k)) + ELSE + deltatw(k) = deltatw(k)+1/Tgw(k)*(1-exp(-dtimesub*Tgw(k)))* + $ (ff+dtKE(k)+dtPBL(k) + $ - spread(k)*deltatw(k)-Tgw(k)*deltatw(k)) + ENDIF + + dth(k) = deltatw(k)/ppi(k) + + gg=d_deltaqw(k)/dtimesub + + deltaqw(k) = deltaqw(k) + + $ dtimesub*(gg+ dqKE(k)+dqPBL(k) - spread(k)*deltaqw(k)) + + d_deltatw2(k)=d_deltatw2(k)+d_deltatw(k) + d_deltaqw2(k)=d_deltaqw2(k)+d_deltaqw(k) + ENDDO + +C And update large scale variables + + DO k = 1,kupper + te(k) = te0(k) + dtls(k) + qe(k) = qe0(k) + dqls(k) + the(k) = te(k)/ppi(k) + ENDDO + +c Determine Ptop from buoyancy integral +c---------------------------------------------------------------------- + +c-1/ Pressure of the level where dth changes sign. + + Ptop_provis=ph(1) + + DO k= 2,klev + IF (dth(k) .GT. -delta_t_min .and. + $ dth(k-1).LT. -delta_t_min) THEN + Ptop_provis = ((dth(k)+delta_t_min)*p(k-1) + $ - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1)) + GO TO 65 + ENDIF + ENDDO +65 CONTINUE + +c-2/ dth integral + + sum_dth = 0. + dthmin = -delta_t_min + z = 0. + + DO k = 1,klev + dz = -(max(ph(k+1),Ptop_provis)-Ph(k))/(rho(k)*rg) + IF (dz .le. 0) GO TO 70 + z = z+dz + sum_dth = sum_dth + dth(k)*dz + dthmin = min(dthmin,dth(k)) + ENDDO +70 CONTINUE + +c-3/ height of triangle with area= sum_dth and base = dthmin + + hw = 2.*sum_dth/min(dthmin,-0.5) + hw = max(hwmin,hw) + +c-4/ now, get Ptop + + ktop = 0 + z=0. + + DO k = 1,klev + dz = min(-(ph(k+1)-Ph(k))/(rho(k)*rg),hw-z) + IF (dz .le. 0) GO TO 75 + z = z+dz + Ptop = Ph(k)-rho(k)*rg*dz + ktop = k + ENDDO +75 CONTINUE + +c-5/Correct ktop and ptop + + Ptop_new=ptop + + DO k= ktop,2,-1 + IF (dth(k) .GT. -delta_t_min .and. + $ dth(k-1).LT. -delta_t_min) THEN + Ptop_new = ((dth(k)+delta_t_min)*p(k-1) + $ - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1)) + GO TO 275 + ENDIF + ENDDO +275 CONTINUE + + ptop = ptop_new + + DO k=klev,1,-1 + IF (ph(k+1) .LT. ptop) ktop=k + ENDDO + +c-6/ Set deltatw & deltaqw to 0 above kupper + + DO k = kupper,klev + deltatw(k) = 0. + deltaqw(k) = 0. + ENDDO + +c------------------------------------------------------------------ + ENDDO ! end sub-timestep loop +C ----------------------------------------------------------------- + +c Get back to tendencies per second + + DO k = 1,kupper-1 + dtls(k) = dtls(k)/dtime + dqls(k) = dqls(k)/dtime + d_deltatw2(k)=d_deltatw2(k)/dtime + d_deltaqw2(k)=d_deltaqw2(k)/dtime + d_deltat_gw(k) = d_deltat_gw(k)/dtime + ENDDO + +C 2.1 - Undisturbed area and Wake integrals +C --------------------------------------------------------- + + z = 0. + sum_thu = 0. + sum_tu = 0. + sum_qu = 0. + sum_thvu = 0. + sum_dth = 0. + sum_dq = 0. + sum_rho = 0. + sum_dtdwn = 0. + sum_dqdwn = 0. + + av_thu = 0. + av_tu =0. + av_qu =0. + av_thvu = 0. + av_dth = 0. + av_dq = 0. + av_rho =0. + av_dtdwn =0. + av_dqdwn = 0. + +C Potential temperatures and humidity +c---------------------------------------------------------- + + DO k =1,klev + rho(k) = p(k)/(rd*te(k)) + IF(k .eq. 1) THEN + rhoh(k) = ph(k)/(rd*te(k)) + zhh(k)=0 + ELSE + rhoh(k) = ph(k)*2./(rd*(te(k)+te(k-1))) + zhh(k)=(ph(k)-ph(k-1))/(-rhoh(k)*RG)+zhh(k-1) + ENDIF + the(k) = te(k)/ppi(k) + thu(k) = (te(k) - deltatw(k)*sigmaw)/ppi(k) + tu(k) = te(k) - deltatw(k)*sigmaw + qu(k) = qe(k) - deltaqw(k)*sigmaw + rhow(k) = p(k)/(rd*(te(k)+deltatw(k))) + dth(k) = deltatw(k)/ppi(k) + + ENDDO + +C Integrals (and wake top level number) +C ----------------------------------------------------------- + +C Initialize sum_thvu to 1st level virt. pot. temp. + + z = 1. + dz = 1. + sum_thvu = thu(1)*(1.+eps*qu(1))*dz + sum_dth = 0. + + DO k = 1,klev + dz = -(max(ph(k+1),Ptop)-Ph(k))/(rho(k)*rg) + + IF (dz .LE. 0) GO TO 51 + z = z+dz + sum_thu = sum_thu + thu(k)*dz + sum_tu = sum_tu + tu(k)*dz + sum_qu = sum_qu + qu(k)*dz + sum_thvu = sum_thvu + thu(k)*(1.+eps*qu(k))*dz + sum_dth = sum_dth + dth(k)*dz + sum_dq = sum_dq + deltaqw(k)*dz + sum_rho = sum_rho + rhow(k)*dz + sum_dtdwn = sum_dtdwn + dtdwn(k)*dz + sum_dqdwn = sum_dqdwn + dqdwn(k)*dz + ENDDO + 51 CONTINUE + + hw0 = z + +C 2.1 - WAPE and mean forcing computation +C------------------------------------------------------------- + +C Means + + av_thu = sum_thu/hw0 + av_tu = sum_tu/hw0 + av_qu = sum_qu/hw0 + av_thvu = sum_thvu/hw0 + av_dth = sum_dth/hw0 + av_dq = sum_dq/hw0 + av_rho = sum_rho/hw0 + av_dtdwn = sum_dtdwn/hw0 + av_dqdwn = sum_dqdwn/hw0 + + wape2 = - rg*hw0*(av_dth + $ + eps*(av_thu*av_dq+av_dth*av_qu+av_dth*av_dq ))/av_thvu + + +C 2.2 Prognostic variable update +C ------------------------------------------------------------ + +C Filter out bad wakes + + IF ( wape2 .LT. 0.) THEN + if(prt_level.ge.10) print*,'wape2<0' + wape2 = 0. + hw = hwmin + sigmaw = max(sigmad,sigd_con) + fip = 0. + DO k = 1,klev + deltatw(k) = 0. + deltaqw(k) = 0. + dth(k) = 0. + ENDDO + ELSE + if(prt_level.ge.10) print*,'wape2>0' + Cstar2 = stark*sqrt(2.*wape2) + + ENDIF + + ktopw = ktop + + IF (ktopw .gt. 0) then + +Cjyg1 Utilisation d'un h_efficace constant ( ~ feeding layer) +ccc heff = 600. +C Utilisation de la hauteur hw +cc heff = 0.7*hw + heff = hw + + FIP = 0.5*rho(ktopw)*Cstar2**3*heff*2*sqrt(sigmaw*wdens*3.14) + FIP = alpk * FIP +Cjyg2 + ELSE + FIP = 0. + ENDIF + + +C Limitation de sigmaw +c +C sécurité : si le wake occuppe plus de 90 % de la surface de la maille, +C alors il disparait en se mélangeant à la partie undisturbed + +! correction NICOLAS . ((wape.ge.wape2).and.(wape2.le.1.0))) THEN + IF ((sigmaw.GT.0.9).or. + . ((wape.ge.wape2).and.(wape2.le.1.0)).or.(ktopw.le.2)) THEN +cIM cf NR/JYG 251108 . ((wape.ge.wape2).and.(wape2.le.1.0))) THEN +c IF (sigmaw.GT.0.9) THEN + DO k = 1,klev + dtls(k) = 0. + dqls(k) = 0. + deltatw(k) = 0. + deltaqw(k) = 0. + ENDDO + wape = 0. + hw = hwmin + sigmaw = sigmad + fip = 0. + ENDIF + + RETURN + END + + + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/wrgradsfi.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/wrgradsfi.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/wrgradsfi.F (revision 1280) @@ -0,0 +1,43 @@ +! +! $Header$ +! + subroutine wrgradsfi(if,nl,fieldfi_p,name,titlevar) + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + implicit none + +c Declarations + +#include "dimensions.h" +cym#include "dimphy.h" + +c arguments + integer if,nl + real fieldfi_p(klon,nl) + real fieldfi(klon_glo,nl) + real fielddyn((iim+1)*(jjm+1),llm) + character*10 name + character*10 titlevar + +c local + + integer lm,l,lnblnk + + + +c print*,'Transformation pour ',name + call Gather(fieldfi_p,fieldfi) + +c$OMP MASTER + if (is_mpi_root) then + call gr_fi_dyn(nl,klon,iim+1,jjm+1,fieldfi,fielddyn) + +c print*,'Transformation OK ' + call wrgrads(if,nl,fielddyn,name,titlevar) +c print*,'Ecriture ok' + endif +c$OMP END MASTER + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_bilKP_ave.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_bilKP_ave.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_bilKP_ave.h (revision 1280) @@ -0,0 +1,155 @@ +c +c $Header$ +c + IF (ok_journe) THEN +c + ndex2d = 0 + ndex3d = 0 +c +c Champs 2D: +c + itau_w = itau_phy + itap +c +cym CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ue_lay,zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"ue",itau_w,ue_lay) +c +cym CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ve_lay,zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"ve",itau_w,ve_lay) +c +cym CALL gr_fi_ecrit(klev, klon,iim,jjmp1, uq_lay,zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"uq",itau_w,uq_lay) +c +cym CALL gr_fi_ecrit(klev, klon,iim,jjmp1, vq_lay,zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"vq",itau_w,vq_lay) +c +c Champs 3D: +C +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"temp",itau_w,t_seri) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"ovap",itau_w,qx(:,:,ivap)) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"geop",itau_w,zphi) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"vitu",itau_w,u_seri) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"vitv",itau_w,v_seri) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"vitw",itau_w,omega) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"pres",itau_w,pplay) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, paprs, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"play",itau_w,paprs) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldliq, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"oliq",itau_w,cldliq) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtdyn",itau_w,d_t_dyn) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dqdyn",itau_w,d_q_dyn) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_con, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtcon",itau_w,d_t_con) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_con, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"ducon",itau_w,d_u_con) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_con, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dvcon",itau_w,d_v_con) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_con, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dqcon",itau_w,d_q_con) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_lsc, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtlsc",itau_w,d_t_lsc) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_lsc, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dqlsc",itau_w,d_q_lsc) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtvdf",itau_w,d_t_vdf) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dqvdf",itau_w,d_q_vdf) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_ajs, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtajs",itau_w,d_t_ajs) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_ajs, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dqajs",itau_w,d_q_ajs) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_eva, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dteva",itau_w,d_t_eva) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_eva, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dqeva",itau_w,d_q_eva) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtswr",itau_w,heat) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat0, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtsw0",itau_w,heat0) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtlwr",itau_w,cool) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool0, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtlw0",itau_w,cool0) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_vdf, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"duvdf",itau_w,d_u_vdf) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_vdf, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dvvdf",itau_w,d_v_vdf) +c + IF (ok_orodr) THEN + IF (ok_orolf) THEN +c + DO k = 1, klev + DO i = 1, klon + d_u_oli(i,k) = d_u_oro(i,k) + d_u_lif(i,k) + d_v_oli(i,k) = d_v_oro(i,k) + d_v_lif(i,k) + ENDDO + ENDDO +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_oli, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"duoli",d_u_oli) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_oli, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dvoli",itau_w,d_v_oli) +c + ENDIF + ENDIF +C +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"duphy",itau_w,d_u) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dvphy",itau_w,d_v) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtphy",itau_w,d_t) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,1), +cymf .zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dqphy",itau_w,d_qx(:,:,1)) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,2), +cym .zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dqlphy",itau_w,d_qx(:,:,2)) +c +C + if (ok_sync) then + call histsync(nid_bilKPave) + endif + ENDIF + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_bilKP_ins.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_bilKP_ins.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_bilKP_ins.h (revision 1280) @@ -0,0 +1,179 @@ + c +c $Header$ +c + IF (ok_journe) THEN +c + ndex2d = 0 + ndex3d = 0 +c + itau_w = itau_phy + itap +c +c Champs 3D: +c +cym CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ue_lay,zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"ue",itau_w,ue_lay) +c +cym CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ve_lay,zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"ve",itau_w,ve_lay) +c +cym CALL gr_fi_ecrit(klev, klon,iim,jjmp1, uq_lay,zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"uq",itau_w,uq_lay) +c +cym CALL gr_fi_ecrit(klev, klon,iim,jjmp1, vq_lay,zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"vq",itau_w,vq_lay) +c +c Champs 3D: +C +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"temp",itau_w,t_seri) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"ovap",itau_w,qx(:,:,ivap)) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"geop",itau_w,zphi) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"vitu",itau_w,u_seri) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"vitv",itau_w,v_seri) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"vitw",itau_w,omega) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"pres",itau_w,pplay) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, paprs, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"play",itau_w,paprs) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldliq, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"oliq",itau_w,cldliq) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtdyn",itau_w,d_t_dyn) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dqdyn",itau_w,d_q_dyn) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_con, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtcon",itau_w,d_t_con) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_con, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"ducon",itau_w,d_u_con) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_con, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dvcon",itau_w,d_v_con) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_con, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dqcon",itau_w,d_q_con) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_lsc, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtlsc",itau_w,d_t_lsc) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_lsc, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dqlsc",itau_w,d_q_lsc) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtvdf",itau_w,d_t_vdf) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dqvdf",itau_w,d_q_vdf) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_ajs, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtajs",itau_w,d_t_ajs) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_ajs, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dqajs",itau_w,d_q_ajs) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_eva, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dteva",itau_w,d_t_eva) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_eva, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dqeva",itau_w,d_q_eva) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtswr",itau_w,heat) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat0, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtsw0",itau_w,heat0) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtlwr",itau_w,cool) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool0, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtlw0",itau_w,cool0) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_vdf, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"duvdf",itau_w,d_u_vdf) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_vdf, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dvvdf",itau_w,d_v_vdf) +c + IF (ok_orodr) THEN + IF (ok_orolf) THEN +c + DO k = 1, klev + DO i = 1, klon + d_u_oli(i,k) = d_u_oro(i,k) + d_u_lif(i,k) + d_v_oli(i,k) = d_v_oro(i,k) + d_v_lif(i,k) + ENDDO + ENDDO +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_oli, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"duoli",itau_w,d_u_oli) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_oli, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dvoli",itau_w,d_v_oli) +c + ENDIF + ENDIF +C +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"duphy",itau_w,d_u) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dvphy",itau_w,d_v) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtphy",itau_w,d_t) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,1), +cym .zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dqphy",itau_w,d_qx(:,:,1)) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,2), +cym .zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dqlphy",itau_w,d_qx(:,:,2)) +c +cIM 280405 BEG +c +c Champs 2D: +c +c Ecriture de champs dynamiques sur des niveaux de pression +c DO k=1, nlevSTD + DO k=1, 12 +c + IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k) + IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k) +c + IF(bb2.EQ."850") THEN +c +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,usumSTD(:,k,1),zx_tmp_2d) + CALL histwrite_phy(nid_bilKPins,"u"//bb2,itau_w,usumSTD(:,k,1)) +c +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,vsumSTD(:,k,1),zx_tmp_2d) + CALL histwrite_phy(nid_bilKPins,"v"//bb2,itau_w,vsumSTD(:,k,1)) +c + ENDIF !(bb2.EQ."850") +c + ENDDO !k=1, 12 +c +cIM 280405 END +C + if (ok_sync) then + call histsync(nid_bilKPins) + endif + ENDIF + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_field_phy.F90 =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_field_phy.F90 (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_field_phy.F90 (revision 1280) @@ -0,0 +1,36 @@ +! +! $Header$ +! +MODULE write_field_phy + + CONTAINS + + SUBROUTINE WriteField_phy(name,Field,ll) + USE dimphy + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz + USE Write_Field + + IMPLICIT NONE + include 'dimensions.h' + include 'paramet.h' + + character(len=*) :: name + INTEGER :: ll + real, dimension(klon_omp,ll) :: Field + real,save,allocatable :: Field_tmp(:,:) + real, dimension(klon_glo,ll):: New_Field + real, dimension(iim,jjp1,ll):: Field_2d + + CALL Gather(Field,New_Field) +!$OMP MASTER + IF (is_mpi_root) THEN + CALL Grid1Dto2D_glo(New_Field,Field_2D) + CALL WriteField(name,Field_2d) + ENDIF +!$OMP END MASTER + + + END SUBROUTINE WriteField_phy + + END MODULE write_field_phy Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histISCCP.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histISCCP.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histISCCP.h (revision 1280) @@ -0,0 +1,222 @@ +! +! $Header$ +! + IF (ok_isccp) THEN +c + IF (MOD(itap,NINT(freq_ISCCP/dtime)).EQ.0) THEN +c + ndex2d = 0 + ndex3d = 0 +c + itau_w = itau_phy + itap +c + IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN +c + DO n=1, napisccp +c + DO k=1,kmaxm1 + zx_tmp_fi3d(1:klon, 1:lmaxm1)=fq_isccp(1:klon,k,1:lmaxm1,n)*100. +cym CALL gr_fi_ecrit(lmaxm1,klon,iim,jjmp1,zx_tmp_fi3d, +cym . zx_tmp_3d) +c +cIM: champ 3d : (lon,lat,pres) pour un tau fixe +c + CALL histwrite_phy(nid_isccp,"cldISCCP_"//taulev(k)//verticaxe(n), + . itau_w,zx_tmp_fi3d) + ENDDO !k +c +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,nbsunlit(1,:,n),zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"nsunlit"//verticaxe(n),itau_w, + . nbsunlit(1,:,n)) +c + CALL histwrite_phy(nid_isccp,"meantaucld"//verticaxe(n),itau_w, + . meantaucld(:,n)) +c + ENDDO ! n=1, napisccp + ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN +c + DO n=1, napisccp +c print*,'n=',n,' write_ISCCP avant fq_isccp' + DO k=1, kmaxm1 + DO l=1, lmaxm1 +c + IF(top_height.LE.2) THEN + DO i=1, klon +c281008 beg +c print*,'write_ISCCP i n nbsunlit',i,n,nbsunlit(1,i,n) +c281008 end +c + IF(nbsunlit(1,i,n).NE.0.) THEN + fq_is_true(i,k,l,n)= + $ fq_isccp(i,k,l,n)*100./nbsunlit(1,i,n) + ELSE + fq_is_true(i,k,l,n)=0 + ENDIF + ENDDO + ELSE IF(top_height.EQ.3) THEN + DO i=1, klon + fq_is_true(i,k,l,n) = fq_isccp(i,k,l,n)*100. + ENDDO + ENDIF +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,fq_is_true, +cym . zx_tmp_2d) +c +cIM: champ 2d : (lon,lat) pour un tau et une pc fixes +c + CALL histwrite_phy(nid_isccp,pclev(l)//taulev(k)//verticaxe(n), + . itau_w,fq_is_true(:,k,l,n)) + ENDDO !l + ENDDO !k +c +c print*,'n=',n,' write_ISCCP avant nbsunlit' +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,nbsunlit(1,:,n),zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"nsunlit"//verticaxe(n), + . itau_w,nbsunlit(1,:,n)) +c + CALL histwrite_phy(nid_isccp,"meantaucld"//verticaxe(n),itau_w, + . meantaucld(:,n)) +c + zx_tmp_fi2d(1:klon)=float(seed(1:klon,n)) +c +c print*,'n=',n,' write_ISCCP avant seed' +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"seed"//verticaxe(n), + . itau_w,zx_tmp_fi2d) +c +c 9types de nuages ISCCP-D2 +c fq_isccp(1:klon,k,l,n)*100. <=> pc_tau(k)_pclev(l) + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,1,1,n)+ fq_is_true(i,2,1,n)+ fq_is_true(i,3,1,n) + + $ fq_is_true(i,1,2,n)+ fq_is_true(i,2,2,n)+ fq_is_true(i,3,2,n) + + $ fq_is_true(i,1,3,n)+ fq_is_true(i,2,3,n)+ fq_is_true(i,3,3,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"cirr",itau_w,zx_tmp_fi2d) +c + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,4,1,n)+ fq_is_true(i,5,1,n) + + $ fq_is_true(i,4,2,n)+ fq_is_true(i,5,2,n) + + $ fq_is_true(i,4,3,n)+ fq_is_true(i,5,3,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"cist",itau_w,zx_tmp_fi2d) +c + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,6,1,n)+ fq_is_true(i,7,1,n) + + $ fq_is_true(i,6,2,n)+ fq_is_true(i,7,2,n) + + $ fq_is_true(i,6,3,n)+ fq_is_true(i,7,3,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"deep",itau_w,zx_tmp_fi2d) +c + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,1,4,n)+ fq_is_true(i,2,4,n)+ fq_is_true(i,3,4,n) + + $ fq_is_true(i,1,5,n)+ fq_is_true(i,2,5,n)+ fq_is_true(i,3,5,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"alcu",itau_w,zx_tmp_fi2d) +c + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,4,4,n)+ fq_is_true(i,5,4,n) + + $ fq_is_true(i,4,5,n)+ fq_is_true(i,5,5,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"alst",itau_w,zx_tmp_fi2d) +c + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,6,4,n)+ fq_is_true(i,7,4,n) + + $ fq_is_true(i,6,5,n)+ fq_is_true(i,7,5,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"nist",itau_w,zx_tmp_fi2d) +c + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,1,6,n)+ fq_is_true(i,2,6,n)+ fq_is_true(i,3,6,n) + + $ fq_is_true(i,1,7,n)+ fq_is_true(i,2,7,n)+ fq_is_true(i,3,7,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"cumu",itau_w,zx_tmp_fi2d) +c + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,4,6,n)+ fq_is_true(i,5,6,n) + + $ fq_is_true(i,4,7,n)+ fq_is_true(i,5,7,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"stcu",itau_w,zx_tmp_fi2d) +c + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,6,6,n)+ fq_is_true(i,7,6,n) + + $ fq_is_true(i,6,7,n)+ fq_is_true(i,7,7,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"stra",itau_w,zx_tmp_fi2d) +c +c 3_tau_nuages x 3_levels +c fq_is_true(1:klon,k,l,n)*100. <=> pc_tau(k)_pclev(l) + DO i=1, klon + cld_fi3d(i,1)= + $ (fq_is_true(i,1,1,n)+ fq_is_true(i,2,1,n)+ fq_is_true(i,3,1,n) + + $ fq_is_true(i,1,2,n)+ fq_is_true(i,2,2,n)+ fq_is_true(i,3,2,n) + + $ fq_is_true(i,1,3,n)+ fq_is_true(i,2,3,n)+ fq_is_true(i,3,3,n) ) + cld_fi3d(i,2)= + $ (fq_is_true(i,1,4,n)+ fq_is_true(i,2,4,n)+ fq_is_true(i,3,4,n) + + $ fq_is_true(i,1,5,n)+ fq_is_true(i,2,5,n)+ fq_is_true(i,3,5,n) ) + cld_fi3d(i,3)= + $ (fq_is_true(i,1,6,n)+ fq_is_true(i,2,6,n)+ fq_is_true(i,3,6,n) + + $ fq_is_true(i,1,7,n)+ fq_is_true(i,2,7,n)+ fq_is_true(i,3,7,n) ) + ENDDO +cym CALL gr_fi_ecrit(lmax3,klon,iim,jjmp1,cld_fi3d,cld_3d) + CALL histwrite_phy(nid_isccp,"thin",itau_w,cld_fi3d) +c + DO i=1, klon + cld_fi3d(i,1)= + $ (fq_is_true(i,4,1,n)+ fq_is_true(i,5,1,n) + + $ fq_is_true(i,4,2,n)+ fq_is_true(i,5,2,n) + + $ fq_is_true(i,4,3,n)+ fq_is_true(i,5,3,n) ) + cld_fi3d(i,2)= + $ (fq_is_true(i,4,4,n)+ fq_is_true(i,5,4,n) + + $ fq_is_true(i,4,5,n)+ fq_is_true(i,5,5,n) ) + cld_fi3d(i,3)= + $ (fq_is_true(i,4,6,n)+ fq_is_true(i,5,6,n) + + $ fq_is_true(i,4,7,n)+ fq_is_true(i,5,7,n) ) + ENDDO +cym CALL gr_fi_ecrit(lmax3, klon,iim,jjmp1,cld_fi3d,cld_3d) + CALL histwrite_phy(nid_isccp,"mid",itau_w,cld_fi3d) +c + DO i=1, klon + cld_fi3d(i,1)= + $ (fq_is_true(i,6,1,n)+ fq_is_true(i,7,1,n) + + $ fq_is_true(i,6,2,n)+ fq_is_true(i,7,2,n) + + $ fq_is_true(i,6,3,n)+ fq_is_true(i,7,3,n) ) + cld_fi3d(i,2)= + $ (fq_is_true(i,6,4,n)+ fq_is_true(i,7,4,n) + + $ fq_is_true(i,6,5,n)+ fq_is_true(i,7,5,n) ) + cld_fi3d(i,3)= + $ (fq_is_true(i,6,6,n)+ fq_is_true(i,7,6,n) + + $ fq_is_true(i,6,7,n)+ fq_is_true(i,7,7,n) ) + ENDDO +cym CALL gr_fi_ecrit(lmax3, klon,iim,jjmp1,cld_fi3d,cld_3d) + CALL histwrite_phy(nid_isccp,"thick",itau_w,cld_fi3d) +c + ENDDO ! n=1, napisccp +c + ENDIF +c + if (ok_sync) then +c$OMP MASTER + call histsync(nid_isccp) +c$OMP END MASTER + endif + + ENDIF !(MOD(itap,NINT(freq_ISCCP/dtime)).EQ.0) THEN + + ENDIF !ok_isccp Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histREGDYN.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histREGDYN.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histREGDYN.h (revision 1280) @@ -0,0 +1,63 @@ +! +! $Header$ +! + if (ok_regdyn) then + + if (is_sequential) then + + + ndex3d = 0 + itau_w = itau_phy + itap +c + CALL histwrite(nid_regdyn,"hw1",itau_w,histoW(:,:,:,1), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nh1",itau_w,nhistoW(:,:,:,1), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nht1",itau_w,nhistoWt(:,:,:,1), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"hw2",itau_w,histoW(:,:,:,2), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nh2",itau_w,nhistoW(:,:,:,2), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nht2",itau_w,nhistoWt(:,:,:,2), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"hw3",itau_w,histoW(:,:,:,3), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nh3",itau_w,nhistoW(:,:,:,3), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nht3",itau_w,nhistoWt(:,:,:,3), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"hw4",itau_w,histoW(:,:,:,4), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nh4",itau_w,nhistoW(:,:,:,4), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nht4",itau_w,nhistoWt(:,:,:,4), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"hw5",itau_w,histoW(:,:,:,5), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nh5",itau_w,nhistoW(:,:,:,5), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nht5",itau_w,nhistoWt(:,:,:,5), + & kmaxm1*lmaxm1*iwmax,ndex3d) + + if (ok_sync) then + call histsync(nid_regdyn) + endif + + endif ! is_sequential + + endif Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histday_seri.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histday_seri.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histday_seri.h (revision 1280) @@ -0,0 +1,242 @@ +c +c $Header$ +c + IF (is_sequential) THEN + + IF (type_run.EQ."AMIP") THEN +c + ndex2d = 0 + itau_w = itau_phy + itap +c +c Champs 2D: +c + pi = ACOS(-1.) + pir = 4.0*ATAN(1.0) / 180.0 +c + DO i=1, klon + zx_tmp_fi2d(i)=(topsw(i)-toplw(i)) + ENDDO +c + ok_msk=.FALSE. + msk(1:klon)=pctsrf(1:klon,is_ter) + CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, + . ok_msk, msk, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"bilTOA",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + ok_msk=.FALSE. + CALL moyglo_pondaire(klon, bils, airephy, + . ok_msk, msk, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"bils",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO k=1, klev + DO i=1, klon +cIM 080904 zx_tmp_fi3d(i,k)=u(i,k)**2+v(i,k)**2 + zx_tmp_fi3d(i,k)=(u(i,k)**2+v(i,k)**2)/2. + ENDDO + ENDDO +c + CALL moyglo_pondaima(klon, klev, zx_tmp_fi3d, + . airephy, paprs, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"ecin",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c +cIM 151004 BEG + IF(1.EQ.0) THEN +c + DO k=1, klev + DO i=1, klon + zx_tmp_fi3d(i,k)=u_seri(i,k)*RA*cos(pir* rlat(i)) + ENDDO + ENDDO +c + CALL moyglo_pondaima(klon, klev, zx_tmp_fi3d, + . airephy, paprs, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"momang",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c +c friction torque +c + DO i=1, klon + zx_tmp_fi2d(i)=zxfluxu(i,1)*RA* cos(pir* rlat(i)) + ENDDO +c + ok_msk=.FALSE. + CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, + . ok_msk, msk, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"frictor",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c +c mountain torque +c +cIM 190504 BEG + CALL gr_fi_dyn(1,klon,iim+1,jjm+1,airephy,airedyn) + CALL gr_fi_dyn(klev+1,klon,iim+1,jjm+1,paprs,padyn) + CALL gr_fi_dyn(1,klon,iim+1,jjm+1,rlat,rlatdyn) + mountor=0. + airetot=0. + DO j = 1, jjmp1 + DO i = 1, iim+1 + ij=i+(iim+1)*(j-1) + zx_tmp(ij)=0. + DO k = 1, klev + zx_tmp(ij)=zx_tmp(ij)+dudyn(i,j,k)*airedyn(i,j)* + $ (padyn(i,j,k+1)-padyn(i,j,k))/RG + airetot=airetot+airedyn(i,j) + ENDDO +cIM 190504 mountor=mountor+zx_tmp(ij)*airedyn(i,j)*RA* + mountor=mountor+zx_tmp(ij)*RA* + $ cos(pir* rlatdyn(i,j)) + ENDDO + ENDDO +cIM 151004 BEG + IF(itap.EQ.1) PRINT*,'airetot=',airetot,airetot/klev +cIM 151004 END +cIM 190504 mountor=mountor/(airetot*airetot) + mountor=mountor/airetot +c +cIM 190504 END + zx_tmp_2d(1:iim,1:jjmp1)=mountor + CALL histwrite(nid_day_seri,"mountor",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + ENDIF !(1.EQ.0) THEN +c +c + CALL gr_fi_dyn(1,klon,iim+1,jjm+1,airephy,airedyn) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d) + airetot=0. +c DO j = 1, jjmp1 +c DO i = 1, iim+1 +c ij=i+(iim+1)*(j-1) +c DO k = 1, klev +c airetot=airetot+airedyn(i,j) +c airetot=airetot+airedyn(i,j) +c ENDDO !k +c ENDDO !i +c ENDDO !j +c + DO i=1, klon + airetot=airetot+airephy(i) + ENDDO +c IF(itap.EQ.1) PRINT*,'airetotphy=',airetot +c + airetot=0. + DO j=1, jjmp1 + DO i=1, iim + airetot=airetot+zx_tmp_2d(i,j) + ENDDO + ENDDO +c +c IF(itap.EQ.1) PRINT*,'airetotij=',airetot, +c $ '4piR2',4.*pi*RA*RA +c + zx_tmp_fi2d(1:klon)=aam/airetot + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"momang",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1:klon)=torsfc/airetot + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"torsfc",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c +cIM 151004 END +c + CALL moyglo_pondmass(klon, klev, t_seri, + . airephy, paprs, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"tamv",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + ok_msk=.FALSE. + CALL moyglo_pondaire(klon, paprs(:,1), airephy, + . ok_msk, msk, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"psol",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + ok_msk=.FALSE. + CALL moyglo_pondaire(klon, evap, airephy, + . ok_msk, msk, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"evap",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c +c DO i=1, klon +c zx_tmp_fi2d(i)=SnowFrac(i,is_ter) +c ENDDO +c +c ok_msk=.TRUE. +c msk(1:klon)=pctsrf(1:klon,is_ter) +c CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, +c . ok_msk, msk, moyglo) +c zx_tmp_fi2d(1:klon)=moyglo +c +c CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) +c CALL histwrite(nid_day_seri,"SnowFrac", +c . itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c DO i=1, klon +cIM 080904 zx_tmp_fi2d(i)=zsnow_mass(i)/330.*rowl +c zx_tmp_fi2d(i)=zsnow_mass(i) +c ENDDO +c +cIM 140904 ok_msk=.FALSE. +c ok_msk=.TRUE. +c msk(1:klon)=pctsrf(1:klon,is_ter) +c CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, +c . ok_msk, msk, moyglo) +c zx_tmp_fi2d(1:klon)=moyglo +c +c CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) +c CALL histwrite(nid_day_seri,"snow_depth",itau_w, +c . zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i=1, klon + zx_tmp_fi2d(i)=ftsol(i,is_oce) + ENDDO +c + ok_msk=.TRUE. + msk(1:klon)=pctsrf(1:klon,is_oce) + CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, + . ok_msk, msk, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day_seri,"tsol_"//clnsurf(is_oce), + $ itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c================================================================= +c================================================================= +c================================================================= +c + if (ok_sync) then + call histsync(nid_day_seri) + endif +c + ENDIF !fin test sur type_run.EQ."AMIP" + + ENDIF ! mono_cpu Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histhf3d.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histhf3d.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histhf3d.h (revision 1280) @@ -0,0 +1,28 @@ + +c +c $Header$ +c +c + ndex2d = 0 + ndex3d = 0 +c + itau_w = itau_phy + itap +c +c Champs 3D: +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d) + CALL histwrite_phy(nid_hf3d,"temp",itau_w,t_seri) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d) + CALL histwrite_phy(nid_hf3d,"ovap",itau_w,qx(:,:,ivap)) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d) + CALL histwrite_phy(nid_hf3d,"vitu",itau_w,u_seri) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d) + CALL histwrite_phy(nid_hf3d,"vitv",itau_w,v_seri) + if (ok_sync) then +c$OMP MASTER + call histsync(nid_hf3d) +c$OMP END MASTER + endif Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histmthNMC.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histmthNMC.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histmthNMC.h (revision 1280) @@ -0,0 +1,126 @@ +! +! $Header$ +! + IF (ok_mensuel) THEN +c + ndex3d = 0 + itau_w = itau_phy + itap +ccc +c Champs interpolles sur des niveaux de pression du NMC +c +c PARAMETER(nout=3) !nout=1 : day; =2 : mth; =3 : NMC +ccc + IF(type_run.EQ."CLIM".OR.type_run.EQ."ENSP") THEN +ccc +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,tsumSTD(:,:,2), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"temp",itau_w,tsumSTD(:,:,2)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,phisumSTD(:,:,2), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"phi",itau_w,phisumSTD(:,:,2)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,qsumSTD(:,:,2), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"q",itau_w,qsumSTD(:,:,2)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,rhsumSTD(:,:,2), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"rh",itau_w,rhsumSTD(:,:,2)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,usumSTD(:,:,2), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"u",itau_w,usumSTD(:,:,2)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vsumSTD(:,:,2), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"v",itau_w,vsumSTD(:,:,2)) +ccc + ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN +ccc +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,tsumSTD(:,:,3), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"temp",itau_w,tsumSTD(:,:,3)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,phisumSTD(:,:,3), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"phi",itau_w,phisumSTD(:,:,3)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,qsumSTD(:,:,3), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"q",itau_w,qsumSTD(:,:,3)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,rhsumSTD(:,:,3), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"rh",itau_w,rhsumSTD(:,:,3)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,usumSTD(:,:,3), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"u",itau_w,usumSTD(:,:,3)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vsumSTD(:,:,3), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"v",itau_w,vsumSTD(:,:,3)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,wsumSTD(:,:,3), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"w",itau_w,wsumSTD(:,:,3)) +c + DO k=1, nlevSTD + DO i=1, klon + IF(tnondef(i,k,3).NE.1.E+20) THEN + zx_tmp_fiNC(i,k) = (100.*tnondef(i,k,3))/ecrit_hf2mth + ELSE + zx_tmp_fiNC(i,k) = 1.E+20 + ENDIF + ENDDO + ENDDO !k=1, nlevSTD +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,zx_tmp_fiNC,zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"psbg",itau_w,zx_tmp_fiNC) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,uvsumSTD(:,:,3), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"uv",itau_w,uvsumSTD(:,:,3)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vqsumSTD(:,:,3), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"vq",itau_w,vqsumSTD(:,:,3)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vTsumSTD(:,:,3), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"vT",itau_w,vTsumSTD(:,:,3)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1, wqsumSTD(:,:,3), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"wq",itau_w,wqsumSTD(:,:,3)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vphisumSTD(:,:,3), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"vphi",itau_w,vphisumSTD(:,:,3)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,wTsumSTD(:,:,3), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"wT",itau_w,wTsumSTD(:,:,3)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,u2sumSTD(:,:,3), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"uxu",itau_w,u2sumSTD(:,:,3)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,v2sumSTD(:,:,3), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"vxv",itau_w,v2sumSTD(:,:,3)) +c +cym CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,T2sumSTD(:,:,3), +cym $ zx_tmp_NC) + CALL histwrite_phy(nid_nmc,"TxT",itau_w,T2sumSTD(:,:,3)) +c + ENDIF !type_run +c + if (ok_sync) then +c$OMP MASTER + call histsync(nid_nmc) +c$OMP END MASTER + endif + + ENDIF Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histrac.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histrac.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_histrac.h (revision 1280) @@ -0,0 +1,83 @@ +!$Id $ +!*************************************** +! ECRITURE DU FICHIER : histrac.nc +!*************************************** + IF (ecrit_tra > 0. .AND. config_inca == 'none') THEN + + itau_w = itau_phy + nstep + + CALL histwrite_phy(nid_tra,"phis",itau_w,pphis) + CALL histwrite_phy(nid_tra,"aire",itau_w,airephy) + +!TRACEURS +!---------------- + DO it=1,nbtr + iiq=niadv(it+2) + +! CONCENTRATIONS + CALL histwrite_phy(nid_tra,tname(iiq),itau_w,tr_seri(:,:,it)) + +! TD LESSIVAGE + IF (lessivage .AND. aerosol(it)) THEN + CALL histwrite_phy(nid_tra,"fl"//tname(iiq),itau_w,flestottr(:,:,it)) + ENDIF + +! TD THERMIQUES + IF (iflag_thermals.gt.0) THEN + CALL histwrite_phy(nid_tra,"d_tr_th_"//tname(iiq),itau_w,d_tr_th(:,:,it)) + ENDIF + +! TD CONVECTION + IF (iflag_con.GE.2) THEN + CALL histwrite_phy(nid_tra,"d_tr_cv_"//tname(iiq),itau_w,d_tr_cv(:,:,it)) + ENDIF + +! TD COUCHE-LIMITE + CALL histwrite_phy(nid_tra,"d_tr_cl_"//tname(iiq),itau_w,d_tr_cl(:,:,it)) + ENDDO +!--------------- +! +! +! VENT (niveau 1) + CALL histwrite_phy(nid_tra,"pyu1",itau_w,yu1) + CALL histwrite_phy(nid_tra,"pyv1",itau_w,yv1) +! +! TEMPERATURE DU SOL + zx_tmp_fi2d(:)=ftsol(:,1) + CALL histwrite_phy(nid_tra,"ftsol1",itau_w,zx_tmp_fi2d) + zx_tmp_fi2d(:)=ftsol(:,2) + CALL histwrite_phy(nid_tra,"ftsol2",itau_w,zx_tmp_fi2d) + zx_tmp_fi2d(:)=ftsol(:,3) + CALL histwrite_phy(nid_tra,"ftsol3",itau_w,zx_tmp_fi2d) + zx_tmp_fi2d(:)=ftsol(:,4) + CALL histwrite_phy(nid_tra,"ftsol4",itau_w,zx_tmp_fi2d) +! +! NATURE DU SOL + zx_tmp_fi2d(:)=pctsrf(:,1) + CALL histwrite_phy(nid_tra,"psrf1",itau_w,zx_tmp_fi2d) + zx_tmp_fi2d(:)=pctsrf(:,2) + CALL histwrite_phy(nid_tra,"psrf2",itau_w,zx_tmp_fi2d) + zx_tmp_fi2d(:)=pctsrf(:,3) + CALL histwrite_phy(nid_tra,"psrf3",itau_w,zx_tmp_fi2d) + zx_tmp_fi2d(:)=pctsrf(:,4) + CALL histwrite_phy(nid_tra,"psrf4",itau_w,zx_tmp_fi2d) + +! DIVERS + CALL histwrite_phy(nid_tra,"pplay",itau_w,pplay) + CALL histwrite_phy(nid_tra,"t",itau_w,t_seri) + CALL histwrite_phy(nid_tra,"mfu",itau_w,pmfu) + CALL histwrite_phy(nid_tra,"mfd",itau_w,pmfd) + CALL histwrite_phy(nid_tra,"en_u",itau_w,pen_u) + CALL histwrite_phy(nid_tra,"en_d",itau_w,pen_d) + CALL histwrite_phy(nid_tra,"de_d",itau_w,pde_d) + CALL histwrite_phy(nid_tra,"de_u",itau_w,pde_u) + CALL histwrite_phy(nid_tra,"coefh",itau_w,coefh) + + IF (ok_sync) THEN +!$OMP MASTER + CALL histsync(nid_tra) +!$OMP END MASTER + ENDIF + + ENDIF !ecrit_tra>0. .AND. config_inca == 'none' + Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_paramLMDZ_phy.h =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_paramLMDZ_phy.h (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/write_paramLMDZ_phy.h (revision 1280) @@ -0,0 +1,358 @@ +c + IF (is_sequential) THEN + + ndex2d = 0 + itau_w = itau_phy + itap +c +c Variables type caractere : plusieurs valeurs possibles +c + IF(type_ocean.EQ.'force ') THEN + zx_tmp_2d(1:iim,1:jjmp1)=1. + ELSE IF(type_ocean.EQ.'slab ') THEN + zx_tmp_2d(1:iim,1:jjmp1)=2. + ELSE IF(type_ocean.EQ.'couple') THEN + zx_tmp_2d(1:iim,1:jjmp1)=3. + ENDIF + CALL histwrite(nid_ctesGCM,"ocean",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + IF(type_run.EQ.'CLIM'.OR.type_run.EQ.'ENSP') THEN + zx_tmp_2d(1:iim,1:jjmp1)=1. + ELSE IF(type_run.EQ.'AMIP'.OR.type_run.EQ.'CFMI') THEN + zx_tmp_2d(1:iim,1:jjmp1)=2. + ENDIF + CALL histwrite(nid_ctesGCM,"type_run",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c +c Variables logiques (1=true, 2=false) +c + IF(ok_veget) THEN + zx_tmp_2d(1:iim,1:jjmp1)=1. + ELSE + zx_tmp_2d(1:iim,1:jjmp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM,"ok_veget",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + IF(ok_journe) THEN + zx_tmp_2d(1:iim,1:jjmp1)=1. + ELSE + zx_tmp_2d(1:iim,1:jjmp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM,"ok_journe",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + IF(ok_mensuel) THEN + zx_tmp_2d(1:iim,1:jjmp1)=1. + ELSE + zx_tmp_2d(1:iim,1:jjmp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM,"ok_mensuel",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + IF(ok_instan) THEN + zx_tmp_2d(1:iim,1:jjmp1)=1. + ELSE + zx_tmp_2d(1:iim,1:jjmp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM,"ok_instan",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + IF(ok_ade) THEN + zx_tmp_2d(1:iim,1:jjmp1)=1. + ELSE + zx_tmp_2d(1:iim,1:jjmp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM,"ok_ade",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + IF(ok_aie) THEN + zx_tmp_2d(1:iim,1:jjmp1)=1. + ELSE + zx_tmp_2d(1:iim,1:jjmp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM,"ok_aie",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + +c +c Champs 2D: +c + zx_tmp_2d(1:iim,1:jjmp1)=bl95_b0 + CALL histwrite(nid_ctesGCM,"bl95_b0",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=bl95_b1 + CALL histwrite(nid_ctesGCM,"bl95_b1",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=ip_ebil_phy + CALL histwrite(nid_ctesGCM,"ip_ebil_phy",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=R_ecc + CALL histwrite(nid_ctesGCM,"R_ecc",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=R_peri + CALL histwrite(nid_ctesGCM,"R_peri",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=R_incl + CALL histwrite(nid_ctesGCM,"R_incl",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=solaire + CALL histwrite(nid_ctesGCM,"solaire",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=co2_ppm + CALL histwrite(nid_ctesGCM,"co2_ppm",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=CH4_ppb + CALL histwrite(nid_ctesGCM,"CH4_ppb",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=N2O_ppb + CALL histwrite(nid_ctesGCM,"N2O_ppb",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=CFC11_ppt + CALL histwrite(nid_ctesGCM,"CFC11_ppt",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=CFC12_ppt + CALL histwrite(nid_ctesGCM,"CFC12_ppt",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=epmax + CALL histwrite(nid_ctesGCM,"epmax",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +! Mais est-il bien raisonable de stoker ces fichiers comme des +! champs 2D... +! WARNING : +! Il faudrait ici ajoute l'ecriture des champs +! cycle_diurne = cycle_diurne_omp +! soil_model = soil_model_omp +! new_oliq = new_oliq_omp +! ok_orodr = ok_orodr_omp +! ok_orolf = ok_orolf_omp +! ok_limitvrai = ok_limitvrai_omp +! nbapp_rad = nbapp_rad_omp +! iflag_con = iflag_con_omp +! qui se trouvaient auparavant dans gcm.def et maintenant dans +! physiq.def. +! Mais regarder d'abord a quoi ca sert ... +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + +c + IF(ok_adj_ema) THEN + zx_tmp_2d(1:iim,1:jjmp1)=1. + ELSE + zx_tmp_2d(1:iim,1:jjmp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM,"ok_adj_ema",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=iflag_clw + CALL histwrite(nid_ctesGCM,"iflag_clw",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=cld_lc_lsc + CALL histwrite(nid_ctesGCM,"cld_lc_lsc",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=cld_lc_con + CALL histwrite(nid_ctesGCM,"cld_lc_con",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=cld_tau_lsc + CALL histwrite(nid_ctesGCM,"cld_tau_lsc",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=cld_tau_con + CALL histwrite(nid_ctesGCM,"cld_tau_con",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=ffallv_lsc + CALL histwrite(nid_ctesGCM,"ffallv_lsc",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=ffallv_con + CALL histwrite(nid_ctesGCM,"ffallv_con",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=coef_eva + CALL histwrite(nid_ctesGCM,"coef_eva",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + IF(reevap_ice) THEN + zx_tmp_2d(1:iim,1:jjmp1)=1. + ELSE + zx_tmp_2d(1:iim,1:jjmp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM,"reevap_ice",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=iflag_cldcon + CALL histwrite(nid_ctesGCM,"iflag_cldcon",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=iflag_pdf + CALL histwrite(nid_ctesGCM,"iflag_pdf",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=fact_cldcon + CALL histwrite(nid_ctesGCM,"fact_cldcon",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=facttemps + CALL histwrite(nid_ctesGCM,"facttemps",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + IF(ok_newmicro) THEN + zx_tmp_2d(1:iim,1:jjmp1)=1. + ELSE + zx_tmp_2d(1:iim,1:jjmp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM,"ok_newmicro",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=ratqsbas + CALL histwrite(nid_ctesGCM,"ratqsbas",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=ratqshaut + CALL histwrite(nid_ctesGCM,"ratqshaut",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=rad_froid + CALL histwrite(nid_ctesGCM,"rad_froid",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=rad_chau1 + CALL histwrite(nid_ctesGCM,"rad_chau1",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=rad_chau2 + CALL histwrite(nid_ctesGCM,"rad_chau2",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=top_height + CALL histwrite(nid_ctesGCM,"top_height",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=overlap + CALL histwrite(nid_ctesGCM,"overlap",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=cdmmax + CALL histwrite(nid_ctesGCM,"cdmmax",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=cdhmax + CALL histwrite(nid_ctesGCM,"cdhmax",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=ksta + CALL histwrite(nid_ctesGCM,"ksta",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=ksta_ter + CALL histwrite(nid_ctesGCM,"ksta_ter",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + IF(ok_kzmin) THEN + zx_tmp_2d(1:iim,1:jjmp1)=1. + ELSE + zx_tmp_2d(1:iim,1:jjmp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM,"ok_kzmin",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=iflag_pbl + CALL histwrite(nid_ctesGCM,"iflag_pbl",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=lev_histhf + CALL histwrite(nid_ctesGCM,"lev_histhf",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=lev_histday + CALL histwrite(nid_ctesGCM,"lev_histday",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=lev_histmth + CALL histwrite(nid_ctesGCM,"lev_histmth",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + IF(ok_isccp) THEN + zx_tmp_2d(1:iim,1:jjmp1)=1. + ELSE + zx_tmp_2d(1:iim,1:jjmp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM,"ok_isccp",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=lonmin_ins + CALL histwrite(nid_ctesGCM,"lonmin_ins",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=lonmax_ins + CALL histwrite(nid_ctesGCM,"lonmax_ins",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=latmin_ins + CALL histwrite(nid_ctesGCM,"latmin_ins",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=latmax_ins + CALL histwrite(nid_ctesGCM,"latmax_ins",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=ecrit_ins + CALL histwrite(nid_ctesGCM,"ecrit_ins",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=ecrit_hf + CALL histwrite(nid_ctesGCM,"ecrit_hf",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=ecrit_day + CALL histwrite(nid_ctesGCM,"ecrit_day",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=ecrit_mth + CALL histwrite(nid_ctesGCM,"ecrit_mth",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=ecrit_tra + CALL histwrite(nid_ctesGCM,"ecrit_tra",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=ecrit_reg + CALL histwrite(nid_ctesGCM,"ecrit_reg",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=freq_ISCCP + CALL histwrite(nid_ctesGCM,"freq_ISCCP",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_2d(1:iim,1:jjmp1)=ecrit_ISCCP + CALL histwrite(nid_ctesGCM,"ecrit_ISCCP",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c +c================================================================= +c================================================================= +c================================================================= +c + if (ok_sync) then + call histsync(nid_ctesGCM) + endif +c + ENDIF ! mono_cpu Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/yamada.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/yamada.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/yamada.F (revision 1280) @@ -0,0 +1,174 @@ +! +! $Header$ +! + SUBROUTINE yamada(ngrid,dt,g,rconst,plev,temp + s ,zlev,zlay,u,v,teta,cd,q2,km,kn,ustar + s ,l_mix) + use dimphy + IMPLICIT NONE +c....................................................................... +cym#include "dimensions.h" +cym#include "dimphy.h" +c....................................................................... +c +c dt : pas de temps +c g : g +c zlev : altitude a chaque niveau (interface inferieure de la couche +c de meme indice) +c zlay : altitude au centre de chaque couche +c u,v : vitesse au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c teta : temperature potentielle au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c cd : cdrag +c (en entree : la valeur au debut du pas de temps) +c q2 : $q^2$ au bas de chaque couche +c (en entree : la valeur au debut du pas de temps) +c (en sortie : la valeur a la fin du pas de temps) +c km : diffusivite turbulente de quantite de mouvement (au bas de chaque +c couche) +c (en sortie : la valeur a la fin du pas de temps) +c kn : diffusivite turbulente des scalaires (au bas de chaque couche) +c (en sortie : la valeur a la fin du pas de temps) +c +c....................................................................... + REAL dt,g,rconst + real plev(klon,klev+1),temp(klon,klev) + real ustar(klon),snstable + REAL zlev(klon,klev+1) + REAL zlay(klon,klev) + REAL u(klon,klev) + REAL v(klon,klev) + REAL teta(klon,klev) + REAL cd(klon) + REAL q2(klon,klev+1) + REAL km(klon,klev+1) + REAL kn(klon,klev+1) + integer l_mix,ngrid + + + integer nlay,nlev +cym PARAMETER (nlay=klev) +cym PARAMETER (nlev=klev+1) + + logical first + save first + data first/.true./ +c$OMP THREADPRIVATE(first) + + integer ig,k + + real ri,zrif,zalpha,zsm + real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev) + + real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1) + real l(klon,klev+1),l0(klon) + + real sq(klon),sqz(klon),zz(klon,klev+1) + integer iter + + real ric,rifc,b1,kap + save ric,rifc,b1,kap + data ric,rifc,b1,kap/0.195,0.191,16.6,0.3/ +c$OMP THREADPRIVATE(ric,rifc,b1,kap) + + real frif,falpha,fsm + + frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156)) + falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri) + fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri)) + + nlay=klev + nlev=klev+1 + + if (0.eq.1.and.first) then + do ig=1,1000 + ri=(ig-800.)/500. + if (ri.lt.ric) then + zrif=frif(ri) + else + zrif=rifc + endif + if(zrif.lt.0.16) then + zalpha=falpha(zrif) + zsm=fsm(zrif) + else + zalpha=1.12 + zsm=0.085 + endif + print*,ri,rif,zalpha,zsm + enddo + first=.false. + endif + +c Correction d'un bug sauvage a verifier. +c do k=2,nlev + do k=2,nlay + do ig=1,ngrid + dz(ig,k)=zlay(ig,k)-zlay(ig,k-1) + m2(ig,k)=((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig,k-1))**2) + s /(dz(ig,k)*dz(ig,k)) + n2(ig,k)=g*2.*(teta(ig,k)-teta(ig,k-1)) + s /(teta(ig,k-1)+teta(ig,k)) /dz(ig,k) + ri=n2(ig,k)/max(m2(ig,k),1.e-10) + if (ri.lt.ric) then + rif(ig,k)=frif(ri) + else + rif(ig,k)=rifc + endif + if(rif(ig,k).lt.0.16) then + alpha(ig,k)=falpha(rif(ig,k)) + sm(ig,k)=fsm(rif(ig,k)) + else + alpha(ig,k)=1.12 + sm(ig,k)=0.085 + endif + zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k) + enddo + enddo + +c iterration pour determiner la longueur de melange + + do ig=1,ngrid + l0(ig)=100. + enddo + do k=2,klev-1 + do ig=1,ngrid + l(ig,k)=l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) + enddo + enddo + + do iter=1,10 + do ig=1,ngrid + sq(ig)=1.e-10 + sqz(ig)=1.e-10 + enddo + do k=2,klev-1 + do ig=1,ngrid + q2(ig,k)=l(ig,k)**2*zz(ig,k) + l(ig,k)=min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) + s ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) + zq=sqrt(q2(ig,k)) + sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1)) + sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1)) + enddo + enddo + do ig=1,ngrid + l0(ig)=0.2*sqz(ig)/sq(ig) + enddo +c(abd 3 5 2) print*,'ITER=',iter,' L0=',l0 + + enddo + + do k=2,klev + do ig=1,ngrid + l(ig,k)=min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) + s ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) + q2(ig,k)=l(ig,k)**2*zz(ig,k) + km(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k) + kn(ig,k)=km(ig,k)*alpha(ig,k) + enddo + enddo + + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/yamada4.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/yamada4.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/yamada4.F (revision 1280) @@ -0,0 +1,493 @@ +! +! $Header$ +! + SUBROUTINE yamada4(ngrid,dt,g,rconst,plev,temp + s ,zlev,zlay,u,v,teta,cd,q2,km,kn,kq,ustar + s ,iflag_pbl) + use dimphy + IMPLICIT NONE +#include "iniprint.h" +c....................................................................... +cym#include "dimensions.h" +cym#include "dimphy.h" +c....................................................................... +c +c dt : pas de temps +c g : g +c zlev : altitude a chaque niveau (interface inferieure de la couche +c de meme indice) +c zlay : altitude au centre de chaque couche +c u,v : vitesse au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c teta : temperature potentielle au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c cd : cdrag +c (en entree : la valeur au debut du pas de temps) +c q2 : $q^2$ au bas de chaque couche +c (en entree : la valeur au debut du pas de temps) +c (en sortie : la valeur a la fin du pas de temps) +c km : diffusivite turbulente de quantite de mouvement (au bas de chaque +c couche) +c (en sortie : la valeur a la fin du pas de temps) +c kn : diffusivite turbulente des scalaires (au bas de chaque couche) +c (en sortie : la valeur a la fin du pas de temps) +c +c iflag_pbl doit valoir entre 6 et 9 +c l=6, on prend systematiquement une longueur d'equilibre +c iflag_pbl=6 : MY 2.0 +c iflag_pbl=7 : MY 2.0.Fournier +c iflag_pbl=8 : MY 2.5 +c iflag_pbl=9 : un test ? + +c....................................................................... + REAL dt,g,rconst + real plev(klon,klev+1),temp(klon,klev) + real ustar(klon) + real kmin,qmin,pblhmin(klon),coriol(klon) + REAL zlev(klon,klev+1) + REAL zlay(klon,klev) + REAL u(klon,klev) + REAL v(klon,klev) + REAL teta(klon,klev) + REAL cd(klon) + REAL q2(klon,klev+1),qpre + REAL unsdz(klon,klev) + REAL unsdzdec(klon,klev+1) + + REAL km(klon,klev+1) + REAL kmpre(klon,klev+1),tmp2 + REAL mpre(klon,klev+1) + REAL kn(klon,klev+1) + REAL kq(klon,klev+1) + real ff(klon,klev+1),delta(klon,klev+1) + real aa(klon,klev+1),aa0,aa1 + integer iflag_pbl,ngrid + + + integer nlay,nlev +cym PARAMETER (nlay=klev) +cym PARAMETER (nlev=klev+1) + + logical first + integer ipas + save first,ipas +cFH/IM data first,ipas/.true.,0/ + data first,ipas/.false.,0/ +c$OMP THREADPRIVATE( first,ipas) + + integer ig,k + + + real ri,zrif,zalpha,zsm,zsn + real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev) + + real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1) + real dtetadz(klon,klev+1) + real m2cstat,mcstat,kmcstat + real l(klon,klev+1) + real,allocatable,save :: l0(:) +c$OMP THREADPRIVATE(l0) + real sq(klon),sqz(klon),zz(klon,klev+1) + integer iter + + real ric,rifc,b1,kap + save ric,rifc,b1,kap + data ric,rifc,b1,kap/0.195,0.191,16.6,0.4/ +c$OMP THREADPRIVATE(ric,rifc,b1,kap) + real frif,falpha,fsm + real fl,zzz,zl0,zq2,zn2 + +cym real rino(klon,klev+1),smyam(klon,klev),styam(klon,klev) +cym s ,lyam(klon,klev),knyam(klon,klev) +cym s ,w2yam(klon,klev),t2yam(klon,klev) + real,allocatable,save,dimension(:,:) :: rino,smyam,styam,lyam, + s knyam,w2yam,t2yam +cym common/pbldiag/rino,smyam,styam,lyam,knyam,w2yam,t2yam +c$OMP THREADPRIVATE(rino,smyam,styam,lyam,knyam,w2yam,t2yam) + logical,save :: firstcall=.true. +c$OMP THREADPRIVATE(firstcall) + frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156)) + falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri) + fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri)) + fl(zzz,zl0,zq2,zn2)= + s max(min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) + s ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) ,1.) + + + nlay=klev + nlev=klev+1 + + if (firstcall) then + allocate(rino(klon,klev+1),smyam(klon,klev),styam(klon,klev)) + allocate(lyam(klon,klev),knyam(klon,klev)) + allocate(w2yam(klon,klev),t2yam(klon,klev)) + allocate(l0(klon)) + firstcall=.false. + endif + + + if (.not.(iflag_pbl.ge.6.and.iflag_pbl.le.9)) then + stop'probleme de coherence dans appel a MY' + endif + + ipas=ipas+1 + if (0.eq.1.and.first) then + do ig=1,1000 + ri=(ig-800.)/500. + if (ri.lt.ric) then + zrif=frif(ri) + else + zrif=rifc + endif + if(zrif.lt.0.16) then + zalpha=falpha(zrif) + zsm=fsm(zrif) + else + zalpha=1.12 + zsm=0.085 + endif +c print*,ri,rif,zalpha,zsm + enddo + endif + +c....................................................................... +c les increments verticaux +c....................................................................... +c +c!!!!! allerte !!!!!c +c!!!!! zlev n'est pas declare a nlev !!!!!c +c!!!!! ----> + DO ig=1,ngrid + zlev(ig,nlev)=zlay(ig,nlay) + & +( zlay(ig,nlay) - zlev(ig,nlev-1) ) + ENDDO +c!!!!! <---- +c!!!!! allerte !!!!!c +c + DO k=1,nlay + DO ig=1,ngrid + unsdz(ig,k)=1.E+0/(zlev(ig,k+1)-zlev(ig,k)) + ENDDO + ENDDO + DO ig=1,ngrid + unsdzdec(ig,1)=1.E+0/(zlay(ig,1)-zlev(ig,1)) + ENDDO + DO k=2,nlay + DO ig=1,ngrid + unsdzdec(ig,k)=1.E+0/(zlay(ig,k)-zlay(ig,k-1)) + ENDDO + ENDDO + DO ig=1,ngrid + unsdzdec(ig,nlay+1)=1.E+0/(zlev(ig,nlay+1)-zlay(ig,nlay)) + ENDDO +c +c....................................................................... + + do k=2,klev + do ig=1,ngrid + dz(ig,k)=zlay(ig,k)-zlay(ig,k-1) + m2(ig,k)=((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig,k-1))**2) + s /(dz(ig,k)*dz(ig,k)) + dtetadz(ig,k)=(teta(ig,k)-teta(ig,k-1))/dz(ig,k) + n2(ig,k)=g*2.*dtetadz(ig,k)/(teta(ig,k-1)+teta(ig,k)) +c n2(ig,k)=0. + ri=n2(ig,k)/max(m2(ig,k),1.e-10) + if (ri.lt.ric) then + rif(ig,k)=frif(ri) + else + rif(ig,k)=rifc + endif + if(rif(ig,k).lt.0.16) then + alpha(ig,k)=falpha(rif(ig,k)) + sm(ig,k)=fsm(rif(ig,k)) + else + alpha(ig,k)=1.12 + sm(ig,k)=0.085 + endif + zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k) +c print*,'RIF L=',k,rif(ig,k),ri*alpha(ig,k) + + + enddo + enddo + + +c==================================================================== +c Au premier appel, on determine l et q2 de facon iterative. +c iterration pour determiner la longueur de melange + + + if (first.or.iflag_pbl.eq.6) then + do ig=1,ngrid + l0(ig)=10. + enddo + do k=2,klev-1 + do ig=1,ngrid + l(ig,k)=l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) + enddo + enddo + + do iter=1,10 + do ig=1,ngrid + sq(ig)=1.e-10 + sqz(ig)=1.e-10 + enddo + do k=2,klev-1 + do ig=1,ngrid + q2(ig,k)=l(ig,k)**2*zz(ig,k) + l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k)) + zq=sqrt(q2(ig,k)) + sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1)) + sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1)) + enddo + enddo + do ig=1,ngrid + l0(ig)=0.2*sqz(ig)/sq(ig) +c l0(ig)=30. + enddo +c print*,'ITER=',iter,' L0=',l0 + + enddo + +c print*,'Fin de l initialisation de q2 et l0' + + endif ! first + +c==================================================================== +c Calcul de la longueur de melange. +c==================================================================== + +c Mise a jour de l0 + do ig=1,ngrid + sq(ig)=1.e-10 + sqz(ig)=1.e-10 + enddo + do k=2,klev-1 + do ig=1,ngrid + zq=sqrt(q2(ig,k)) + sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1)) + sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1)) + enddo + enddo + do ig=1,ngrid + l0(ig)=0.2*sqz(ig)/sq(ig) +c l0(ig)=30. + enddo +c print*,'ITER=',iter,' L0=',l0 +c calcul de l(z) + do k=2,klev + do ig=1,ngrid + l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k)) + if(first) then + q2(ig,k)=l(ig,k)**2*zz(ig,k) + endif + enddo + enddo + +c==================================================================== +c Yamada 2.0 +c==================================================================== + if (iflag_pbl.eq.6) then + + do k=2,klev + do ig=1,ngrid + q2(ig,k)=l(ig,k)**2*zz(ig,k) + enddo + enddo + + + else if (iflag_pbl.eq.7) then +c==================================================================== +c Yamada 2.Fournier +c==================================================================== + +c Calcul de l, km, au pas precedent + do k=2,klev + do ig=1,ngrid +c print*,'SMML=',sm(ig,k),l(ig,k) + delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k)) + kmpre(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k) + mpre(ig,k)=sqrt(m2(ig,k)) +c print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k) + enddo + enddo + + do k=2,klev-1 + do ig=1,ngrid + m2cstat=max(alpha(ig,k)*n2(ig,k)+delta(ig,k)/b1,1.e-12) + mcstat=sqrt(m2cstat) + +c print*,'M2 L=',k,mpre(ig,k),mcstat +c +c -----{puis on ecrit la valeur de q qui annule l'equation de m +c supposee en q3} +c + IF (k.eq.2) THEN + kmcstat=1.E+0 / mcstat + & *( unsdz(ig,k)*kmpre(ig,k+1) + & *mpre(ig,k+1) + & +unsdz(ig,k-1) + & *cd(ig) + & *( sqrt(u(ig,3)**2+v(ig,3)**2) + & -mcstat/unsdzdec(ig,k) + & -mpre(ig,k+1)/unsdzdec(ig,k+1) )**2) + & /( unsdz(ig,k)+unsdz(ig,k-1) ) + ELSE + kmcstat=1.E+0 / mcstat + & *( unsdz(ig,k)*kmpre(ig,k+1) + & *mpre(ig,k+1) + & +unsdz(ig,k-1)*kmpre(ig,k-1) + & *mpre(ig,k-1) ) + & /( unsdz(ig,k)+unsdz(ig,k-1) ) + ENDIF +c print*,'T2 L=',k,tmp2 + tmp2=kmcstat + & /( sm(ig,k)/q2(ig,k) ) + & /l(ig,k) + q2(ig,k)=max(tmp2,1.e-12)**(2./3.) +c print*,'Q2 L=',k,q2(ig,k) +c + enddo + enddo + + else if (iflag_pbl.ge.8) then +c==================================================================== +c Yamada 2.5 a la Didi +c==================================================================== + + +c Calcul de l, km, au pas precedent + do k=2,klev + do ig=1,ngrid +c print*,'SMML=',sm(ig,k),l(ig,k) + delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k)) + if (delta(ig,k).lt.1.e-20) then +c print*,'ATTENTION L=',k,' Delta=',delta(ig,k) + delta(ig,k)=1.e-20 + endif + km(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k) + aa0= + s (m2(ig,k)-alpha(ig,k)*n2(ig,k)-delta(ig,k)/b1) + aa1= + s (m2(ig,k)*(1.-rif(ig,k))-delta(ig,k)/b1) +c abder print*,'AA L=',k,aa0,aa1,aa1/max(m2(ig,k),1.e-20) + aa(ig,k)=aa1*dt/(delta(ig,k)*l(ig,k)) +c print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k) + qpre=sqrt(q2(ig,k)) + if (iflag_pbl.eq.8 ) then + if (aa(ig,k).gt.0.) then + q2(ig,k)=(qpre+aa(ig,k)*qpre*qpre)**2 + else + q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2 + endif + else ! iflag_pbl=9 + if (aa(ig,k)*qpre.gt.0.9) then + q2(ig,k)=(qpre*10.)**2 + else + q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2 + endif + endif + q2(ig,k)=min(max(q2(ig,k),1.e-10),1.e4) +c print*,'Q2 L=',k,q2(ig,k),qpre*qpre + enddo + enddo + + endif ! Fin du cas 8 + +c print*,'OK8' + +c==================================================================== +c Calcul des coefficients de m�ange +c==================================================================== + do k=2,klev +c print*,'k=',k + do ig=1,ngrid +cabde print*,'KML=',l(ig,k),q2(ig,k),sm(ig,k) + zq=sqrt(q2(ig,k)) + km(ig,k)=l(ig,k)*zq*sm(ig,k) + kn(ig,k)=km(ig,k)*alpha(ig,k) + kq(ig,k)=l(ig,k)*zq*0.2 +c print*,'KML=',km(ig,k),kn(ig,k) + enddo + enddo + +c if (iflag_pbl.ge.7..and.0.eq.1) then +c q2(:,1)=q2(:,2) +c call vdif_q2(dt,g,rconst,plev,temp,kq,q2) +c endif + +c Traitement des cas noctrunes avec l'introduction d'une longueur +c minilale. + +c==================================================================== +c Traitement particulier pour les cas tres stables. +c D'apres Holtslag Boville. + + if (prt_level>1) THEN + print*,'YAMADA4 0' + endif !(prt_level>1) THEN + do ig=1,ngrid + coriol(ig)=1.e-4 + pblhmin(ig)=0.07*ustar(ig)/max(abs(coriol(ig)),2.546e-5) + enddo + +! print*,'pblhmin ',pblhmin +CTest a remettre 21 11 02 +c test abd 13 05 02 if(0.eq.1) then + if(1.eq.1) then + do k=2,klev + do ig=1,ngrid + if (teta(ig,2).gt.teta(ig,1)) then + qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2 + kmin=kap*zlev(ig,k)*qmin + else + kmin=-1. ! kmin n'est utilise que pour les SL stables. + endif + if (kn(ig,k).lt.kmin.or.km(ig,k).lt.kmin) then +c print*,'Seuil min Km K=',k,kmin,km(ig,k),kn(ig,k) +c s ,sqrt(q2(ig,k)),pblhmin(ig),qmin/sm(ig,k) + kn(ig,k)=kmin + km(ig,k)=kmin + kq(ig,k)=kmin +c la longueur de melange est suposee etre l= kap z +c K=l q Sm d'ou q2=(K/l Sm)**2 + q2(ig,k)=(qmin/sm(ig,k))**2 + endif + enddo + enddo + endif + + if (prt_level>1) THEN + print*,'YAMADA4 1' + endif !(prt_level>1) THEN +c Diagnostique pour stokage + + if(1.eq.0)then + rino=rif + smyam(1:ngrid,1)=0. + styam(1:ngrid,1)=0. + lyam(1:ngrid,1)=0. + knyam(1:ngrid,1)=0. + w2yam(1:ngrid,1)=0. + t2yam(1:ngrid,1)=0. + + smyam(1:ngrid,2:klev)=sm(1:ngrid,2:klev) + styam(1:ngrid,2:klev)=sm(1:ngrid,2:klev)*alpha(1:ngrid,2:klev) + lyam(1:ngrid,2:klev)=l(1:ngrid,2:klev) + knyam(1:ngrid,2:klev)=kn(1:ngrid,2:klev) + +c Estimations de w'2 et T'2 d'apres Abdela et McFarlane + + w2yam(1:ngrid,2:klev)=q2(1:ngrid,2:klev)*0.24 + s +lyam(1:ngrid,2:klev)*5.17*kn(1:ngrid,2:klev) + s *n2(1:ngrid,2:klev)/sqrt(q2(1:ngrid,2:klev)) + + t2yam(1:ngrid,2:klev)=9.1*kn(1:ngrid,2:klev) + s *dtetadz(1:ngrid,2:klev)**2 + s /sqrt(q2(1:ngrid,2:klev))*lyam(1:ngrid,2:klev) + endif + +c print*,'OKFIN' + first=.false. + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/zilch.F =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/zilch.F (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/zilch.F (revision 1280) @@ -0,0 +1,16 @@ +! +! $Header$ +! + subroutine zilch(x,m) +c +c Zero the real array x dimensioned m. +c + implicit none +c + integer m,i + real x(m) + do 1 i=1,m + x(i)= 0.0 + 1 continue + return + end Index: /LMDZ4/branches/LMDZ4-dev-20091210/makegcm =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/makegcm (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/makegcm (revision 1280) @@ -0,0 +1,1092 @@ +#!/bin/csh +# +# $Id$ +# +#set verbose echo +######################################################################## +# options par defaut pour la commande make +######################################################################## +set dim="96x71x19" +set physique=lmd +set phys="PHYS=$physique" +set include='-I$(LIBF)/grid -I$(LIBF)/bibio -I$(LIBF)/filtrez -I. ' +set filtre=filtrez +set grille=reg +set couple=false +set veget=false +set chimie=false +set psmile=true +set parallel=false +set vampir=false +set OPT_STACK='-Wf,-init stack=nan' +set OPT_STACK=' ' +set OPTIMI='-C debug -eC ' +set OPTIMI=' -ftrace ' +set OPT_LINUX='-O3' +set OPT_LINUX="-i4 -r8 -O3" +set io=ioipsl +set cosp=false + +set FC_LINUX=g95 +#set FC_LINUX=pgf90 +if ( $FC_LINUX == g95 ) then + set OPT_LINUX="-i4 -r8 -O3" +else + # pgf90 options + set OPT_LINUX="-i4 -r8 -O2 -Munroll -Mnoframe -Mautoinline -Mcache_align" +endif + +######################################################################## +# path a changer contenant les sources et les objets du modele +######################################################################## + +###### VERSION LMDZ.4 +#set LMDGCM=/workdir/p86cozic/INCA_dev/LMDZ4 +#setenv LIBOGCM $LMDGCM/libo +set INCALIB=../INCA3/config/lib +#set LMDGCM="`pwd`" +#setenv LIBOGCM $LMDGCM/libo +#set LMDGCM=/d4/fairhead/V4/ +#setenv LIBOGCM $LMDGCM/libo +# +# +#setenv IOIPSLDIR /u/fairhead/modipsl_ioipsl_3/lib_i4r4_32bits +#setenv MODIPSLDIR /u/fairhead/modipsl_ioipsl_3/lib_i4r4_32bits +#setenv NCDFINC /distrib/local/netcdf/pgi_32bits/include +#setenv NCDFLIB /distrib/local/netcdf/pgi_32bits/lib/ +#setenv IOIPSLDIR /data/lfairlmd/Install/LMDZ20090409.trunk/modipsl/lib +#setenv MODIPSLDIR /data/lfairlmd/Install/LMDZ20090409.trunk/modipsl/lib +#setenv NCDFINC /data/lfairlmd/Install/LMDZ20090409.trunk/netcdf-3.6.1/include +#setenv NCDFLIB /data/lfairlmd/Install/LMDZ20090409.trunk/netcdf-3.6.1/lib + + + +setenv localdir "`pwd`" +set MODIPSL=0 +echo $localdir | grep modipsl >& /dev/null +if ( ! $status ) then + set MODIPSL=1 + setenv LMDGCM $localdir + cd ../.. + setenv LIBOGCM "`pwd`/lib" + setenv IOIPSLDIR $LIBOGCM + setenv MODIPSLDIR $LIBOGCM + cd $localdir + if ( `hostname` == rhodes ) then + set NCDFINC=`grep sxnec ../../util/AA_make.gdef| grep NCDF_INC|sed -e "s/^.* =//"` + set NCDFLIB=`grep sxnec ../../util/AA_make.gdef| grep NCDF_LIB|sed -e 's/^.* =//'` + else + if ( `hostname` == nymphea0 ) then + set NCDFINC=`grep fjvpp ../../util/AA_make.gdef| grep NCDF_INC|sed -e "s/^.* =//"` + set NCDFLIB=`grep fjvpp ../../util/AA_make.gdef| grep NCDF_LIB|sed -e 's/^.* =//'` + else if ( `hostname` == mercure ) then + set NCDFINC=`grep sx6nec ../../util/AA_make.gdef| grep NCDF_INC|sed -e "s/^.* =//"` + set NCDFLIB=`grep sx6nec ../../util/AA_make.gdef| grep NCDF_LIB|sed -e 's/^.* =//'` + else if ( `hostname` == brodie ) then + set NCDFINC=`grep sx8brodie ../../util/AA_make.gdef| grep NCDF_INC|sed -e "s/^.* =//"` + set NCDFLIB=`grep sx8brodie ../../util/AA_make.gdef| grep NCDF_LIB|sed -e 's/^.* =//'` + else + echo 'Probleme de definition des variables NCDFINC et NCDFLIB' + endif + endif +else + if ( ! $?LMDGCM ) then + echo You must initialize the variable LMDGCM in your environnement + echo for instance: "setenv LMDGCM /usr/myself/supergcm" in .cshrc + exit + endif + if ( ! $?LIBOGCM ) then + set LIBOGCM=$LMDGCM/libo + endif + if ( ! $?IOIPSLDIR ) then + echo You must initialize the variable IOIPSLDIR in your environnement + echo for instance: "setenv IOIPSLDIR /usr/myself/ioipsl" in .cshrc + exit + else + setenv MODIPSLDIR $IOIPSLDIR + endif + if ( ! $?NCDFLIB ) then + echo You must initialize the variable NCDFLIB in your environnement + echo for instance: "setenv NCDFLIB /usr/myself/netcdf" in .cshrc + exit + endif + if ( ! $?NCDFINC ) then + echo You must initialize the variable NCDFINC in your environnement + echo for instance: "setenv NCDFINC /usr/myself/netcdf" in .cshrc + exit + endif +endif +set model=$LMDGCM +set libo=$LIBOGCM + +######################################################################## +# Les differentes platformes reconnues +######################################################################## + +set HP=0 +set IBM=0 +set SUN=0 +set VPP=0 +set CRAY=0 +set DEC=0 +set LINUX=0 +set NEC=0 +set XNEC=0 +set X6NEC=0 +set X8BRODIE=0 +if ( `uname` == HP-UX ) then + set machine=HP + set HP=1 +else if (`uname` == UNIX_System_V ) then + set machine=VPP + set VPP=1 +else if (`uname` == SunOS ) then + set machine=SUN + set SUN=1 +else if ( `uname` == AIX ) then + set machine=IBM + set IBM=1 +else if ( `uname` == OSF1 ) then + set machine=ALPHA + set DEC=1 +else if ( `uname` == Linux && `hostname` != mercure && `hostname` != brodie ) then + set machine=LINUX + set LINUX=1 +else if ( `hostname` == atlas || `hostname` == axis || `hostname` == etoile ) then + set machine=CRAY + set CRAY=1 +else if ( `uname` == SUPER-UX ) then + set machine=NEC + set NEC=1 +else if ( `hostname` == rhodes) then + set machine=XNEC + set XNEC=1 +else if ( `hostname` == mercure) then + set machine=X6NEC + set X6NEC=1 +else if ( `hostname` == brodie) then + set machine=X8BRODIE + set X8BRODIE=1 +else + echo Vous travaillez sur une machine non prevue par le reglement + exit +endif + +if ( ! -d $libo ) then + mkdir $libo +endif + + +if $VPP then +set netcdf=netcdf_v +else +set netcdf=netcdf +endif +######################################################################## +# Quelques initialisations de variables du shell. +######################################################################## + +set dyn= +set opt_link="" +set adjnt="" +set lcosp="" +set opt_dep="" +set libchimie="" + +set optim="" +set optimbis="" +set optim90="" +set oplink="" + +######################################################################## +# Optimisations par defaut suivant les machines +######################################################################## + +echo "Optimisations par defaut suivant les machines" +set libf=$model/libf +#setenv localdir "LOCAL_DIR=`pwd`" +#setenv localdir "`pwd`" +cd $model +############# +if $CRAY then +############# +# set optim="-Wf'-ei' -dp -Wf'-a static'" + set optimbis=" -DCRAY " + set optim90="-Wp'-P' -DCRAY -p$IOIPSLDIR "'-p$(LIBO) -eiv ' + set optim="$optim90" + if ( $io == "ioipsl" ) then + set oplink="-Wl'-DSTACK=128 -f indef' -L$IOIPSLDIR -lioipsl -L$NCDFLIB -lnetcdf " + else + set oplink="-Wl'-DSTACK=128 -f indef' -L$IOIPSLDIR -L$NCDFLIB -lnetcdf " + endif + set mod_loc_dir=" " + set mod_suffix=" " +################# +else if $SUN then +################# + set optim=" -fast " + set optimbis=" " + set optim90=" -fast -fixed " + set optimtru90=" -fast -free " + if ( $io == "ioipsl" ) then + set opt_link="-lf77compat -L$MODIPSLDIR -lsechiba -lparameters -lstomate -lioipsl -L$NCDFLIB -lnetcdf " + else + set opt_link="-lf77compat -L$MODIPSLDIR -lsechiba -lparameters -lstomate -L$NCDFLIB -lnetcdf " + endif + set mod_loc_dir=$localdir + set mod_suffix=mod +################# +else if $HP then +################# + set optim=" +U77 -O +E1 " + set optimbis=" " +################# +else if $IBM then +################# + set optim=" -O3 -qtune=pwr2 -qarch=pwr2" + set optimbis=" " +################# +else if $VPP then +################# +# set optim="-Dasuxm -On, -g -Ad -Potilax -Eciplume -Si" +# set optimbis=" -Wv,-m3 -Wp,-DVPP -Z $LMDGCM/listage" + set optimbis=" -Wp,-DNC_DOUBLE -Ad -Z $LMDGCM/listage -X9" + set optim90="$optim $optimbis -X9 -w" + set mod_loc_dir=$MODIPSLDIR + set mod_suffix=mod +################# +else if $DEC then +################# + set optim=" " + set optimbis=" " +################# +else if $LINUX then +################# + if ( $FC_LINUX == pgf90 || $FC_LINUX == g95 ) then + set optim=" $OPT_LINUX " + set optim90=" $OPT_LINUX " + set optimtru90=" $OPT_LINUX " + else + echo 'compilateur linux non reconnu' + exit + endif + set mod_loc_dir=$MODIPSLDIR + set mod_suffix=mod +################# +else if $NEC then +################# + set optim90=' -clear -C hopt -float0 -ew -P static -Wf,"-pvctl fullmsg noassume "' + set optimtru90=' -clear -f4 -C hopt -float0 -ew -P static -Wf,"-pvctl fullmsg noassume "' + set optim="$optim90" + set optimbis=" " + if ( $io == "ioipsl" ) then + set opt_link=" -C hopt -float0 -ew -P static -L$MODIPSLDIR -lioipsl $NCDFLIB -lnetcdf_i8r8_v " + else + set opt_link=" -C hopt -float0 -ew -P static -L$MODIPSLDIR $NCDFLIB -lnetcdf_i8r8_v " + endif + set mod_loc_dir="." + set mod_suffix="mod" +################# +else if $XNEC then +################# + set optdbl='-dw -Wf\"-A dbl4\"' + set optim90=' -clear -float0 -f3 -Ep -DNC_DOUBLE -dw -Wf\"-A dbl4\" -R5 -Wf,"-pvctl loopcnt=40000 fullmsg noassume "' + set optimtru90=' -clear -f4 -float0 -Ep -DNC_DOUBLE -dw -Wf\"-A dbl4\" -R2 -R3 -R4 -R5 -Wf,"-pvctl loopcnt=40000 fullmsg noassume"' + set optim="$optim90" + set optimbis=" " + set mod_suffix="mod" + set mod_loc_dir="./" +################# +else if $X6NEC then +################# + set optdbl='-dw -Wf\"-A dbl4\"' + set optim90=' -clear -float0 -size_t64 -P stack -Wf "-ptr byte -init stack=nan -init heap=nan" -Ep -DNC_DOUBLE -dw -Wf\"-A dbl4\" -R5 -Wf,"-pvctl loopcnt=40000 fullmsg noassume "' + set optimtru90=' -clear -f4 -float0 -size_t64 -P stack -Wf "-ptr byte -init stack=nan -init heap=nan" -Ep -DNC_DOUBLE -dw -Wf\"-A dbl4\" -R2 -R3 -R4 -R5 -Wf,"-pvctl loopcnt=40000 fullmsg noassume"' + set optim="$optim90" + set optimbis=" " + set mod_suffix="mod" + set mod_loc_dir="./" +################# +else if $X8BRODIE then +################## + set optdbl='-dw -Wf\"-A dbl4\"' +# set optim90='-P stack -Wf,-pvctl res=whole,-A dbl4,-init stack=nan,-init heap=nan,-ptr byte -EP -R5 -float0 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume" -I/SX/usr/include' + set optim90='-C vopt -Wf,-pvctl res=whole,-A dbl4,-init stack=nan,-init heap=nan,-ptr byte -EP -DNC_DOUBLE -R5 -float0 -dw -Wf,"-pvctl loopcnt=999999 noassume" -I/SX/usr/include' +# set optim90='-C vsafe -P stack -Wf,-pvctl res=whole,-A dbl4,-ptr byte -EP -R5 -float0 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume" -I/SX/usr/include' + set optimtru90="$optim90" + set optim90="$optim90" + set optim="$optim90" + set optimbis=" " + set mod_suffix="mod" + set mod_loc_dir="./" +else + set optim="" + set optimbis=" " +endif + +set nomlib=$machine + +######################################################################## +# lecture des options de mymake +######################################################################## + +top: +if ($#argv > 0) then + switch ($1:q) + + case -h: + +######################################################################## +# Manuel en ligne +######################################################################## +more <> tmp +end +set suf= +foreach i ( `sort tmp | uniq ` ) + set suf=$suf$i +end +if ( ! $IBM ) then + set nomlib="$nomlib$suf" +endif +if ( $DEC ) then + set nomlib=DEC +endif +if ( $IBM ) then + set dim=`echo $dim | sed -en 's/[^0-9]/ /g'` + set dim_=`echo $dim | sed -en 's/[^0-9]/_/g'` +else if ( $SUN ) then + set dim=`echo $dim | sed -e 's/[^0-9]/ /g'` + set dim_=`echo $dim | sed -e 's/[^0-9]/_/g'` +else + set dim_=`echo $dim | sed -e 's/[^0-9]/_/g'` + set dim=`echo $dim | sed -e 's/[^0-9]/ /g'` +endif +set nomlib=${nomlib}${physique}_${dim_}_$grille +## M-A-F nomlib trop long sur CRAY pour ar +if ( $CRAY ) then + set nomlib=F90_${dim_} +endif +if ( $NEC || $XNEC || $X6NEC || $X8BRODIE ) then + set nomlib=F90_${dim_}_'phy'${physique}${FLAG_PARA} +endif +echo calcul de la dimension +set dimc=`echo $dim | wc -w` + +if ( "$dimc" == "2" ) then +set include="$include "'-I$(LIBF)/dyn2d ' +set dimh=$dim +else +set include="$include "'-I$(LIBF)/dyn3d${FLAG_PARA} ' +set dimh=`echo $dim | awk ' { print $1 "." $2 } '` +endif +echo $dimc + +######################################################################## +# path pour les #include +######################################################################## + +if ( $XNEC ) then + set include="$include -I$NCDFINC -I$IOIPSLDIR" +else + set include="$include -I$NCDFINC -I$IOIPSLDIR" +endif +echo $include + +######################################################################## +# Gestion des dimensions du modele. +# on cree ou remplace le fichier des dimensions +######################################################################## + +cd $libf/grid +if ( -f dimensions.h ) then +echo 'ATTENTION: vous etes sans doute en train de compiler le modele par ailleurs' +echo "Attendez que la premiere compilation soit terminee pour relancer la suivante." +echo "Si vous etes sur que vous ne compilez pas le modele par ailleurs," +echo vous pouvez continuer en repondant oui. +echo "Voulez-vous vraiment continuer?" +if ( $< == "oui" ) then +\rm -f $libf/grid/dimensions.h +else +exit +endif +endif + +cd dimension +./makdim $dim +cat $libf/grid/dimensions.h + +cd $LMDGCM +set libo=$libo/$nomlib +if ( ! -d $libo ) then + mkdir $libo + cd $model +endif + +######################################################################## +# Differentes dynamiques (3d, 2d, 1d) +######################################################################## + +set dimension=`echo $dim | wc -w` +echo dimension $dimension +if ( $dimension == 1 ) then +echo pas de dynamique +set dyn="L_DYN= DYN= L_FILTRE= DIRMAIN=phy$physique " +endif +endif +cd $model +if ( $dimension == 3 ) then +cd libf/grid +\rm fxyprim.h +cp -p fxy_${grille}.h fxyprim.h +endif + +###################################################################### +# Traitement special pour le nouveau rayonnement de Laurent Li. +###################################################################### + +#if ( -f $libf/phy$physique/raddim.h ) then +# if ( -f $libf/phy$physique/raddim.$dimh.h ) then +# \rm -f $libf/phy$physique/raddim.h +# cp -p $libf/phy$physique/raddim.$dimh.h $libf/phy$physique/raddim.h +# echo $libf/phy$physique/raddim.$dimh.h +# cat $libf/phy$physique/raddim.$dimh.h +# cat $libf/phy$physique/raddim.h +# else +# echo On peut diminuer la taille de l executable en creant +# echo le fichier $libf/phy$physique/raddim.$dimh.h +# \cp -p $libf/phy$physique/raddim.defaut.h $libf/phy$physique/raddim.h +# endif +#endif + +###################################################################### +# Gestion du filtre qui n'existe qu'en 3d. +###################################################################### + +if ( `expr $dimc \> 2` == 1 ) then + set filtre="FILTRE=$filtre" +else + set filtre="FILTRE= L_FILTRE= " +endif +echo MACRO FILTRE $filtre + +echo $dimc + +######################################################################## +# Avant de lancer le make, on recree le makefile si necessaire +######################################################################## +######################################################################## +# c'est a dire dans 3 cas: +# 1. si la liste des fichiers .F et .h a ete modifiee depuis la +# derniere creation du makefile +# 2. si le fichier contenant cette liste "liste_des_sources" +# n'existe pas. +# 3. Si le makefile n'existe pas. +######################################################################## +########################################## +# On adapte d'abord certains include à F90 +########################################## +########################################## +cd $model +find libf -name '*.[Fh]' -print >! tmp77 +find libf -name '*.[Fh]' -exec egrep -i " *use *ioipsl" {} \; -print >! tmp90 +find libf -name '*.[Fh]90' -print >> tmp90 + +if ( `diff tmp77 liste_des_sources_f77 | wc -w` \ + || `diff tmp90 liste_des_sources_f90 | wc -w` \ + || ! -f makefile \ + || ! -f liste_des_sources_f90 \ + || ! -f liste_des_sources_f77 ) then + echo les fichiers suivants ont ete crees ou detruits + echo ou les fichiers suivants sont passes ou ne sont plus en Fortran 90 + diff liste_des_sources_f77 tmp77 + diff liste_des_sources_f90 tmp90 + \cp tmp77 liste_des_sources_f77 + \cp tmp90 liste_des_sources_f90 + echo On recree le makefile + ./create_make_gcm >! tmp + \mv tmp makefile + echo Nouveau makefile cree. +endif + +######################################################################## +# Execution de la comande make +######################################################################## + +echo PHYSIQUE $phys +echo dynamique $dyn $dimension +echo OPTIM="$optim" $filtre LIBO=$libo $dyn PHYS=$phys DIM=$dimc PROG=$code +echo PATH pour les fichiers INCLUDE $include +echo OPLINK="$oplink" + +################# +if $HP then +################# + set f77='fort77 +OP' + set f90='jensaisrien' + set opt_link="$opt_link -lm" +################# +else if $VPP then +################# + set f77=frt + set f90=$f77 + if ($couple == true) then + set opt_link="-Wg,-c $MODIPSLDIR/liboasis2.4_mpi2.a /usr/lang/mpi2/lib64/libmpi.a /usr/lang/mpi2/lib64/libmp.a -L$MODIPSLDIR -lioipsl /usr/local/lib/lib64/libnetcdf_cc_31.a" + set oplink="-Wl,-t,-P,-dy " + else + set opt_link="-Wg,-c -L$MODIPSLDIR -lioipsl /usr/local/lib/lib64/libnetcdf_cc_31.a" + set oplink="-Wl,-t,-dy " + endif + if ($veget == true) then + set opt_link="$opt_link $link_veget -lioipsl /usr/local/lib/lib64/libnetcdf_cc_31.a" + endif +################# +else if $CRAY then +################# + set f77=f90 + set f90=f90 +################# +else if $LINUX then +################# +# set f77=pgf90 +# set f90=pgf90 + set f77=$FC_LINUX + set f90=$FC_LINUX + if ( $FC_LINUX == 'pgf90' ) then + if ( $io == "ioipsl" ) then + set opt_link=" -L$MODIPSLDIR $link_veget -L$NCDFLIB -lioipsl -lnetcdf " + else + set opt_link=" -L$MODIPSLDIR $link_veget -L$NCDFLIB -lnetcdf " + endif + else if ($FC_LINUX == 'g95') then + if ( $io == "ioipsl" ) then + set opt_link="-L$MODIPSLDIR $link_veget -lioipsl -L$NCDFLIB -lnetcdf -lioipsl -lnetcdf " + else + set opt_link="-L$MODIPSLDIR $link_veget -lioipsl -L$NCDFLIB -lnetcdf -lnetcdf " + endif + else + set opt_link=" " + endif +################# +else if $SUN then +################# + set f77=f90 + set f90=f90 + if ( $io == "ioipsl" ) then + set opt_link="-lf77compat -L$MODIPSLDIR $link_veget -lioipsl -L$NCDFLIB -lnetcdf " + else + set opt_link="-lf77compat -L$MODIPSLDIR $link_veget -L$NCDFLIB -lnetcdf " + endif +################# +else if $NEC then +################# + set f77=f90 -ftrace + set f90=f90 -ftrace + set opt_link="-L$MODIPSLDIR" + if ($veget == true) then + set opt_link="$opt_link $link_veget" + endif + if ($couple == true) then + set opt_link="$opt_link -lioipsl -loasis2.4_mpi2 -float0 -ew -P static $NCDFLIB " + else + set opt_link="$opt_link -L$MODIPSLDIR -lioipsl -float0 -ew -P static $NCDFLIB " + endif + set mod_loc_dir="./" +################# +else if $XNEC then +################# + set f77="sxmpif90 -ftrace" + set f90="sxmpif90 -ftrace" + if $MODIPSL then + set opt_link="-L$MODIPSLDIR" + if ($veget == true) then + set opt_link="$opt_link $link_veget" + endif + if ($couple == true) then + if ($psmile == true) then + set opt_link="$opt_link -lsxioipsl -float0 $optdbl -P static $NCDFLIB " + else + set opt_link="$opt_link -lsxioipsl -loasis2.4_mpi2 -float0 $optdbl -P static $NCDFLIB " + endif + else + set opt_link="$opt_link -lsxioipsl -float0 $optdbl -P static $NCDFLIB " + endif + else + if ($couple == true) then + set opt_link="-L$MODIPSLDIR" + set opt_link="$opt_link $link_veget -lsxioipsl -loasis2.4_mpi2 -float0 $optdbl -P static $NCDFLIB " + else + set opt_link=" -C hopt -float0 $optdbl -P static -L$MODIPSLDIR $link_veget -lsxioipsl $NCDFLIB " + endif + endif + set mod_loc_dir="./" +################## +else if $X6NEC then +################## + set f77=sxmpif90 + set f90=sxmpif90 + if $MODIPSL then + set opt_link="$opt_link -L$MODIPSLDIR" + if ($veget == true) then + set opt_link="$opt_link $link_veget" + endif + if ($couple == true) then + if ($psmile == true) then + set opt_link="$opt_link -lsxioipsl -float0 -size_t64 $optdbl -P static $NCDFLIB " + else + set opt_link="$opt_link -lsxioipsl -loasis2.4_mpi2 -float0 -size_t64 $optdbl -P static $NCDFLIB " + endif + else + set opt_link="$opt_link -lsxioipsl -float0 -size_t64 $optdbl -P static $NCDFLIB " + endif + else +# set opt_link=" -float0 -size_t64 $optdbl -P static -L$MODIPSLDIR -lsxsechiba -lsxparameters -lsxstomate -lsxioipsl $NCDFLIB " + set opt_link=" $opt_link -float0 -size_t64 $optdbl -P static -L$MODIPSLDIR -lsxioipsl $NCDFLIB " + + endif + set mod_loc_dir="./" +################## +else if $X8BRODIE then +################## + set f77=sxmpif90 + set f90=sxmpif90 + if $MODIPSL then + set opt_link="$opt_link -float0 -Wf,-A dbl4 -L$MODIPSLDIR -lblas" + if ($veget == true) then + set opt_link="$opt_link $link_veget" + endif + if ($couple == true) then + set opt_link="$opt_link -lsxioipsl -float0 $optdbl -P static $NCDFLIB " + else + set opt_link="$opt_link -lsxioipsl -float0 $optdbl -P static $NCDFLIB " + endif + else +# set opt_link=" -float0 $optdbl -P static -L$MODIPSLDIR -lsxsechiba -lsxparameters -lsxstomate -lsxioipsl $NCDFLIB " + set opt_link=" -float0 $optdbl -P static -L$MODIPSLDIR -lsxioipsl $NCDFLIB -lblas" + + endif + set mod_loc_dir="./" +################# +else +################# + set f77=f77 + set f90=f90 +endif + +cd $model + +if $VPP then +set make="gmake RANLIB=ls" +else if $CRAY then +set make="make RANLIB=ls" +else if $NEC then +set make="make RANLIB=ls" +else if $LINUX then +set make="make -k RANLIB=ranlib" +else if $XNEC then +set make="gmake RANLIB=ls" +else if $X6NEC then +set make="gmake RANLIB=ls" +else if $X8BRODIE then +set make="gmake RANLIB=ls" +else +set make="make RANLIB=ranlib" +endif + + + + +# +# etat0_netcdf a besoin d'info de la physique +# A revoir +set include="$include"' -I$(LIBF)/phy'"$physique" +# +# le programme principal create_limit a besoin de l'info du module +# startvar: on met donc libo dans les include pour Nec +set include="$include"' -I$(LIBO)' + + +################################################################# +# Execution de la comande make... ENFIN! +################################################################# + +if $VPP then + set optim90=" $optim90 -Am -M$libo" + set optimtru90="$optim90" + \cp $IOIPSLDIR/*.mod $libo +else if $SUN then + set optim90=" $optim90 -M$libo -M$MODIPSLDIR " + set optimtru90=" $optimtru90 -M$libo -M$MODIPSLDIR " + set optim="$optim90" + \cp $IOIPSLDIR/*.mod $libo +else if $NEC then + set optim90=" $optim90 -I$libo " +else if $XNEC then + set optim90=" $optim90 -I$libo " + set optimtru90=" $optimtru90 -I$libo " +else if $X6NEC then + set optim90=" $optim90 -I$libo " + set optimtru90=" $optimtru90 -I$libo " +else if $X8BRODIE then + set optim90=" $optim90 -I$libo " + set optimtru90=" $optimtru90 -I$libo " +else if $LINUX then + if ( $FC_LINUX == "pgf90" ) then + set optimtru90=" $optimtru90 -module $libo " + set optim90=" $optim90 -module $libo " + else if ( $FC_LINUX == 'g95' ) then + set optimtru90=" $optimtru90 -fmod=$libo " + set optim90=" $optim90 -fmod=$libo " + endif + set optim="$optim90" + set mod_loc_dir=$libo +# \cp /d3/fairhead/sechiba/ioipsl/*.mod $libo +# \cp $IOIPSLDIR/*.mod $libo +endif + +set link="$f90 $optim90" + +set ar=ar + +if $XNEC then + set link="sxld $opt_link" + set link="$f90 " +# set ar=sxar +else if $X6NEC then + set link="sxld $opt_link" + set link="$f90 -Wl,-hlib_cyclic " +else if $X8BRODIE then + set link="sxld $opt_link" + set link="$f90 -Wl,-hlib_cyclic " +endif + + +cd $localdir + +echo $make -f $LMDGCM/makefile \ +OPTION_DEP="$opt_dep" OPTION_LINK="$opt_link" \ +OPTIM90="$optim90" \ +OPTIMTRU90="$optimtru90" \ +OPTIM="$optim$optimbis" \ +INCLUDE="$include" \ +$filtre \ +LIBO=$libo \ +$dyn \ +$phys \ +DIM=$dimc \ +FLAG_PARA="$FLAG_PARA"\ +L_ADJNT="$adjnt" \ +L_COSP="$lcosp" \ +L_CHIMIE="$libchimie" \ +LOCAL_DIR="$localdir" \ +F77="$f77" \ +F90="$f90" \ +OPLINK="$oplink" \ +LINK="$link" \ +GCM="$LMDGCM" \ +MOD_LOC_DIR=$mod_loc_dir \ +MOD_SUFFIX=$mod_suffix \ +AR=$ar \ +PROG=$code + +$make -f $LMDGCM/makefile \ +OPTION_DEP="$opt_dep" OPTION_LINK="$opt_link" \ +OPTIM90="$optim90" \ +OPTIMTRU90="$optimtru90" \ +OPTIM="$optim$optimbis" \ +INCLUDE="$include" \ +$filtre \ +LIBO=$libo \ +$dyn \ +$phys \ +DIM=$dimc \ +FLAG_PARA="$FLAG_PARA"\ +L_ADJNT="$adjnt" \ +L_COSP="$lcosp" \ +L_CHIMIE="$libchimie" \ +LOCAL_DIR="$localdir" \ +F77="$f77" \ +F90="$f90" \ +OPLINK="$oplink" \ +LINK="$link" \ +GCM="$LMDGCM" \ +MOD_LOC_DIR=$mod_loc_dir \ +MOD_SUFFIX=$mod_suffix \ +AR=$ar \ +PROG=$code + +\rm -f $libf/grid/dimensions.h Index: /LMDZ4/branches/LMDZ4-dev-20091210/makelmdz_fcm =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/makelmdz_fcm (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/makelmdz_fcm (revision 1280) @@ -0,0 +1,407 @@ +#!/bin/bash +# $Id$ +# This is a script in Bash. + +# FH : on ne crée plus le fichier arch.mk qui est supposé exister par +# FH : ailleurs. +# FH : ulterieurement, ce fichier sera pré-existant pour une série +# FH : de configurations en versions optimisées et debug qui seront +# FH : liés (ln -s) avec arch.mk en fonction de l'architecture. +# FH : Pour le moment, cette version est en test et on peut créer les +# FH : arch.mk en lançant une première fois makegcm. +# +##set -x +######################################################################## +# options par defaut pour la commande make +######################################################################## + +dim="96x72x19" +physique=lmd +filtre=filtrez +grille=reg +couple=false +veget=false +chimie=false +parallel=none +compil_mod=prod +io=ioipsl +LIBPREFIX="" +fcm_path=none +cosp=false + +LMDGCM=`/bin/pwd` +LIBOGCM=$LMDGCM/libo +LIBFGCM=$LMDGCM/libf + +######################################################################## +# Quelques initialisations de variables du shell. +######################################################################## + +CPP_KEY="" +INCLUDE="" +LIB="" +adjnt="" +COMPIL_FFLAGS="%PROD_FFLAGS" +PARA_FFLAGS="" +PARA_LD="" +EXT_SRC="" + +######################################################################## +# lecture des options de mymake +######################################################################## + +while (($# > 0)) + do + case $1 in + "-h") cat < .void_file +rm -f arch.path +ln -s arch/arch-${arch}.path ./arch.path +source arch.path + +######################################################################## +# Definition des clefs CPP, des chemins des includes et modules +# et des libraries +######################################################################## + +if [[ "$compil_mod" == "prod" ]] +then + COMPIL_FFLAGS="%PROD_FFLAGS" +elif [[ "$compil_mod" == "dev" ]] +then + COMPIL_FFLAGS="%DEV_FFLAGS" +elif [[ "$compil_mod" == "debug" ]] +then + COMPIL_FFLAGS="%DEBUG_FFLAGS" +fi + +if [[ "$physique" != "nophys" ]] +then + #Default planet type is Earth + CPP_KEY="$CPP_KEY CPP_EARTH" +fi + +if [[ "$chimie" == "INCA" ]] +then + CPP_KEY="$CPP_KEY INCA" + INCLUDE="$INCLUDE -I${INCA_INCDIR}" + LIB="$LIB -L${INCA_LIBDIR} -lchimie" +fi + +if [[ "$couple" != "false" ]] +then + CPP_KEY="$CPP_KEY CPP_COUPLE" + INCLUDE="$INCLUDE -I${OASIS_INCDIR}" + LIB="$LIB -L${OASIS_LIBDIR} -lpsmile.${couple} -lmpp_io" +fi + +if [[ "$parallel" == "mpi" ]] +then + CPP_KEY="$CPP_KEY CPP_PARA CPP_MPI" + PARA_FFLAGS="%MPI_FFLAGS" + PARA_LD="%MPI_LD" +elif [[ "$parallel" == "omp" ]] +then + CPP_KEY="$CPP_KEY CPP_PARA CPP_OMP" + PARA_FFLAGS="%OMP_FFLAGS" + PARA_LD="%OMP_LD" +elif [[ "$parallel" == "mpi_omp" ]] +then + CPP_KEY="$CPP_KEY CPP_PARA CPP_MPI CPP_OMP" + PARA_FFLAGS="%MPI_FFLAGS %OMP_FFLAGS" + PARA_LD="%MPI_LD %OMP_LD" +fi + +if [[ ( "$parallel" == "omp" || "$parallel" == "mpi_omp" ) \ + && "$compil_mod" == "debug" ]] +then + echo "Usually, parallelization with OpenMP requires some optimization." + echo "We suggest switching to \"-dev\"." +fi + +if [[ "$veget" == "true" ]] +then + CPP_KEY="$CPP_KEY CPP_VEGET" + INCLUDE="${INCLUDE} -I${ORCH_INCDIR}" + LIB="${LIB} -L${ORCH_LIBDIR} -l${LIBPREFIX}sechiba -l${LIBPREFIX}parameters -l${LIBPREFIX}stomate -l${LIBPREFIX}parallel -l${LIBPREFIX}orglob" +fi + +if [[ $io == ioipsl ]] +then + CPP_KEY="$CPP_KEY CPP_IOIPSL" + INCLUDE="$INCLUDE -I${IOIPSL_INCDIR}" + LIB="$LIB -L${IOIPSL_LIBDIR} -l${LIBPREFIX}ioipsl" +fi +if [[ "$cosp" == "true" ]] +then + CPP_KEY="$CPP_KEY CPP_COSP" + INCLUDE="$INCLUDE -I$(LIBFGCM)/cosp" +# LIB="${LIB} -l${LIBPREFIX}cosp" +fi +INCLUDE="$INCLUDE -I${NETCDF_INCDIR}" +LIB="$LIB -L${NETCDF_LIBDIR} -lnetcdf" + +######################################################################## +# calcul du nombre de dimensions +######################################################################## + + +dim_full=$dim +dim=`echo $dim | sed -e 's/[^0-9]/ /g'` +set $dim +dimc=$# +echo calcul de la dimension +echo dim $dim +echo dimc $dimc + + +######################################################################## +# Gestion des dimensions du modele. +# on cree ou remplace le fichier des dimensions +######################################################################## + +cd $LIBFGCM/grid/dimension +./makdim $dim +cat $LIBFGCM/grid/dimensions.h +cd $LMDGCM + + +######################################################################## +# Differentes dynamiques (3d, 2d, 1d) +######################################################################## + +dimension=`echo $dim | wc -w` +echo dimension $dimension + +if (( $dimension == 3 )) +then + cd $LIBFGCM/grid + \rm fxyprim.h + cp -p fxy_${grille}.h fxyprim.h +else + echo "Probleme dans les dimensions de la dynamique !!" + echo "Non reactive pour l'instant !!!" +fi + +###################################################################### +# Traitement special pour le nouveau rayonnement de Laurent Li. +# ---> YM desactive pour le traitemement en parallele +###################################################################### + +#if [[ -f $libf/phy$physique/raddim.h ]] +#then +# if [[ -f $libf/phy$physique/raddim.$dimh.h ]] +#then +# \rm -f $libf/phy$physique/raddim.h +# cp -p $libf/phy$physique/raddim.$dimh.h $libf/phy$physique/raddim.h +# echo $libf/phy$physique/raddim.$dimh.h +# cat $libf/phy$physique/raddim.h +# else +# echo On peut diminuer la taille de l executable en creant +# echo le fichier $libf/phy$physique/raddim.$dimh.h +# \cp -p $libf/phy$physique/raddim.defaut.h $libf/phy$physique/raddim.h +# fi +#fi + +###################################################################### +# Gestion du filtre qui n'existe qu'en 3d. +###################################################################### + +if (( `expr $dimc \> 2` == 1 )) +then + filtre="FILTRE=$filtre" +else + filtre="FILTRE= L_FILTRE= " +fi +echo MACRO FILTRE $filtre + +echo $dimc + + + +###################################################################### +# Creation du suffixe de la configuration +###################################################################### + + +SUFF_NAME=_${dim_full} +SUFF_NAME=${SUFF_NAME}_phy${physique} + +if [[ "$parallel" != "none" ]] +then + SUFF_NAME=${SUFF_NAME}_para + DYN=dyn${dimc}dpar +else + SUFF_NAME=${SUFF_NAME}_seq + DYN=dyn${dimc}d +fi + +if [[ $veget == "true" ]] +then + SUFF_NAME=${SUFF_NAME}_orch +fi + +if [[ $couple != "false" ]] +then + SUFF_NAME=${SUFF_NAME}_couple +fi + +if [[ $chimie == "INCA" ]] +then + SUFF_NAME=${SUFF_NAME}_inca +fi + +cd $LMDGCM +config_fcm="config.fcm" +rm -f $config_fcm +touch $config_fcm +rm -f bin/${code}${SUFF_NAME}.e +rm -f arch.fcm +rm -f arch.opt + +echo "%ARCH $arch" >> $config_fcm +echo "%INCDIR $INCLUDE" >> $config_fcm +echo "%LIB $LIB" >> $config_fcm +echo "%ROOT_PATH $PWD" >> $config_fcm +echo "%LIBF $LIBFGCM" >> $config_fcm +echo "%LIBO $LIBOGCM" >> $config_fcm +echo "%DYN $DYN" >> $config_fcm +echo "%PHYS phy${physique}" >> $config_fcm +echo "%CPP_KEY $CPP_KEY" >> $config_fcm +echo "%EXEC $code" >> $config_fcm +echo "%SUFF_NAME $SUFF_NAME" >> $config_fcm +echo "%COMPIL_FFLAGS $COMPIL_FFLAGS" >> $config_fcm +echo "%PARA_FFLAGS $PARA_FFLAGS" >> $config_fcm +echo "%PARA_LD $PARA_LD" >> $config_fcm +echo "%EXT_SRC $EXT_SRC" >> $config_fcm + + + +ln -s arch/arch-${arch}.fcm arch.fcm +if test -f arch/arch-${arch}.opt && [ $compil_mod = "prod" ] + then + ln -s arch/arch-${arch}.opt arch.opt +else + ln -s .void_file arch.opt +fi + + +rm -f $LIBOGCM/${arch}${SUFF_NAME}/.config/fcm.bld.lock +./build_gcm + +rm -rf tmp_src +rm -rf config +ln -s $LIBOGCM/${arch}${SUFF_NAME}/.config config +ln -s $LIBOGCM/${arch}${SUFF_NAME}/.config/tmp tmp_src Index: /LMDZ4/branches/LMDZ4-dev-20091210/offline.def =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/offline.def (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/offline.def (revision 1280) @@ -0,0 +1,12 @@ +# +# $Header$ +# +T +4 +T +-2. +48.1 +1 +T +6 +2 Index: /LMDZ4/branches/LMDZ4-dev-20091210/orchidee.def =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/orchidee.def (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/orchidee.def (revision 1280) @@ -0,0 +1,46 @@ +# +# $Header$ +# +# +# SECHIBA +# +STOMATE_OK_CO2=FALSE +# STOMATE_OK_STOMATE is not set +# STOMATE_OK_DGVM is not set +# STOMATE_WATCHOUT is not set +#SECHIBA_restart_in=default +SECHIBA_restart_in=start_sech.nc +SECHIBA_rest_out=sechiba_rest.nc +SECHIBA_reset_time=y +SECHIBA_reset_time is not set +OUTPUT_FILE=sechiba_out.nc +WRITE_STEP=2592000 +SECHIBA_HISTLEVEL=10 +STOMATE_OUTPUT_FILE=stomate_history.nc +STOMATE_HIST_DT=10. +STOMATE_HISTLEVEL=0 +SECHIBA_DAY=0.0 +SECHIBA_ZCANOP=0.5 +DT_SLOW=86400. +# IMPOSE_VEG is not set +VEGETATION_FILE=carteveg5km.nc +DIFFUCO_LEAFCI=233. +CONDVEG_SNOWA=default +# IMPOSE_AZE is not set +SOILALB_FILE=soils_param.nc +SOILTYPE_FILE=soils_param.nc +ENERBIL_TSURF=280. +HYDROL_SNOW=0.0 +HYDROL_SNOWAGE=0.0 +HYDROL_SNOWICE=0.0 +HYDROL_SNOWICEAGE=0.0 +HYDROL_HDRY=1.0 +HYDROL_HUMR=1.0 +HYDROL_BQSB=default +HYDROL_GQSB=0.0 +HYDROL_DSG=0.0 +HYDROL_DSP=default +HYDROL_QSV=0.0 +THERMOSOIL_TPRO=280. +RIVER_ROUTING=y +ROUTING_FILE=routing.nc Index: /LMDZ4/branches/LMDZ4-dev-20091210/output.def =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/output.def (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/output.def (revision 1280) @@ -0,0 +1,794 @@ +######## Abderrahmane le 20 11 08 ######################## +# Niveaux de sorties et nom pour chaque variable dans les# +# fichiers histmth histday histhf histins histLES # +########################################################## +# Surface geop.height +flag_phis = 1, 1, 10, 1, 1 +name_phis = phis +# Grid area +flag_aire = 1, 1, 10, 1, 1 +name_aire = aire +# Surfac ter+lic +flag_contfracATM = 10, 1, 1, 10, 10 +name_contfracATM = contfracATM +# Surface terre OR +flag_contfracOR = 10, 1, 1, 10, 10 +name_contfracOR = contfracOR +# Grid area CONT +flag_aireTER = 10, 10, 1, 10, 10 +name_aireTER = aireTER +# Latent heat flux +flag_flat = 10, 1, 10, 10, 1 +name_flat = flat +# Sea Level Pressure +flag_slp = 1, 1, 1, 10, 1 +name_slp = slp +# Surface Temperature +flag_tsol = 1, 1, 1, 1, 1 +name_tsol = tsol +# Temperature 2m +flag_t2m = 1, 1, 1, 1, 1 +name_t2m = t2m +# Temperature min 2m +flag_t2m_min = 1, 1, 10, 10, 10 +name_t2m_min = t2m_min +# Temperature max 2m +flag_t2m_max = 1, 1, 10, 10, 10 +name_t2m_max = t2m_max +# Temperature ter lic oce sic at 2m +flag_t2m_ter = 10, 4, 10, 10, 10 +name_t2m_ter = t2m_ter +flag_t2m_lic = 10, 4, 10, 10, 10 +name_t2m_lic = t2m_lic +flag_t2m_oce = 10, 4, 10, 10, 10 +name_t2m_oce = t2m_oce +flag_t2m_sic = 10, 4, 10, 10, 10 +name_t2m_sic = t2m_sic +# 10-m wind speed +flag_wind10m = 1, 1, 1, 10, 10 +name_wind10m = wind10m +# 10-m wind speed max +flag_wind10max = 10, 1, 10, 10, 10 +name_wind10max = wind10max +# Sea-ice fraction +flag_sicf = 1, 1, 10, 10, 10 +name_sicf = sicf +# Specific humidity 2m +flag_q2m = 1, 1, 1, 1, 1 +name_q2m = q2m +# 10m zonal wind +flag_u10m = 1, 1, 1, 1, 1 +name_u10m = u10m +# 10m meridional wind +flag_v10m = 1, 1, 1, 1, 1 +name_v10m = v10m +# Surface Pressure +flag_psol = 1, 1, 1, 1, 1 +name_psol = psol +# Surface Air humidity +flag_qsurf = 1, 10, 10, 10, 10 +name_qsurf = qsurf +# 10m zonal wind (ter lic oce sic) +flag_u10m_ter = 10, 4, 10, 10, 10 +name_u10m_ter = u10m_ter +flag_u10m_lic = 10, 4, 10, 10, 10 +name_u10m_lic = u10m_lic +flag_u10m_oce = 10, 4, 10, 10, 10 +name_u10m_oce = u10m_oce +flag_u10m_sic = 10, 4, 10, 10, 10 +name_u10m_sic = u10m_sic +# 10m meridien wind (ter oce ice lic) +flag_v10m_ter = 10, 4, 10, 10, 10 +name_v10m_ter = v10m_ter +flag_v10m_lic = 10, 4, 10, 10, 10 +name_v10m_lic = v10m_lic +flag_v10m_oce = 10, 4, 10, 10, 10 +name_v10m_oce = v10m_oce +flag_v10m_sic = 10, 4, 10, 10, 10 +name_v10m_sic = v10m_sic +# Soil watter content +flag_qsol = 1, 10, 10, 1, 1 +name_qsol = qsol +# Number of dayrain(liq+sol) +flag_ndayrain = 1, 10, 10, 10, 10 +name_ndayrain = ndayrain +# Precip Totale liq+sol +flag_precip = 1, 1, 1, 1, 1 +name_precip = precip +# Large-scale Precip +flag_plul = 1, 1, 1, 1, 10 +name_plul = plul +# Convective Precip +flag_pluc = 1, 1, 1, 1, 10 +name_pluc = pluc +# Snow fall +flag_snow = 1, 1, 10, 1, 10 +name_snow = snow +# Evaporation +flag_evap = 1, 1, 10, 1, 10 +name_evap = evap +# Solar rad. at TOA +flag_tops = 1, 1, 10, 10, 10 +name_tops = tops +# CS Solar rad. at TOA +flag_tops0 = 1, 5, 10, 10, 10 +name_tops0 = tops0 +# IR rad. at TOA +flag_topl = 1, 1, 10, 1, 10 +name_topl = topl +# CR IR rad. at TOA +flag_topl0 = 1, 5, 10, 10, 10 +name_topl0 = topl0 +# SWup at TOA +flag_SWupTOA = 1, 4, 10, 10, 10 +name_SWupTOA = SWupTOA +# CR SWup at TOA +flag_SWupTOAclr = 1, 4, 10, 10, 10 +name_SWupTOAclr = SWupTOAclr +# SWdn at TOA +flag_SWdnTOA = 1, 4, 10, 10, 10 +name_SWdnTOA = SWdnTOA +# CR SWdn at TOA +flag_SWdnTOAclr = 1, 4, 10, 10, 10 +name_SWdnTOAclr = SWdnTOAclr +# SWup at 200hPa +flag_SWup200 = 1, 10, 10, 10, 10 +name_SWup200 = SWup200 +# CR SWup at 200hPa +flag_SWup200clr = 10, 1, 10, 10, 10 +name_SWup200clr = SWup200clr +# SWdn at 200hPa +flag_SWdn200 = 1, 10, 10, 10, 10 +name_SWdn200 = SWdn200 +# CR SWdn at 200hPa +flag_SWdn200clr = 10, 1, 10, 10, 10 +name_SWdn200clr = SWdn200clr +# LWup at 200mb +flag_LWup200 = 1, 10, 10, 10, 10 +name_LWup200 = LWup200 +# CR LWup at 200mb +flag_LWup200clr = 1, 10, 10, 10, 10 +name_LWup200clr = LWup200clr +# LWdn at 200mb +flag_LWdn200 = 1, 10, 10, 10, 10 +name_LWdn200 = LWdn200 +# CR LWdn at 200mb +flag_LWdn200clr = 1, 10, 10, 10, 10 +name_LWdn200clr = LWdn200clr +# Solar rad. at surf +flag_sols = 1, 1, 10, 1, 10 +name_sols = sols +# CR Solar rad. at surf +flag_sols0 = 1, 5, 10, 10, 10 +name_sols0 = sols0 +# IR rad. at surface +flag_soll = 1, 1, 10, 1, 10 +name_soll = soll +# CR IR rad. at surface +flag_soll0 = 1, 5, 10, 10, 10 +name_soll0 = soll0 +# Rayonnement au sol +flag_radsol = 1, 1, 10, 10, 10 +name_radsol = radsol +# SWup at surface +flag_SWupSFC = 1, 4, 10, 10, 10 +name_SWupSFC = SWupSFC +# CR SWup at surface +flag_SWupSFCclr = 1, 4, 10, 10, 10 +name_SWupSFCclr = SWupSFCclr +# SWdn at surface +flag_SWdnSFC = 1, 1, 10, 10, 10 +name_SWdnSFC = SWdnSFC +# CR at surface +flag_SWdnSFCclr = 1, 4, 10, 10, 10 +name_SWdnSFCclr = SWdnSFCclr +# LWup at surface +flag_LWupSFC = 1, 4, 10, 10, 10 +name_LWupSFC = LWupSFC +# CR LWup at surface +flag_LWupSFCclr = 1, 4, 10, 10, 10 +name_LWupSFCclr = LWupSFCclr +# LWdn at surface +flag_LWdnSFC = 1, 4, 10, 10, 10 +name_LWdnSFC = LWdnSFC +# CR LWdn at surface +flag_LWdnSFCclr = 1, 4, 10, 10, 10 +name_LWdnSFCclr = LWdnSFCclr +# Surf. total heat flux +flag_bils = 1, 2, 10, 1, 10 +name_bils = bils +# Sensible heat flux +flag_sens = 1, 1, 10, 1, 1 +name_sens = sens +# Heat flux derivation +flag_fder = 1, 2, 10, 1, 10 +name_fder = fder +# Thermal flux for snow melting +flag_ffonte = 1, 10, 10, 10, 10 +name_ffonte = ffonte +# Ice Calving +flag_fqcalving = 1, 10, 10, 10, 10 +name_fqcalving = fqcalving +# Land ice melt +flag_fqfonte = 1, 10, 10, 10, 10 +name_fqfonte = fqfonte +# Zonal wind stress (ter ice liq oce) +flag_taux_ter = 1, 4, 10, 1, 10 +name_taux_ter = taux_ter +flag_taux_lic = 1, 4, 10, 1, 10 +name_taux_lic = taux_lic +flag_taux_oce = 1, 4, 10, 1, 10 +name_taux_oce = taux_oce +flag_taux_sic = 1, 4, 10, 1, 10 +name_taux_sic = taux_sic +# Meridien wind stress (ter ice liq oce) +flag_tauy_ter = 1, 4, 10, 1, 10 +name_tauy_ter = tauy_ter +flag_tauy_lic = 1, 4, 10, 1, 10 +name_tauy_lic = tauy_lic +flag_tauy_oce = 1, 4, 10, 1, 10 +name_tauy_oce = tauy_oce +flag_tauy_sic = 1, 4, 10, 1, 10 +name_tauy_sic = tauy_sic +# % surface (ter ice liq oce) +flag_pourc_ter = 1, 4, 10, 1, 10 +name_pourc_ter = pourc_ter +flag_pourc_lic = 1, 4, 10, 1, 10 +name_pourc_lic = pourc_lic +flag_pourc_oce = 1, 4, 10, 1, 10 +name_pourc_oce = pourc_oce +flag_pourc_sic = 1, 4, 10, 1, 10 +name_pourc_sic = pourc_sic +# Fraction (ter ice liq oce) +flag_fract_ter = 1, 4, 10, 1, 10 +name_fract_ter = fract_ter +flag_fract_lic = 1, 4, 10, 1, 10 +name_fract_lic = fract_lic +flag_fract_oce = 1, 4, 10, 1, 10 +name_fract_oce = fract_oce +flag_fract_sic = 1, 4, 10, 1, 10 +name_fract_sic = fract_sic +# Surface temperature (ter ice liq oce) +flag_tsol_ter = 1, 4, 10, 1, 10 +name_tsol_ter = tsol_ter +flag_tsol_lic = 1, 4, 10, 1, 10 +name_tsol_lic = tsol_lic +flag_tsol_oce = 1, 4, 10, 1, 10 +name_tsol_oce = tsol_oce +flag_tsol_sic = 1, 4, 10, 1, 10 +name_tsol_sic = tsol_sic +# Sensible heat flux (ter ice liq oce) +flag_sens_ter = 1, 4, 10, 1, 10 +name_sens_ter = sens_ter +flag_sens_lic = 1, 4, 10, 1, 10 +name_sens_lic = sens_lic +flag_sens_oce = 1, 4, 10, 1, 10 +name_sens_oce = sens_oce +flag_sens_sic = 1, 4, 10, 1, 10 +name_sens_sic = sens_sic +# Latent heat flux (ter ice liq oce) +flag_lat_ter = 1, 4, 10, 1, 10 +name_lat_ter = lat_ter +flag_lat_lic = 1, 4, 10, 1, 10 +name_lat_lic = lat_lic +flag_lat_oce = 1, 4, 10, 1, 10 +name_lat_oce = lat_oce +flag_lat_sic = 1, 4, 10, 1, 10 +name_lat_sic = lat_sic +# LW (ter ice liq oce) +flag_flw_ter = 1, 10, 10, 10, 10 +name_flw_ter = flw_ter +flag_flw_lic = 1, 10, 10, 10, 10 +name_flw_lic = flw_lic +flag_flw_oce = 1, 10, 10, 10, 10 +name_flw_oce = flw_oce +flag_flw_sic = 1, 10, 10, 10, 10 +name_flw_sic = flw_sic +# SW (ter ice liq oce) +flag_fsw_ter = 1, 10, 10, 10, 10 +name_fsw_ter = fsw_ter +flag_fsw_lic = 1, 10, 10, 10, 10 +name_fsw_lic = fsw_lic +flag_fsw_oce = 1, 10, 10, 10, 10 +name_fsw_oce = fsw_oce +flag_fsw_sic = 1, 10, 10, 10, 10 +name_fsw_sic = fsw_sic +# Bilan sol (ter ice liq oce) +flag_wbils_ter = 1, 10, 10, 10, 10 +name_wbils_ter = wbils_ter +flag_wbils_lic = 1, 10, 10, 10, 10 +name_wbils_lic = wbils_lic +flag_wbils_oce = 1, 10, 10, 10, 10 +name_wbils_oce = wbils_oce +flag_wbils_sic = 1, 10, 10, 10, 10 +name_wbils_sic = wbils_sic +# Bilan eau (ter ice liq oce) +flag_wbilo_ter = 1, 10, 10, 10, 10 +name_wbilo_ter = wbilo_ter +flag_wbilo_lic = 1, 10, 10, 10, 10 +name_wbilo_lic = wbilo_lic +flag_wbilo_oce = 1, 10, 10, 10, 10 +name_wbilo_oce = wbilo_oce +flag_wbilo_sic = 1, 10, 10, 10, 10 +name_wbilo_sic = wbilo_sic +# Momentum drag coef +flag_cdrm = 1, 10, 10, 1, 10 +name_cdrm = cdrm +# Heat drag coef +flag_cdrh = 1, 10, 10, 1, 10 +name_cdrh = cdrh +# Low-level cloudiness +flag_cldl = 1, 1, 10, 10, 10 +name_cldl = cldl +# Mid-level cloudiness +flag_cldm = 1, 1, 10, 10, 10 +name_cldm = cldm +# High-level cloudiness +flag_cldh = 1, 1, 10, 10, 10 +name_cldh = cldh +# Total cloudiness +flag_cldt = 1, 1, 2, 10, 10 +name_cldt = cldt +# Cloud liquid water path +flag_cldq = 1, 1, 10, 10, 10 +name_cldq = cldq +# Cloud water path +flag_lwp = 1, 5, 10, 10, 10 +name_lwp = lwp +# Cloud ice water path +flag_iwp = 1, 5, 10, 10, 10 +name_iwp = iwp +# Zonal energy transport +flag_ue = 1, 10, 10, 10, 10 +name_ue = ue +# Merid energy transport +flag_ve = 1, 10, 10, 10, 10 +name_ve = ve +# Zonal humidity transport +flag_uq = 1, 10, 10, 10, 10 +name_uq = uq +# Merid humidity transport +flag_vq = 1, 10, 10, 10, 10 +name_vq = vq +# Conv avlbl pot ener +flag_cape = 1, 10, 10, 10, 10 +name_cape = cape +# Cld base pressure +flag_pbase = 1, 10, 10, 10, 10 +name_pbase = pbase +# Cld top pressure +flag_ptop = 1, 4, 10, 10, 10 +name_ptop = ptop +# Cld base mass flux +flag_fbase = 1, 10, 10, 10, 10 +name_fbase = fbase +# Precipitable water +flag_prw = 1, 1, 10, 10, 10 +name_prw = prw +# Boundary Layer Height +flag_s_pblh = 1, 10, 10, 1, 1 +name_s_pblh = pblh +# t at Boundary Layer Height +flag_s_pblt = 1, 10, 10, 1, 1 +name_s_pblt = pblt +# Condensation level +flag_s_lcl = 1, 10, 10, 1, 10 +name_s_lcl = lcl +# Conv avlbl pot enerfor ABL +flag_s_capCL = 1, 10, 10, 1, 10 +name_s_capCL = capCL +# Liq Water in BL +flag_s_oliqCL = 1, 10, 10, 1, 10 +name_s_oliqCL = oliqCL +# Instability criteria(ABL) +flag_s_cteiCL = 1, 10, 10, 1, 1 +name_s_cteiCL = cteiCL +# Exces du thermique +flag_s_therm = 1, 10, 10, 1, 1 +name_s_therm = therm +# deep_cape(HBTM2) +flag_s_trmb1 = 1, 10, 10, 1, 10 +name_s_trmb1 = trmb1 +# inhibition (HBTM2) +flag_s_trmb2 = 1, 10, 10, 1, 10 +name_s_trmb2 = trmb2 +# Point Omega (HBTM2) +flag_s_trmb3 = 1, 10, 10, 1, 10 +name_s_trmb3 = trmb3 +# Bilan au sol sur ocean slab +flag_slab_bils = 1, 1, 10, 10, 10 +name_slab_bils = slab_bils +# ALE BL +flag_ale_bl = 1, 1, 1, 1, 10 +name_ale_bl = ale_bl +# alp_bl +flag_alp_bl = 1, 1, 1, 1, 10 +name_alp_bl = alp_bl +# ale_wk +flag_ale_wk = 1, 1, 1, 1, 10 +name_ale_wk = ale_wk +# alp_wk +flag_alp_wk = 1, 1, 1, 1, 10 +name_alp_wk = alp_wk +# ale +flag_ale = 1, 1, 1, 1, 10 +name_ale = ale +# alp +flag_alp = 1, 1, 1, 1, 10 +name_alp = alp +# Convective INhibition +flag_cin = 1, 1, 1, 1, 10 +name_cin = cin +# WAPE +flag_wape = 1, 1, 1, 1, 10 +name_wape = wape +# u, v w t q et phi aux niveaux 200, 500, 700 et 850 hPa +flag_u850 = 1, 1, 3, 10, 10 +name_u850 = u850 +flag_u700 = 1, 1, 3, 10, 10 +name_u700 = u700 +flag_u500 = 1, 1, 3, 10, 10 +name_u500 = u500 +flag_u200 = 1, 1, 3, 10, 10 +name_u200 = u200 +flag_v850 = 1, 1, 3, 10, 10 +name_v850 = v850 +flag_v700 = 1, 1, 3, 10, 10 +name_v700 = v700 +flag_v500 = 1, 1, 3, 10, 10 +name_v500 = v500 +flag_v200 = 1, 1, 3, 10, 10 +name_v200 = v200 +flag_w850 = 1, 1, 3, 10, 10 +name_w850 = w850 +flag_w700 = 1, 1, 3, 10, 10 +name_w700 = w700 +flag_w500 = 1, 1, 3, 10, 10 +name_w500 = w500 +flag_w200 = 1, 1, 3, 10, 10 +name_w200 = w200 +flag_t850 = 1, 1, 3, 10, 10 +name_t850 = t850 +flag_t700 = 1, 1, 3, 10, 10 +name_t700 = t700 +flag_t500 = 1, 1, 3, 10, 10 +name_t500 = t500 +flag_t200 = 1, 1, 3, 10, 10 +name_t200 = t200 +flag_q850 = 1, 1, 3, 10, 10 +name_q850 = q850 +flag_q700 = 1, 1, 3, 10, 10 +name_q700 = q700 +flag_q500 = 1, 1, 3, 10, 10 +name_q500 = q500 +flag_q200 = 1, 1, 3, 10, 10 +name_q200 = q200 +flag_phi850 = 1, 1, 3, 10, 10 +name_phi850 = phi850 +flag_phi700 = 1, 1, 3, 10, 10 +name_phi700 = phi700 +flag_phi500 = 1, 1, 3, 10, 10 +name_phi500 = phi500 +flag_phi200 = 1, 1, 3, 10, 10 +name_phi200 = phi200 +# Temp mixte oce-sic +flag_t_oce_sic = 1, 10, 10, 10, 10 +name_t_oce_sic = t_oce_sic +# Weak inversion +flag_weakinv = 10, 1, 10, 10, 10 +name_weakinv = weakinv +# dTheta mini +flag_dthmin = 10, 1, 10, 10, 10 +name_dthmin = dthmin +# 10m zonal and meriden wind (ter sic lic oce) +flag_u10_ter = 10, 4, 10, 10, 10 +name_u10_ter = u10_ter +flag_u10_lic = 10, 4, 10, 10, 10 +name_u10_lic = u10_lic +flag_u10_oce = 10, 4, 10, 10, 10 +name_u10_oce = u10_oce +flag_u10_sic = 10, 4, 10, 10, 10 +name_u10_sic = u10_sic +flag_v10_ter = 10, 4, 10, 10, 10 +name_v10_ter = v10_ter +flag_v10_lic = 10, 4, 10, 10, 10 +name_v10_lic = v10_lic +flag_v10_oce = 10, 4, 10, 10, 10 +name_v10_oce = v10_oce +flag_v10_sic = 10, 4, 10, 10, 10 +name_v10_sic = v10_sic +# Cloud optical thickness +flag_cldtau = 10, 5, 10, 10, 10 +name_cldtau = cldtau +# Cloud optical emissivity +flag_cldemi = 10, 5, 10, 10, 10 +name_cldemi = cldemi +# Relative humidity at 2m +flag_rh2m = 10, 5, 10, 10, 10 +name_rh2m = rh2m +# Saturant humidity at 2m +flag_qsat2m = 10, 5, 10, 10, 10 +name_qsat2m = qsat2m +# Surface air potential temperature +flag_tpot = 10, 5, 10, 10, 10 +name_tpot = tpot +# Surface air equivalent potential temperature +flag_tpote = 10, 5, 10, 10, 10 +name_tpote = tpote +# TKE, tke max and tke (ter sic lic oce) +flag_tke = 4, 10, 10, 10, 10 +name_tke = tke +flag_tke_max = 4, 10, 10, 10, 10 +name_tke_max = tke_max +flag_tke_ter = 10, 4, 10, 10, 10 +name_tke_ter = tke_ter +flag_tke_lic = 10, 4, 10, 10, 10 +name_tke_lic = tke_lic +flag_tke_oce = 10, 4, 10, 10, 10 +name_tke_oce = tke_oce +flag_tke_sic = 10, 4, 10, 10, 10 +name_tke_sic = tke_sic +flag_tke_max_ter = 10, 4, 10, 10, 10 +name_tke_max_ter = tke_max_ter +flag_tke_max_lic = 10, 4, 10, 10, 10 +name_tke_max_lic = tke_max_lic +flag_tke_max_oce = 10, 4, 10, 10, 10 +name_tke_max_oce = tke_max_oce +flag_tke_max_sic = 10, 4, 10, 10, 10 +name_tke_max_sic = tke_max_sic +# Kz melange +flag_kz = 4, 10, 10, 10, 10 +name_kz = kz +# Kz max melange +flag_kz_max = 4, 10, 10, 10, 10 +name_kz_max = kz_max +# Sfce net SW radiation OR +flag_SWnetOR = 10, 10, 2, 10, 10 +name_SWnetOR = SWnetOR +# Sfce incident SW radiation OR +flag_SWdownOR = 10, 10, 2, 10, 10 +name_SWdownOR = SWdownOR +# Sfce incident LW radiation OR +flag_LWdownOR = 10, 10, 2, 10, 10 +name_LWdownOR = LWdownOR +# Solid Large-scale Precip +flag_snowl = 10, 1, 10, 10, 10 +name_snowl = snowl +# cape max +flag_cape_max = 10, 1, 10, 10, 10 +name_cape_max = cape_max +# Down. IR rad. at surface +flag_solldown = 10, 1, 10, 1, 10 +name_solldown = solldown +# Boundary-layer dTs(o) +flag_dtsvdfo = 10, 10, 10, 1, 10 +name_dtsvdfo = dtsvdfo +# Boundary-layer dTs(t) +flag_dtsvdft = 10, 10, 10, 1, 10 +name_dtsvdft = dtsvdft +# Boundary-layer dTs(g) +flag_dtsvdfg = 10, 10, 10, 1, 10 +name_dtsvdfg = dtsvdfg +# Boundary-layer dTs(g) +flag_dtsvdfi = 10, 10, 10, 1, 10 +name_dtsvdfi = dtsvdfi +# rugosity +flag_rugs = 10, 10, 10, 1, 1 +name_rugs = rugs +# Cloud liquid water content +flag_lwcon = 2, 5, 10, 10, 1 +name_lwcon = lwcon +# Cloud ice water content +flag_iwcon = 2, 5, 10, 10, 10 +name_iwcon = iwcon +# Air temperature +flag_temp = 2, 3, 4, 1, 1 +name_temp = temp +# Potential air temperature +flag_theta = 2, 3, 4, 1, 1 +name_theta = theta +# Specific humidity +flag_ovap = 2, 3, 4, 1, 1 +name_ovap = ovap +# ? +flag_ovapinit = 2, 3, 4, 1, 1 +name_ovapinit = ovapinit +# ? +flag_wvapp = 2, 10, 10, 10, 10 +name_wvapp = wvapp +# Geopotential height +flag_geop = 2, 3, 10, 1, 1 +name_geop = geop +# Zonal wind +flag_vitu = 2, 3, 4, 1, 1 +name_vitu = vitu +# Meridional wind +flag_vitv = 2, 3, 4, 1, 1 +name_vitv = vitv +# Vertical wind +flag_vitw = 2, 3, 10, 10, 1 +name_vitw = vitw +# Air pressure +flag_pres = 2, 3, 10, 1, 1 +name_pres = pres +# Cloud Fraction +flag_rneb = 2, 5, 10, 10, 1 +name_rneb = rneb +# Convective Cloud Fraction +flag_rnebcon = 2, 5, 10, 10, 1 +name_rnebcon = rnebcon +# Relative humidity +flag_rhum = 2, 10, 10, 10, 10 +name_rhum = rhum +# Ozone concentration +flag_ozone = 2, 10, 10, 10, 10 +name_ozone = ozone +# saturated updraft +flag_upwd = 2, 10, 10, 10, 10 +name_upwd = upwd +# Physics dT +flag_dtphy = 2, 10, 10, 10, 1 +name_dtphy = dtphy +# Physics dq +flag_dqphy = 2, 10, 10, 10, 1 +name_dqphy = dqphy +# Convective precipitation lic and ice +flag_pr_con_l = 2, 10, 10, 10, 10 +name_pr_con_l = pr_con_l +flag_pr_con_i = 2, 10, 10, 10, 10 +name_pr_con_i = pr_con_i +# Large scale precipitation lic and ice +flag_pr_lsc_l = 2, 10, 10, 10, 10 +name_pr_lsc_l = pr_lsc_l +flag_pr_lsc_i = 2, 10, 10, 10, 10 +name_pr_lsc_i = pr_lsc_i +# Albedo surf, Snow age and rugosity (ter sic lic oce) +flag_albe_ter = 3, 4, 10, 1, 10 +name_albe_ter = albe_ter +flag_albe_lic = 3, 4, 10, 1, 10 +name_albe_lic = albe_lic +flag_albe_oce = 3, 4, 10, 1, 10 +name_albe_oce = albe_oce +flag_albe_sic = 3, 4, 10, 1, 10 +name_albe_sic = albe_sic +flag_ages_ter = 3, 10, 10, 10, 10 +name_ages_ter = ages_ter +flag_ages_lic = 3, 10, 10, 10, 10 +name_ages_lic = ages_lic +flag_ages_oce = 3, 10, 10, 10, 10 +name_ages_oce = ages_oce +flag_ages_sic = 3, 10, 10, 10, 10 +name_ages_sic = ages_sic +flag_rugs_ter = 3, 4, 10, 1, 10 +name_rugs_ter = rugs_ter +flag_rugs_lic = 3, 4, 10, 1, 10 +name_rugs_lic = rugs_lic +flag_rugs_oce = 3, 4, 10, 1, 10 +name_rugs_oce = rugs_oce +flag_rugs_sic = 3, 4, 10, 1, 10 +name_rugs_sic = rugs_sic +# Surface albedo +flag_albs = 3, 10, 10, 1, 10 +name_albs = albs +# Surface albedo LW +flag_albslw = 3, 10, 10, 1, 10 +name_albslw = albslw +# Convective Cloud Liquid water content +flag_clwcon = 4, 10, 10, 10, 10 +name_clwcon = clwcon +# undilute adiab updraft +flag_Ma = 4, 10, 10, 10, 10 +name_Ma = Ma +# saturated downdraft +flag_dnwd = 4, 10, 10, 10, 10 +name_dnwd = dnwd +# unsat. downdraft +flag_dnwd0 = 4, 10, 10, 10, 10 +name_dnwd0 = dnwd0 +# Dynamics dT dQ dU dV, ..... +flag_dtdyn = 4, 10, 10, 10, 1 +name_dtdyn = dtdyn +flag_dqdyn = 4, 10, 10, 10, 1 +name_dqdyn = dqdyn +flag_dudyn = 4, 10, 10, 10, 1 +name_dudyn = dudyn +flag_dvdyn = 4, 10, 10, 10, 1 +name_dvdyn = dvdyn +flag_dtcon = 4, 5, 10, 10, 10 +name_dtcon = dtcon +flag_ducon = 4, 10, 10, 10, 10 +name_ducon = ducon +flag_dqcon = 4, 5, 10, 10, 10 +name_dqcon = dqcon +flag_dtwak = 4, 5, 10, 10, 10 +name_dtwak = dtwak +flag_dqwak = 4, 5, 10, 10, 10 +name_dqwak = dqwak +flag_wake_h = 4, 5, 10, 10, 10 +name_wake_h = wake_h +flag_wake_s = 4, 5, 10, 10, 10 +name_wake_s = wake_s +flag_wake_deltat = 4, 5, 10, 10, 10 +name_wake_deltat = wake_deltat +flag_wake_deltaq = 4, 5, 10, 10, 10 +name_wake_deltaq = wake_deltaq +flag_wake_omg = 4, 5, 10, 10, 10 +name_wake_omg = wake_omg +flag_Vprecip = 10, 10, 10, 10, 10 +name_Vprecip = Vprecip +flag_ftd = 4, 5, 10, 10, 10 +name_ftd = ftd +flag_fqd = 4, 5, 10, 10, 10 +name_fqd = fqd +flag_dtlsc = 4, 10, 10, 10, 10 +name_dtlsc = dtlsc +flag_dtlschr = 4, 10, 10, 10, 10 +name_dtlschr = dtlschr +flag_dqlsc = 4, 10, 10, 10, 10 +name_dqlsc = dqlsc +flag_dtvdf = 4, 10, 10, 1, 10 +name_dtvdf = dtvdf +flag_dqvdf = 4, 10, 10, 1, 10 +name_dqvdf = dqvdf +flag_dteva = 4, 10, 10, 10, 10 +name_dteva = dteva +flag_dqeva = 4, 10, 10, 10, 10 +name_dqeva = dqeva +flag_ptconv = 4, 10, 10, 10, 10 +name_ptconv = ptconv +flag_ratqs = 4, 10, 10, 10, 10 +name_ratqs = ratqs +flag_dtthe = 4, 10, 10, 10, 10 +name_dtthe = dtthe +flag_f_th = 4, 10, 10, 10, 10 +name_f_th = f_th +flag_e_th = 4, 10, 10, 10, 10 +name_e_th = e_th +flag_w_th = 4, 10, 10, 10, 10 +name_w_th = w_th +flag_lambda_th = 4, 10, 10, 10, 10 +name_lambda_th = lambda_th +flag_q_th = 4, 10, 10, 10, 10 +name_q_th = q_th +flag_a_th = 4, 10, 10, 10, 10 +name_a_th = a_th +flag_d_th = 4, 10, 10, 10, 10 +name_d_th = d_th +flag_f0_th = 4, 10, 10, 10, 10 +name_f0_th = f0_th +flag_zmax_th = 4, 10, 10, 10, 10 +name_zmax_th = zmax_th +flag_dqthe = 4, 10, 10, 10, 1 +name_dqthe = dqthe +flag_dtajs = 4, 10, 10, 10, 10 +name_dtajs = dtajs +flag_dqajs = 4, 10, 10, 10, 10 +name_dqajs = dqajs +flag_dtswr = 4, 10, 10, 10, 1 +name_dtswr = dtswr +flag_dtsw0 = 4, 10, 10, 10, 10 +name_dtsw0 = dtsw0 +flag_dtlwr = 4, 10, 10, 10, 1 +name_dtlwr = dtlwr +flag_dtlw0 = 4, 10, 10, 10, 10 +name_dtlw0 = dtlw0 +flag_dtec = 4, 10, 10, 10, 10 +name_dtec = dtec +flag_duvdf = 4, 10, 10, 10, 10 +name_duvdf = duvdf +flag_dvvdf = 4, 10, 10, 10, 10 +name_dvvdf = dvvdf +flag_duoro = 4, 10, 10, 10, 10 +name_duoro = duoro +flag_dvoro = 4, 10, 10, 10, 10 +name_dvoro = dvoro +flag_dulif = 4, 10, 10, 10, 10 +name_dulif = dulif +flag_dvlif = 4, 10, 10, 10, 10 +name_dvlif = dvlif +###! Attention a refaire correctement +flag_trac01 = 4, 10, 10, 10, 10 +name_trac01 = trac01 +flag_trac02 = 4, 10, 10, 10, 10 +name_trac02 = trac02 + Index: /LMDZ4/branches/LMDZ4-dev-20091210/physiq.def =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/physiq.def (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/physiq.def (revision 1280) @@ -0,0 +1,140 @@ +# +## $Id$ +# +# +# Automatically generated make config: don t edit +# +type_ocean=force +# avec ou sans orchidee +VEGET=n +#type_run = AMIP, ENSP, clim +type_run=AMIP +# +# Controle des sorties +# sorties moyennees tous les jours dans histday.nc +OK_journe=y +# sorties moyennees tous les mois dans histmth.nc +OK_mensuel=y +# sorties moyennees toutes les 6 ou bien 3h dans histhf.nc +ok_hf=n +# sorties moyennees tous les pas de temps de la physique dans histins.nc +OK_instan=n +# +ecrit_mth=30. +ecrit_day=1. +ecrit_hf=0.25 +# +#niveau de sortie "hf" lev_histhf +lev_histhf=4 +#niveau de sortie "day" lev_histday +lev_histday=5 +#niveau de sortie "mth" lev_histmth +lev_histmth=4 + +# parametres KE +if_ebil=0 +epmax = .99 +ok_adj_ema = n +iflag_clw = 1 +# +# parametres nuages +cld_lc_lsc = 2.6e-4 +cld_lc_con = 2.6e-4 +cld_tau_lsc = 3600. +cld_tau_con = 3600. +ffallv_lsc = 1. +ffallv_con = 1. +coef_eva = 2.e-5 +reevap_ice = y +iflag_cldcon = 3 +iflag_pdf = 1 +fact_cldcon = 1. +facttemps = 1.e-4 +ok_newmicro = y +iflag_ratqs=0 +ratqsbas = 0.005 +ratqshaut = 0.33 +rad_froid = 35 +rad_chau1=12 +rad_chau2=11 +ksta_ter=1.e-7 +ksta=1.e-10 +#ok_kzmin : calcul Kzmin dans la CL de surface +ok_kzmin=y +# +# parametres climatique +R_ecc = 0.016715 +R_peri = 102.7 +R_incl = 23.441 +solaire = 1365. +co2_ppm = 348. +#RCO2 = co2_ppm * 1.0e-06 * 44.011/28.97 +#RCO2 = 348. * 1.0e-06 * 44.011/28.97 +#RCO2 = 5.286789092164308E-04 +#RCO2 = 425.43e-06 +CH4_ppb = 1650. +#RCH4 = 1.65E-06* 16.043/28.97 +#RCH4 = 9.137366240938903E-07 +N2O_ppb = 306. +#RN2O = 306.E-09* 44.013/28.97 +#RN2O = 4.648939592682085E-07 +CFC11_ppt = 280. +#RCFC11 = 280.E-12* 137.3686/28.97 +#RCFC11 = 1.327690990680013E-09 +CFC12_ppt = 484. +#RCFC12 = 484.E-12* 120.9140/28.97 +#RCFC12 = 2.020102726958923E-09 +# +# effets direct et indirect des aerosols +ok_ade=n +ok_aie=n +bl95_b0=1.7 +bl95_b1=0.2 +# +# parametres simulateur ISCCP +#ok_isccp : y/n avec/sans simulateur ISCCP +ok_isccp=n +#top_height = 1 ou 3 +top_height = 1 +#overlap = 1, 2 ou 3 +overlap = 3 +#cdmmax +cdmmax = 2.5E-3 +#cdhmax +cdhmax = 2.0E-3 +# +#ok_regdyn : y/n calcul/non des regymes dynamiques sur regions pre-definies +ok_regdyn=y +# +# Flag pour la convection (1 pour LMD, 2 pour Tiedtke, 3 KE nouvelle physique, 30 KE IPCC) +iflag_con=30 +# +# activation thermiques wake, ... +iflag_thermals = 0 +nsplit_thermals =1 +tau_thermals=1800. +iflag_pbl = 1 +iflag_coupl=0 +iflag_wake=0 +iflag_clos=0 +iflag_mix=1 +qqa1=0. +qqa2=1. +## frequence (en jours ) de l'ecriture du fichier histphy +ecritphy=30 +## Cycle diurne ou non +cycle_diurne=y +## Soil Model ou non +soil_model=y +## Choix ou non de New oliq +new_oliq=y +## Orodr ou non pour l orographie +ok_orodr=y +## Orolf ou non pour l orographie +ok_orolf=y +## Si = .T. , lecture du fichier limit avec la bonne annee +ok_limitvrai=n +## Nombre d'appels des routines de rayonnements ( par jour) +nbapp_rad=12 +## Facteur multiplication des precip convectives dans KE +cvl_corr=1.0 Index: /LMDZ4/branches/LMDZ4-dev-20091210/run.def =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/run.def (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/run.def (revision 1280) @@ -0,0 +1,23 @@ +# +## $Id$ +# +INCLUDEDEF=physiq.def +INCLUDEDEF=gcm.def +INCLUDEDEF=orchidee.def +INCLUDEDEF=output.def +## Jour de l'etat initial ( = 350 si 20 Decembre ,par expl. ,comme ici ) +dayref=1 +## Annee de l'etat initial ( avec 4 chiffres ) +anneeref=1980 +## Nombre de jours d'integration +nday=1 +## periode de sortie des variables de controle (en pas) +iconser=240 +## periode d'ecriture du fichier histoire (en jour) +iecri=1 +## flag de sortie dynzon +ok_dynzon=n +## periode de stockage fichier dynzon (en jour) +periodav=30. +## Output diagnistics from the dynamics in Grads file dyn.dat +output_grads_dyn=n Index: /LMDZ4/branches/LMDZ4-dev-20091210/traceur.def =================================================================== --- /LMDZ4/branches/LMDZ4-dev-20091210/traceur.def (revision 1280) +++ /LMDZ4/branches/LMDZ4-dev-20091210/traceur.def (revision 1280) @@ -0,0 +1,5 @@ +4 +14 14 H2Ov +10 10 H2Ol +10 10 RN +10 10 PB