Index: /LMDZ4/trunk/create_make_gcm =================================================================== --- /LMDZ4/trunk/create_make_gcm (revision 524) +++ /LMDZ4/trunk/create_make_gcm (revision 524) @@ -0,0 +1,230 @@ +#!/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 +VPP=0 +if [ "$machine" = "nymphea0" ] ; then + VPP=1 +fi +# +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo "# Definitions de Macros pour Make" +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo +echo "# Repertoires :" +echo +echo "GCM = "$gcm +if [ "$CRAY" = '0' ] ; then + echo "MACHINE = sun4" +fi +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' +echo 'RM=rm' +echo +echo "OPLINK = " +echo +echo '# Les differentes librairies pour l"edition des liens:' +echo +if [ "$XNEC" = '1' ] ; then + echo 'dyn3d = $(LIBO)/libsxdyn3d.a $(LIBO)/libsx$(FILTRE).a' + echo 'dyn2d = $(LIBO)/libsxdyn2d.a' + echo 'dyn1d = $(LIBO)/libsxdyn1d.a' + echo 'L_DYN = -lsxdyn$(DIM)d' + echo 'L_FILTRE = -lsx$(FILTRE)' + echo 'L_PHY = -lsxphy$(PHYS) ' + echo 'L_BIBIO = -lsxbibio' + echo 'L_ADJNT =' +else + echo 'dyn3d = $(LIBO)/libdyn3d.a $(LIBO)/lib$(FILTRE).a' + echo 'dyn2d = $(LIBO)/libdyn2d.a' + echo 'dyn1d = $(LIBO)/libdyn1d.a' + echo 'L_DYN = -ldyn$(DIM)d' + echo 'L_FILTRE = -l$(FILTRE)' + echo 'L_PHY = -lphy$(PHYS) ' + echo 'L_BIBIO = -lbibio' + echo 'L_ADJNT =' +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 : $(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 ; \' +if [ "$CRAY" = '0' ] ; then +echo ' $(LINK) $(PROG).o -L$(LIBO) $(L_DYN) $(L_ADJNT) $(L_FILTRE) $(L_PHY) $(L_BIBIO) $(L_DYN) $(OPLINK) $(OPTION_LINK) -o $(LOCAL_DIR)/$(PROG).e ; $(RM) $(PROG).o ' +else +echo ' $(LINK) $(PROG).o -L$(LIBO) $(L_DYN) $(L_ADJNT) $(L_FILTRE) $(L_PHY) $(L_BIBIO) $(OPLINK) $(OPTION_LINK) -o $(LOCAL_DIR)/$(PROG).e ; $(RM) $(PROG).o ' +fi +echo +echo 'dyn : $(LIBO)/libdyn$(DIM)d.a $(FILTRE)$(DIM)d' +echo +echo 'phys : $(LIBPHY)' +echo +echo 'bibio : $(LIBO)/libbibio.a' +echo +echo 'adjnt : $(LIBO)/libadjnt.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 + 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 | awk ' { print $2 } ' ) ` + do + 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 + do + if [ -f ../$dirinc/$stri ] ; then + echo $str1 \\ + str1='$(LIBF)/'`cd .. ; ls */$stri | head -1` + 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) ; \' + fi + fi + fi + if [ "$XNEC" -eq '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/trunk/gcm.def =================================================================== --- /LMDZ4/trunk/gcm.def (revision 524) +++ /LMDZ4/trunk/gcm.def (revision 524) @@ -0,0 +1,70 @@ +# +# $Header$ +# +## nombre de pas par jour (multiple de iperiod) ( ici pour dt = 1 min ) +day_step=480 +## periode pour le pas Matsuno (en pas) +iperiod=5 +## periode de la dissipation (en pas) +idissip=15 +## choix de l'operateur de dissipation (star ou non star ) +lstardis=y +## nombre d'iterations de l'operateur de dissipation gradiv +nitergdiv=1 +## 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=36000. +## 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 +## avec ou sans physique +##physic=n +iflag_phys=1 +## periode de la physique (en pas) +iphysiq=10 +## frequence (en jours ) de l'ecriture du fichier histphy +ecritphy=1 +## 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 +## Flag pour la convection (1 pour LMD, 2 pour Tiedtke, 3 KE, 4 KE vect) +iflag_con=3 +## 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/trunk/libf/bibio/formcoord.F =================================================================== --- /LMDZ4/trunk/libf/bibio/formcoord.F (revision 524) +++ /LMDZ4/trunk/libf/bibio/formcoord.F (revision 524) @@ -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/trunk/libf/bibio/initdynav.F =================================================================== --- /LMDZ4/trunk/libf/bibio/initdynav.F (revision 524) +++ /LMDZ4/trunk/libf/bibio/initdynav.F (revision 524) @@ -0,0 +1,167 @@ +! +! $Header$ +! +c +c + subroutine initdynav(infile,day0,anne0,tstep,t_ops,t_wrt + . ,nq,fileid) + + USE IOIPSL + USE histcom + + 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 nq: nombre de traceurs +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 "advtrac.h" + +C Arguments +C + character*(*) infile + integer*4 day0, anne0 + real tstep, t_ops, t_wrt + integer fileid + integer nq + integer thoriid, zvertiid + +C Variables locales +C + 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,nq + 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) + return + end Index: /LMDZ4/trunk/libf/bibio/initfluxsto.F =================================================================== --- /LMDZ4/trunk/libf/bibio/initfluxsto.F (revision 524) +++ /LMDZ4/trunk/libf/bibio/initfluxsto.F (revision 524) @@ -0,0 +1,227 @@ +! +! $Header$ +! + subroutine initfluxsto + . (infile,tstep,t_ops,t_wrt,nq, + . fileid,filevid,filedid) + + USE IOIPSL + USE histcom + + 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" + +C Arguments +C + character*(*) infile + integer*4 itau + real tstep, t_ops, t_wrt + integer fileid, filevid,filedid + integer nq,ndex(1) + real nivd(1) + +C Variables locales +C + 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 + + return + end Index: /LMDZ4/trunk/libf/bibio/inithist.F =================================================================== --- /LMDZ4/trunk/libf/bibio/inithist.F (revision 524) +++ /LMDZ4/trunk/libf/bibio/inithist.F (revision 524) @@ -0,0 +1,186 @@ +! +! $Header$ +! + subroutine inithist(infile,day0,anne0,tstep,t_ops,t_wrt,nq,fileid, + . filevid) + + USE IOIPSL + USE histcom + + 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 "advtrac.h" + +C Arguments +C + character*(*) infile + integer*4 day0, anne0 + real tstep, t_ops, t_wrt + integer fileid, filevid + integer nq + +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,nq + 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) + return + end Index: /LMDZ4/trunk/libf/bibio/lnblnk.F =================================================================== --- /LMDZ4/trunk/libf/bibio/lnblnk.F (revision 524) +++ /LMDZ4/trunk/libf/bibio/lnblnk.F (revision 524) @@ -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/trunk/libf/bibio/writedynav.F =================================================================== --- /LMDZ4/trunk/libf/bibio/writedynav.F (revision 524) +++ /LMDZ4/trunk/libf/bibio/writedynav.F (revision 524) @@ -0,0 +1,142 @@ +! +! $Header$ +! + subroutine writedynav( histid, nq, time, vcov, + , ucov,teta,ppk,phi,q,masse,ps,phis) + + USE ioipsl + 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 nqmx: nombre maxi de traceurs +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 "advtrac.h" + +C +C Arguments +C + + INTEGER histid, nq + 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,nq) + integer time + + +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,nq + 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) + return + end Index: /LMDZ4/trunk/libf/bibio/writehist.F =================================================================== --- /LMDZ4/trunk/libf/bibio/writehist.F (revision 524) +++ /LMDZ4/trunk/libf/bibio/writehist.F (revision 524) @@ -0,0 +1,128 @@ +! +! $Header$ +! + subroutine writehist( histid, histvid, nq, time, vcov, + , ucov,teta,phi,q,masse,ps,phis) + + USE ioipsl + 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 nqmx: nombre maxi de traceurs +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 "advtrac.h" + +C +C Arguments +C + + INTEGER histid, nq, 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,nq) + integer time + + +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,nq + 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 + return + end Index: /LMDZ4/trunk/libf/dyn3d/abort_gcm.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/abort_gcm.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/abort_gcm.F (revision 524) @@ -0,0 +1,43 @@ +! +! $Header$ +! +c +c + SUBROUTINE abort_gcm(modname, message, ierr) + +#ifdef CPP_IOIPSL + USE IOIPSL +#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*20 modname + integer ierr + character*80 message + + write(lunout,*) 'in abort_gcm' +#ifdef CPP_IOIPSL + call histclo + call restclo +#endif +c call getin_dump +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 + endif + STOP + END Index: /LMDZ4/trunk/libf/dyn3d/academic.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/academic.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/academic.h (revision 524) @@ -0,0 +1,5 @@ +! +! $Header$ +! + real tetarappel(ip1jmp1,llm),taurappel + common/academic/tetarappel,taurappel Index: /LMDZ4/trunk/libf/dyn3d/adaptdt.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/adaptdt.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/adaptdt.F (revision 524) @@ -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/trunk/libf/dyn3d/addfi.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/addfi.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/addfi.F (revision 524) @@ -0,0 +1,167 @@ +! +! $Header$ +! + SUBROUTINE addfi(nq, pdt, leapf, forward, + S pucov, pvcov, pteta, pq , pps , + S pdufi, pdvfi, pdhfi,pdqfi, pdpfi ) + 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 + INTEGER nq + + REAL pdt +c + REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm) + REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nq),pps(ip1jmp1) +c + REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm) + REAL pdqfi(ip1jmp1,llm,nq),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, nq + 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, nq + 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/trunk/libf/dyn3d/advect.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/advect.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/advect.F (revision 524) @@ -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/trunk/libf/dyn3d/advn.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/advn.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/advn.F (revision 524) @@ -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/trunk/libf/dyn3d/advtrac.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/advtrac.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/advtrac.F (revision 524) @@ -0,0 +1,355 @@ +! +! $Header$ +! +c +c +#ifdef INCA_CH4 + SUBROUTINE advtrac(pbaru,pbarv , + * p, masse,q,iapptrac,teta, + * flxw, + * pk, + * mmt_adj, + * hadv_flg) +#else + SUBROUTINE advtrac(pbaru,pbarv , + * p, masse,q,iapptrac,teta, + * pk) +#endif + +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 + 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 "advtrac.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,nqmx),masse(ip1jmp1,llm) + REAL p( ip1jmp1,llmp1 ),teta(ip1jmp1,llm) + REAL pk(ip1jmp1,llm) +#ifdef INCA_CH4 + INTEGER :: hadv_flg(nq) + REAL :: mmt_adj(ip1jmp1,llm) + REAL :: flxw(ip1jmp1,llm) +#endif + +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 + real cpuadv(nqmx) + common/cpuadv/cpuadv + + 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,nqmx) + REAL fluxwppm(iim,jjp1,llm) + REAL apppm(llmp1), bpppm(llmp1) + LOGICAL dum,fill + DATA fill/.true./ + DATA dum/.true./ + + + 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 ) + +#ifdef INCA_CH4 + ! ... Flux de masse diaganostiques traceurs + flxw = wg / FLOAT(iapp_tracvl) +#endif + +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------------------------------------------------------------------- +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,nqmx +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) +#ifdef INCA_CH4 + do iiq = iq+1, iq+3 + q(:,:,iiq)=q(:,:,iiq)*mmt_adj(:,:,1) + enddo +#endif + +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) +#ifdef INCA_CH4 + do iiq = iq+1, iq+9 + q(:,:,iiq)=q(:,:,iiq)*mmt_adj(:,:,1) + enddo +#endif +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) + tps_cpu=t_final-t_initial + 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/trunk/libf/dyn3d/advtrac.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/advtrac.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/advtrac.h (revision 524) @@ -0,0 +1,15 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c INCLUDE 'advtrac.h' + + COMMON/advtr/iadv,hadv,vadv,tnom,tname,ttext,niadv + INTEGER iadv(nqmx) ! indice schema de transport + INTEGER hadv(nqmx) ! indice schema transport horizontal + INTEGER vadv(nqmx) ! indice schema transport vertical + INTEGER niadv(nqmx) ! equivalent dyn / physique + character*8 tnom(nqmx) ! nom court du traceur + character*10 tname(nqmx) ! nom du traceur pour restart + character*13 ttext(nqmx) ! nom long du traceur pour sorties +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/dyn3d/advx.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/advx.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/advx.F (revision 524) @@ -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,9) + 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,9) + END DO + END DO + END DO +c + PRINT*,'------ DIAG DANS ADVX - SORTIE -----' + PRINT*,'sqf=',sqf +c------------- + + RETURN + END +C_________________________________________________________________ +C_________________________________________________________________ Index: /LMDZ4/trunk/libf/dyn3d/advxp.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/advxp.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/advxp.F (revision 524) @@ -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/trunk/libf/dyn3d/advy.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/advy.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/advy.F (revision 524) @@ -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/trunk/libf/dyn3d/advyp.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/advyp.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/advyp.F (revision 524) @@ -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/trunk/libf/dyn3d/advz.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/advz.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/advz.F (revision 524) @@ -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,9) + 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,9) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------' + PRINT*,'sqf=', sqf + +C------------------------------------------------------------- + RETURN + END +C_______________________________________________________________ +C_______________________________________________________________ Index: /LMDZ4/trunk/libf/dyn3d/advzp.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/advzp.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/advzp.F (revision 524) @@ -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/trunk/libf/dyn3d/bernoui.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/bernoui.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/bernoui.F (revision 524) @@ -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/trunk/libf/dyn3d/bilan_dyn.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/bilan_dyn.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/bilan_dyn.F (revision 524) @@ -0,0 +1,577 @@ +! +! $Header$ +! +c +c $Header$ +c + 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 * ... + + USE IOIPSL + + 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) + + + character*6 nom(nQ) + character*6 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) + + character*10 znom(ntr,nQ) + character*20 znoml(ntr,nQ) + character*10 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 + + 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 + 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)=q(:,:,:,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/trunk/libf/dyn3d/caladvtrac.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/caladvtrac.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/caladvtrac.F (revision 524) @@ -0,0 +1,141 @@ +! +! $Header$ +! +c +c +#ifdef INCA_CH4 + SUBROUTINE caladvtrac(q,pbaru,pbarv , + * p ,masse, dq , teta, + * flxw, + * pk, + * mmt_adj, + * hadv_flg) +#else + SUBROUTINE caladvtrac(q,pbaru,pbarv , + * p ,masse, dq , teta, + * pk) +#endif + +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" +#include "advtrac.h" + +c Arguments: +c ---------- + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm),masse(ip1jmp1,llm) + REAL p( ip1jmp1,llmp1),q( ip1jmp1,llm,nqmx),dq( ip1jmp1,llm,2 ) + REAL teta( ip1jmp1,llm),pk( ip1jmp1,llm) +#ifdef INCA_CH4 + INTEGER :: hadv_flg(nq) + REAL :: mmt_adj(iip1,jjp1,llm) + REAL :: flxw(ip1jmp1,llm) +#endif + +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 + +#ifdef INCA_CH4 + CALL advtrac( pbaru,pbarv, + * p, masse,q,iapptrac, teta, + . flxw, + . pk, + . mmt_adj, + . hadv_flg) +#else + CALL advtrac( pbaru,pbarv, + * p, masse,q,iapptrac, teta, + . pk) +#endif +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 + + CALL qminimum( q, 2, finmasse ) + + 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/trunk/libf/dyn3d/caldyn.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/caldyn.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/caldyn.F (revision 524) @@ -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/trunk/libf/dyn3d/caldyn0.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/caldyn0.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/caldyn0.F (revision 524) @@ -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/trunk/libf/dyn3d/calfis.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/calfis.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/calfis.F (revision 524) @@ -0,0 +1,614 @@ +! +! $Header$ +! +C +C + SUBROUTINE calfis(nq, + $ lafin, + $ rdayvrai, + $ heure, + $ pucov, + $ pvcov, + $ pteta, + $ pq, + $ pmasse, + $ pps, + $ pp, + $ ppk, + $ pphis, + $ pphi, + $ pducov, + $ pdvcov, + $ pdteta, + $ pdq, + $ pw, +#ifdef INCA_CH4 + $ flxw, +#endif + $ clesphy0, + $ pdufi, + $ pdvfi, + $ pdhfi, + $ pdqfi, + $ pdpsfi) +c +c Auteur : P. Le Van, F. Hourdin +c ......... + + 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" +#include "advtrac.h" + + INTEGER ngridmx,nq + 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 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,nqmx) + 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,nqmx) +c + REAL pw(iip1,jjp1,llm) + + 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,nqmx) + 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,nqmx) +c + REAL pcvgu(ngridmx,llm), pcvgv(ngridmx,llm) + REAL pcvgt(ngridmx,llm), pcvgq(ngridmx,llm,2) +c + REAL pvervel(ngridmx,llm) +c + REAL zdufi(ngridmx,llm),zdvfi(ngridmx,llm) + REAL zdtfi(ngridmx,llm),zdqfi(ngridmx,llm,nqmx) + REAL zdpsrf(ngridmx) +c + REAL zsin(iim),zcos(iim),z1(iim) + REAL zsinbis(iim),zcosbis(iim),z1bis(iim) + REAL unskap, pksurcp + +#ifdef INCA_CH4 + REAL flxw(iip1,jjp1,llm) + REAL flxwfi(ngridmx,llm) +#endif +c + + REAL SSUM + + LOGICAL firstcal, debut + DATA firstcal/.true./ + SAVE firstcal,debut + REAL rdayvrai +c +c----------------------------------------------------------------------- +c +c 1. Initialisations : +c -------------------- +c + + 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----------------------------------------------------------------------- +c latitude, longitude et aires des mailles pour la physique: +c ---------------------------------------------------------- + +c + IF ( firstcal ) THEN + debut = .TRUE. + 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 ---------------------------------- + + + 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,nq + 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" + + 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 + + +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 + DO l=1,llm + pvervel(1,l)=pw(1,1,l) * g /apoln + ig0=2 + DO j=2,jjm + DO i = 1, iim + pvervel(ig0,l) = pw(i,j,l) * g * unsaire(i,j) + ig0 = ig0 + 1 + ENDDO + ENDDO + pvervel(ig0,l)=pw(1,jjp1,l) * g /apols + 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 + + +#ifdef INCA_CH4 + CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,flxw,flxwfi) +#endif + + +c----------------------------------------------------------------------- +c Appel de la physique: +c --------------------- + + + CALL physiq (ngridmx, + . llm, + . nq, + . debut, + . lafin, + . rdayvrai, + . heure, + . dtphys, + . zplev, + . zplay, + . zphi, + . zphis, + . presnivs, + . clesphy0, + . zufi, + . zvfi, + . ztfi, + . zqfi, + . pvervel, +#ifdef INCA_CH4 + . flxwfi, +#endif + . zdufi, + . zdvfi, + . zdtfi, + . zdqfi, + . zdpsrf) + +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 --------------------- + + DO iq=1,nqmx + 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,nq + 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/trunk/libf/dyn3d/clesph0.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/clesph0.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/clesph0.h (revision 524) @@ -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/trunk/libf/dyn3d/coefpoly.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/coefpoly.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/coefpoly.F (revision 524) @@ -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*8 Xf1, Xf2,Xprim1,Xprim2, xtild1,xtild2, xi + REAL*8 Xfout, Xprim + REAL*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/trunk/libf/dyn3d/com_io_dyn.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/com_io_dyn.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/com_io_dyn.h (revision 524) @@ -0,0 +1,5 @@ +! +! $Header$ +! + integer histid, histvid, histaveid + common/com_io_dyn/histid, histvid, histaveid Index: /LMDZ4/trunk/libf/dyn3d/comconst.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/comconst.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/comconst.h (revision 524) @@ -0,0 +1,16 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c 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 + + 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 + +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/dyn3d/comdiss.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/comdiss.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/comdiss.h (revision 524) @@ -0,0 +1,15 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c INCLUDE 'comdiss.h' + + INTEGER niter + REAL tetau(llm),tetah(llm),cdivu,cdivh,crot + LOGICAL dissipst + + COMMON/comdissi/niter + COMMON/comdissr/tetau,tetah,cdivu,cdivh,crot + COMMON/comdissl/dissipst + +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/dyn3d/comdissip.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/comdissip.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/comdissip.h (revision 524) @@ -0,0 +1,16 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c INCLUDE dissip.h + + COMMON/comdissip/ + $ lstardis,niterdis,coefdis,tetavel,tetatemp,gamdissip + + + LOGICAL lstardis + INTEGER niterdis + + REAL tetavel,tetatemp,coefdis,gamdissip + +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/dyn3d/comdissipn.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/comdissipn.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/comdissipn.h (revision 524) @@ -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/trunk/libf/dyn3d/comdissnew.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/comdissnew.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/comdissnew.h (revision 524) @@ -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/trunk/libf/dyn3d/comgeom.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/comgeom.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/comgeom.h (revision 524) @@ -0,0 +1,33 @@ +! +! $Header$ +! +*CDK comgeom + COMMON/comgeom/ + 1 cu(ip1jmp1),cv(ip1jm),unscu2(ip1jmp1),unscv2(ip1jm), + 2 aire(ip1jmp1),airesurg(ip1jmp1),aireu(ip1jmp1), + 3 airev(ip1jm),unsaire(ip1jmp1),apoln,apols, + 4 unsairez(ip1jm),airuscv2(ip1jm),airvscu2(ip1jm), + 5 aireij1(ip1jmp1),aireij2(ip1jmp1),aireij3(ip1jmp1), + 6 aireij4(ip1jmp1),alpha1(ip1jmp1),alpha2(ip1jmp1), + 7 alpha3(ip1jmp1),alpha4(ip1jmp1),alpha1p2(ip1jmp1), + 8 alpha1p4(ip1jmp1),alpha2p3(ip1jmp1),alpha3p4(ip1jmp1), + 9 fext(ip1jm),constang(ip1jmp1),rlatu(jjp1),rlatv(jjm), + 1 rlonu(iip1),rlonv(iip1),cuvsurcv(ip1jm),cvsurcuv(ip1jm), + 1 cvusurcu(ip1jmp1),cusurcvu(ip1jmp1),cuvscvgam1(ip1jm), + 2 cuvscvgam2(ip1jm),cvuscugam1(ip1jmp1), + 3 cvuscugam2(ip1jmp1),cvscuvgam(ip1jm),cuscvugam(ip1jmp1), + 4 unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2, + 5 unsair_gam1(ip1jmp1),unsair_gam2(ip1jmp1),unsairz_gam(ip1jm), + 6 aivscu2gam(ip1jm),aiuscv2gam(ip1jm),xprimu(iip1),xprimv(iip1) + +c + REAL + 1 cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,unsaire,apoln , + 2 apols,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4, + 3 alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 , + 4 fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2 , + 5 cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1,unsapolnga2 + 6 ,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2,unsairz_gam , + 7 aivscu2gam ,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu,cusurcvu,xprimu + 8 , xprimv +c Index: /LMDZ4/trunk/libf/dyn3d/comgeom2.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/comgeom2.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/comgeom2.h (revision 524) @@ -0,0 +1,34 @@ +! +! $Header$ +! +*CDK comgeom2 + COMMON/comgeom/ + 1 cu(iip1,jjp1),cv(iip1,jjm),unscu2(iip1,jjp1),unscv2(iip1,jjm) , + 2 aire(iip1,jjp1),airesurg(iip1,jjp1),aireu(iip1,jjp1) , + 3 airev(iip1,jjm),unsaire(iip1,jjp1),apoln,apols , + 4 unsairez(iip1,jjm),airuscv2(iip1,jjm),airvscu2(iip1,jjm) , + 5 aireij1(iip1,jjp1),aireij2(iip1,jjp1),aireij3(iip1,jjp1) , + 6 aireij4(iip1,jjp1),alpha1(iip1,jjp1),alpha2(iip1,jjp1) , + 7 alpha3(iip1,jjp1),alpha4(iip1,jjp1),alpha1p2(iip1,jjp1) , + 8 alpha1p4(iip1,jjp1),alpha2p3(iip1,jjp1),alpha3p4(iip1,jjp1) , + 9 fext(iip1,jjm),constang(iip1,jjp1), rlatu(jjp1),rlatv(jjm), + 1 rlonu(iip1),rlonv(iip1),cuvsurcv(iip1,jjm),cvsurcuv(iip1,jjm) , + 1 cvusurcu(iip1,jjp1),cusurcvu(iip1,jjp1) , + 2 cuvscvgam1(iip1,jjm),cuvscvgam2(iip1,jjm),cvuscugam1(iip1,jjp1), + 3 cvuscugam2(iip1,jjp1),cvscuvgam(iip1,jjm),cuscvugam(iip1,jjp1) , + 4 unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2 , + 5 unsair_gam1(iip1,jjp1),unsair_gam2(iip1,jjp1) , + 6 unsairz_gam(iip1,jjm),aivscu2gam(iip1,jjm),aiuscv2gam(iip1,jjm) + 7 , xprimu(iip1),xprimv(iip1) + +c + REAL + 1 cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,apoln,apols,unsaire + 2 ,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4 , + 3 alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 , + 4 fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2 , + 5 cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1 , + 6 unsapolnga2,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2 , + 7 unsairz_gam,aivscu2gam,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu , + 8 cusurcvu,xprimu,xprimv +c Index: /LMDZ4/trunk/libf/dyn3d/comvert.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/comvert.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/comvert.h (revision 524) @@ -0,0 +1,12 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c 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 + +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/dyn3d/conf_dat2d.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/conf_dat2d.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/conf_dat2d.F (revision 524) @@ -0,0 +1,218 @@ +! +! $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 + + RETURN + END Index: /LMDZ4/trunk/libf/dyn3d/conf_dat3d.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/conf_dat3d.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/conf_dat3d.F (revision 524) @@ -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/trunk/libf/dyn3d/conf_gcm.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/conf_gcm.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/conf_gcm.F (revision 524) @@ -0,0 +1,765 @@ +! +! $Header$ +! +c +c + SUBROUTINE conf_gcm( tapedef, etatinit, clesphy0 ) +c + use IOIPSL + 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 "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 = 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 = 5 +!Config Help = frequence du groupement des flux (en pas de temps) + iapp_tracvl = 5 + 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 = 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 ) + +!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 = 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) + +ccc .... P.Le Van, ajout le 03/01/96 pour l'ecriture phys ... +c + +!Config Key = ecritphy +!Config Desc = Frequence d'ecriture de la physique +!Config Def = 1 +!Config Help = frequence de l'ecriture du fichier histphy +!Config en jours. + ecritphy = 1 + CALL getin('ecritphy',ecritphy) + +!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 = .TRUE. + CALL getin('cycle_diurne',cycle_diurne) + +!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 = .TRUE. + CALL getin('soil_model',soil_model) + +!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 = .TRUE. + CALL getin('new_oliq',new_oliq) + +!Config Key = ok_orodr +!Config Desc = Orodr ??? +!Config Def = y +!Config Help = Y en a pas comprendre ! +!Config + ok_orodr = .TRUE. + CALL getin('ok_orodr',ok_orodr) + +!Config Key = ok_orolf +!Config Desc = Orolf ?? +!Config Def = y +!Config Help = Connais pas ! + ok_orolf = .TRUE. + CALL getin('ok_orolf', ok_orolf) + +!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 = .FALSE. + CALL getin('ok_limitvrai',ok_limitvrai) + +!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 = 12 + CALL getin('nbapp_rad',nbapp_rad) + +!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 = 2 + CALL getin('iflag_con',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 + +!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 + PRINT *,' 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 + PRINT *,' 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 + PRINT *,' La valeur de grossismy passee par run.def est differen + * te de celle lue sur le fichier start ' + STOP + ENDIF + + IF( grossismx.LT.1. ) THEN + PRINT *,' *** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + + IF( grossismy.LT.1. ) THEN + PRINT *,' *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + + PRINT *,' alphax alphay defrun ',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 + PRINT *,' ******** PBS DANS DEFRUN ******** ' + PRINT *,' *** fxyhypb lu sur le fichier start est F ', + * 'alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.fxyhypbb ) THEN + PRINT *,' ******** PBS DANS DEFRUN ******** ' + PRINT *,' *** 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 + PRINT *,' 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 + PRINT *,' 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 + PRINT *,' 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 + PRINT *,' 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 + PRINT *,' ******** PBS DANS DEFRUN ******** ' + PRINT *,' *** ysinus lu sur le fichier start est F ', + * 'alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.ysinuss ) THEN + PRINT *,' ******** PBS DANS DEFRUN ******** ' + PRINT *,' *** ysinus lu sur le fichier start est T ', + * 'alors qu il est F sur run.def **** ' + STOP + ENDIF + ENDIF + ENDIF +c + + write(lunout,*)' #########################################' + write(lunout,*)' Configuration des parametres du gcm: ' + 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,*)' 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,*)' iflag_phys = ', iflag_phys + write(lunout,*)' iphysiq = ', iphysiq + write(lunout,*)' ecritphy = ', ecritphy + write(lunout,*)' cycle_diurne = ', cycle_diurne + write(lunout,*)' soil_model = ', soil_model + write(lunout,*)' new_oliq = ', new_oliq + write(lunout,*)' ok_orodr = ', ok_orodr + write(lunout,*)' ok_orolf = ', ok_orolf + write(lunout,*)' ok_limitvrai = ', ok_limitvrai + write(lunout,*)' nbapp_rad = ', nbapp_rad + write(lunout,*)' iflag_con = ', iflag_con + 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 + + 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 + PRINT *,' *** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + + IF( grossismy.LT.1. ) THEN + PRINT *,' *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + + PRINT *,' alphax alphay defrun ',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 + + write(lunout,*)' #########################################' + write(lunout,*)' Configuration des parametres du gcm: ' + 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,*)' 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,*)' iflag_phys = ', iflag_phys + write(lunout,*)' iphysiq = ', iphysiq + write(lunout,*)' ecritphy = ', ecritphy + write(lunout,*)' cycle_diurne = ', cycle_diurne + write(lunout,*)' soil_model = ', soil_model + write(lunout,*)' new_oliq = ', new_oliq + write(lunout,*)' ok_orodr = ', ok_orodr + write(lunout,*)' ok_orolf = ', ok_orolf + write(lunout,*)' ok_limitvrai = ', ok_limitvrai + write(lunout,*)' nbapp_rad = ', nbapp_rad + write(lunout,*)' iflag_con = ', iflag_con + write(lunout,*)' clonn = ', clonn + write(lunout,*)' clatt = ', clatt + write(lunout,*)' grossismx = ', grossismx + write(lunout,*)' grossismy = ', grossismy + write(lunout,*)' fxyhypbb = ', fxyhypbb + write(lunout,*)' dzoomx = ', dzoomx + write(lunout,*)' dzoomy = ', dzoomy + write(lunout,*)' taux = ', taux + write(lunout,*)' tauy = ', tauy +c + RETURN + END Index: /LMDZ4/trunk/libf/dyn3d/conf_guide.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/conf_guide.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/conf_guide.F (revision 524) @@ -0,0 +1,51 @@ +! +! $Header$ +! +c +c + SUBROUTINE conf_guide +c + use IOIPSL + use getparam + IMPLICIT NONE + +c----------------------------------------------------------------------- +c Parametres de controle du run: +c----------------------------------------------------------------------- +#include "guide.h" + + call getpar('guide.eff') + + call getpar('online',1,online,'Index de controle du guide') + CALL getpar('ncep',.false.,ncep,'Coordonnee vert NCEP ou ECMWF') + CALL getpar('ini_anal',.false.,ini_anal,'Initial = analyse') + + 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') + +c 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') + +c Latitude min et max pour le rappel. +c dans le cas ou on 'a les analyses que sur une bande de latitudes. + CALL getpar('lat_min_guide',-90.,lat_min_guide + s ,'Latitude minimum pour le guidage ') + CALL getpar('lat_max_guide', 90.,lat_max_guide + s ,'Latitude maximum pour le guidage ') + + + CALL getpar + + end Index: /LMDZ4/trunk/libf/dyn3d/control.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/control.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/control.h (revision 524) @@ -0,0 +1,16 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c INCLUDE 'control.h' + + COMMON/control/nday,day_step, + $ iperiod,iapp_tracvl,iconser,iecri,idissip,iphysiq , + $ periodav,ecritphy,iecrimoy,dayref,anneeref, + $ raz_date + + INTEGER nday,day_step,iperiod,iapp_tracvl,iconser,iecri, + $ idissip,iphysiq,iecrimoy,dayref,anneeref, raz_date + REAL periodav, ecritphy + +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/dyn3d/convflu.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/convflu.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/convflu.F (revision 524) @@ -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/trunk/libf/dyn3d/convmas.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/convmas.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/convmas.F (revision 524) @@ -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/trunk/libf/dyn3d/coordij.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/coordij.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/coordij.F (revision 524) @@ -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/trunk/libf/dyn3d/covcont.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/covcont.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/covcont.F (revision 524) @@ -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/trunk/libf/dyn3d/covnat.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/covnat.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/covnat.F (revision 524) @@ -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/trunk/libf/dyn3d/cray.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/cray.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/cray.F (revision 524) @@ -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/trunk/libf/dyn3d/create_etat0_limit.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/create_etat0_limit.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/create_etat0_limit.F (revision 524) @@ -0,0 +1,46 @@ +! +! $Header$ +! + PROGRAM create_etat0_limit +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 cohérences + + LOGICAL interbar, extrap , oldice + PARAMETER ( interbar = .true. , extrap = .FALSE. , oldice=.false.) +#include "dimensions.h" +#include "paramet.h" +#include "indicesol.h" +#include "dimphy.h" + REAL :: masque(iip1,jjp1) + REAL :: pctsrf(klon, nbsrf) + + WRITE(6,*) ' ********************* ' + WRITE(6,*) ' interbar = ',interbar + CALL etat0_netcdf ( interbar, masque, pctsrf ) +c + WRITE(6,1) + WRITE(6,*) ' ********************* ' + WRITE(6,*) ' *** Limit_netcdf *** ' + WRITE(6,*) ' ********************* ' + WRITE(6,1) +c + CALL limit_netcdf ( interbar, extrap , oldice, masque, pctsrf ) + +1 FORMAT(//) + + STOP + END Index: /LMDZ4/trunk/libf/dyn3d/defrun.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/defrun.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/defrun.F (revision 524) @@ -0,0 +1,502 @@ +! +! $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,*) ecritphy + WRITE(tapeout,9001) ch1,'ecritphy' + WRITE(tapeout,*) ecritphy + + 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/trunk/libf/dyn3d/description.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/description.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/description.h (revision 524) @@ -0,0 +1,5 @@ +! +! $Header$ +! + character *120 descript + common /titre/descript Index: /LMDZ4/trunk/libf/dyn3d/diagedyn.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/diagedyn.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/diagedyn.F (revision 524) @@ -0,0 +1,319 @@ +! +! $Header$ +! + +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" + +#ifdef CPP_PHYS +#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_PHYS +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 + print*,'Pour l instant diagedyn a besoin de la physique' +#endif + RETURN + END Index: /LMDZ4/trunk/libf/dyn3d/dissip.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/dissip.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/dissip.F (revision 524) @@ -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/trunk/libf/dyn3d/disvert.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/disvert.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/disvert.F (revision 524) @@ -0,0 +1,170 @@ +! +! $Header$ +! + 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" +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 + 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' + + h=7. + snorm = 0. + DO l = 1, llm + x = 2.*asin(1.) * (FLOAT(l)-0.5) / float(llm+1) + dsig(l) = 1.0 + 7.0 * SIN(x)**2 + 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 + 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/trunk/libf/dyn3d/disvert0.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/disvert0.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/disvert0.F (revision 524) @@ -0,0 +1,175 @@ +! +! $Header$ +! +c +c + SUBROUTINE disvert0(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" +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 ap(llmp1),bp(llmp1),dpres(llm),nivsigs(llm),nivsig(llmp1) + REAL pa,preff,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 + REAL alpha,beta,gama,delta,deltaz,h + INTEGER np,ierr + REAL pi,x + + REAL SSUM + + pa = 50 000. + preff = 101 325. + +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' + + h=7. + snorm = 0. + DO l = 1, llm + x = 2.*asin(1.) * (FLOAT(l)-0.5) / float(llm+1) + dsig(l) = 1.0 + 7.0 * SIN(x)**2 + 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 + 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/trunk/libf/dyn3d/diverg.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/diverg.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/diverg.F (revision 524) @@ -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/trunk/libf/dyn3d/diverg_gam.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/diverg_gam.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/diverg_gam.F (revision 524) @@ -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/trunk/libf/dyn3d/divergf.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/divergf.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/divergf.F (revision 524) @@ -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/trunk/libf/dyn3d/divergst.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/divergst.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/divergst.F (revision 524) @@ -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/trunk/libf/dyn3d/divgrad.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/divgrad.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/divgrad.F (revision 524) @@ -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/trunk/libf/dyn3d/divgrad2.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/divgrad2.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/divgrad2.F (revision 524) @@ -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/trunk/libf/dyn3d/dteta1.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/dteta1.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/dteta1.F (revision 524) @@ -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/trunk/libf/dyn3d/dudv1.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/dudv1.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/dudv1.F (revision 524) @@ -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/trunk/libf/dyn3d/dudv2.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/dudv2.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/dudv2.F (revision 524) @@ -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/trunk/libf/dyn3d/dump2d.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/dump2d.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/dump2d.F (revision 524) @@ -0,0 +1,46 @@ +! +! $Header$ +! + SUBROUTINE dump2d(im,jm,z,nom_z) + IMPLICIT NONE + INTEGER im,jm + REAL z(im,jm) + CHARACTER*80 nom_z + + INTEGER i,j,imin,illm,jmin,jllm + REAL zmin,zllm + + PRINT*,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(*,'(72i1)') (NINT(10.*(z(i,j)-zmin)/(zllm-zmin)),i=1,im) + ENDDO + ENDIF + RETURN + END Index: /LMDZ4/trunk/libf/dyn3d/dynetat0.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/dynetat0.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/dynetat0.F (revision 524) @@ -0,0 +1,383 @@ +! +! $Header$ +! + SUBROUTINE dynetat0(fichnom,nq,vcov,ucov, + . teta,q,masse,ps,phis,time) + 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" +#include "advtrac.h" + +c Arguments: +c ---------- + + CHARACTER*(*) fichnom + INTEGER nq + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nq),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 . + dzoomx = tab_cntrl(25) + dzoomy = tab_cntrl(26) + taux = tab_cntrl(28) + 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(nq.GE.1) THEN + DO iq=1,nq + 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/trunk/libf/dyn3d/dynredem.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/dynredem.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/dynredem.F (revision 524) @@ -0,0 +1,514 @@ +! +! $Header$ +! +c + SUBROUTINE dynredem0(fichnom,iday_end,phis,nq) + USE IOIPSL + 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" +#include "advtrac.h" + +c Arguments: +c ---------- + INTEGER iday_end + REAL phis(ip1jmp1) + CHARACTER*(*) fichnom + INTEGER nq + +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='dynredem' + + call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian) + call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours) + + + 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) + ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid) + 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) + ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid) + 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) + ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid) + 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) + ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid) + 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) + ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid) + 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) + ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid) + 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) + ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid) + 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) + ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid) + 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) + ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid) + 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) + ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid) + 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 + ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid) + 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 + ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid) + 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 + ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid) + 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 + ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid) + 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 + ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid) + 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 + ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid) + 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 + ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid) + 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 + ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid) + 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(nq.GE.1) THEN + DO iq=1,nq + ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid) + 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 + ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid) + 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 + ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid) + 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,nq,masse,ps) + 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 "advtrac.h" + + INTEGER nq, l + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nq) + CHARACTER*(*) fichnom + + REAL time + INTEGER nid, nvarid + INTEGER ierr + INTEGER iq + 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 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(nq.GE.1) THEN + do iq=1,nq + 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 + 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/trunk/libf/dyn3d/ener.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/ener.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/ener.h (revision 524) @@ -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/trunk/libf/dyn3d/enercin.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/enercin.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/enercin.F (revision 524) @@ -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/trunk/libf/dyn3d/etat0_netcdf.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/etat0_netcdf.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/etat0_netcdf.F (revision 524) @@ -0,0 +1,691 @@ +! +! $Header$ +! +c +c + SUBROUTINE etat0_netcdf (interbar, masque, pctsrf) + + USE startvar + USE ioipsl + ! + IMPLICIT NONE + ! +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" + ! + ! +! INTEGER, PARAMETER :: KIDIA=1, KFDIA=iim*(jjm-1)+2, +! .KLON=KFDIA-KIDIA+1,KLEV=llm + ! +#include "comgeom2.h" +#include "comvert.h" +#include "comconst.h" +#include "indicesol.h" +#include "dimphy.h" +#include "dimsoil.h" +#include "temps.h" + ! + LOGICAL interbar + REAL :: latfi(klon), lonfi(klon) + REAL :: orog(iip1,jjp1), rugo(iip1,jjp1), masque(iip1,jjp1), + . 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 :: q3d(iip1, jjp1, llm,nqmx), qsat(iip1, jjp1, llm) + REAL :: tsol(klon), qsol(klon), sn(klon) + REAL :: tsolsrf(klon,nbsrf), qsolsrf(klon,nbsrf),snsrf(klon,nbsrf) + REAL :: albe(klon,nbsrf), evap(klon,nbsrf) + REAL :: alblw(klon,nbsrf) + REAL :: tsoil(klon,nsoilmx,nbsrf) + REAL :: radsol(klon),rain_fall(klon), snow_fall(klon) + REAL :: solsw(klon), sollw(klon), fder(klon) + REAL :: deltat(klon), frugs(klon,nbsrf), agesno(klon,nbsrf) + REAL :: rugmer(klon) + REAL :: zmea(iip1*jjp1), zstd(iip1*jjp1) + REAL :: zsig(iip1*jjp1), zgam(iip1*jjp1), zthe(iip1*jjp1) + REAL :: zpic(iip1*jjp1), zval(iip1*jjp1), rugsrel(iip1*jjp1) + REAL :: qd(iip1, jjp1, llm) + REAL :: pctsrf(klon, nbsrf) + REAL :: t_ancien(klon,klev), q_ancien(klon,klev) ! + real :: clwcon(klon,klev),rnebcon(klon,klev),ratqs(klon,klev) + ! 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*80 :: varname + ! + INTEGER :: i,j, ig, l, ji,ii1,ii2 + INTEGER :: nq + 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 + INTEGER :: radpas + real zrel(iip1*jjp1),chmin,chmax + + CHARACTER*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) + ! + ! 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. + unskap = 1./kappa + ! + jmp1 = jjm + 1 + ! + ! Construct a grid + ! + +! CALL defrun_new(99,.TRUE.,clesphy0) + CALL conf_gcm( 99, .TRUE. , clesphy0 ) + + dtvr = daysec/FLOAT(day_step) + print*,'dtvr',dtvr + + CALL inicons0() + CALL inigeom() + ! + CALL inifilr() + ! + 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 + ! + + +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 = nf_open("o2a.nc", NF_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 = nf_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(:,:,:)) + ! + 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(:,:,:) + ! + 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 = 'deltat' + deltat(:) = 0.0 + CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,deltat,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 + rugsrel(:) = 0.0 + IF(ok_orodr) THEN + DO i = 1, iip1* jjp1 + rugsrel(i) = MAX( 1.e-05, zstd(i)* zsig(i) /2. ) + ENDDO + 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)) +c$$$ 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 init pour traceurs + call iniadvtrac(nq) +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 = FLOAT(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,nqmx) + print*,'sortie dynredem0' + CALL dynredem1("start.nc",0.0,vvent,uvent,tpot,q3d,nqmx,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 + tsolsrf(:,is_ter) = tsol + tsolsrf(:,is_lic) = tsol + tsolsrf(:,is_oce) = tsol + tsolsrf(:,is_sic) = tsol + snsrf(:,is_ter) = sn + snsrf(:,is_lic) = sn + snsrf(:,is_oce) = sn + snsrf(:,is_sic) = sn + albe(:,is_ter) = 0.08 + albe(:,is_lic) = 0.6 + albe(:,is_oce) = 0.5 + albe(:,is_sic) = 0.6 + alblw = albe + 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. + deltat = 0. + 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 + +cIM call phyredem("startphy.nc",phystep,radpas, co2_ppm, solaire, + call phyredem("startphy.nc",phystep,radpas, + $ latfi, lonfi, pctsrf, tsolsrf, tsoil, deltat, qsolsrf, qsol, + $ snsrf, + $ albe, alblw, evap, rain_fall, snow_fall, solsw, sollw, fder, + $ radsol, frugs, agesno, + $ zmea, zstd, zsig, zgam, zthe, zpic, zval, rugsrel, + $ t_ancien, q_ancien, rnebcon, ratqs, clwcon) + print*,'sortie phyredem' + +C Sortie Visu pour les champs dynamiques + if (1.eq.0 ) then + print*,'sortie visu' + time_step = 1. + t_ops = 2. + t_wrt = 2. + itau = 2. + visu_file='Etat0_visu.nc' + CALL initdynav(visu_file,dayref,anneeref,time_step, + . t_ops, t_wrt, nqmx, visuid) + CALL writedynav(visuid, nqmx, itau,vvent , + . uvent,tpot,pk,phi,q3d,masse,psol,phis) + else + print*,'CCCCCCCCCCCCCCCCCC REACTIVER SORTIE VISU DANS ETAT0' + endif + print*,'entree histclo' + CALL histclo + RETURN + ! + END SUBROUTINE etat0_netcdf Index: /LMDZ4/trunk/libf/dyn3d/exner_hyb.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/exner_hyb.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/exner_hyb.F (revision 524) @@ -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/trunk/libf/dyn3d/extrapol.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/extrapol.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/extrapol.F (revision 524) @@ -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/trunk/libf/dyn3d/flumass.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/flumass.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/flumass.F (revision 524) @@ -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/trunk/libf/dyn3d/friction.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/friction.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/friction.F (revision 524) @@ -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/trunk/libf/dyn3d/fxhyp.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/fxhyp.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/fxhyp.F (revision 524) @@ -0,0 +1,447 @@ +! +! $Header$ +! +c +c + SUBROUTINE fxhyp ( xzoomdeg,grossism,dzoom,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,dzoom,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*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( dzoom.LT.1.) THEN + dzoom = dzoom * depi + ELSEIF( dzoom.LT. 25. ) THEN + WRITE(6,*) ' Le param. dzoomy pour fxhyp est trop petit ! L aug + ,menter et relancer ! ' + STOP 1 + ELSE + dzoom = dzoom * 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/trunk/libf/dyn3d/fxy.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/fxy.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/fxy.F (revision 524) @@ -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/trunk/libf/dyn3d/fxyhyper.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/fxyhyper.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/fxyhyper.F (revision 524) @@ -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*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/trunk/libf/dyn3d/fxysinus.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/fxysinus.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/fxysinus.F (revision 524) @@ -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/trunk/libf/dyn3d/fyhyp.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/fyhyp.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/fyhyp.F (revision 524) @@ -0,0 +1,377 @@ +! +! $Header$ +! +c +c + SUBROUTINE fyhyp ( yzoomdeg, grossism, dzoom,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,dzoom,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*8 ylat(jjp1), yprim(jjp1) + REAL*8 yuv + REAL*8 yt(0:nmax2) + REAL*8 fhyp(0:nmax2),beta,Ytprim(0:nmax2),fxm(0:nmax2) + SAVE Ytprim, yt,Yf + REAL*8 Yf(0:nmax2),yypr(0:nmax2) + REAL*8 yvrai(jjp1), yprimm(jjp1),ylatt(jjp1) + REAL*8 pi,depi,pis2,epsilon,y0,pisjm + REAL*8 yo1,yi,ylon2,ymoy,Yprimin,champmin,champmax + REAL*8 yfi,Yf1,ffdy + REAL*8 ypn,deply,y00 + SAVE y00, deply + + INTEGER i,j,it,ik,iter,jlat + INTEGER jpn,jjpn + SAVE jpn + REAL*8 a0,a1,a2,a3,yi2,heavyy0,heavyy0m + REAL*8 fa(0:nmax2),fb(0:nmax2) + REAL y0min,y0max + + REAL*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( dzoom.LT.1.) THEN + dzoom = dzoom * pi + ELSEIF( dzoom.LT. 12. ) THEN + WRITE(6,*) ' Le param. dzoomy pour fyhyp est trop petit ! L aug + ,menter et relancer ! ' + STOP 1 + ELSE + dzoom = dzoom * 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/trunk/libf/dyn3d/gcm.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/gcm.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/gcm.F (revision 524) @@ -0,0 +1,389 @@ +! +! $Header$ +! +c +c + PROGRAM gcm + +#ifdef CPP_IOIPSL + USE IOIPSL +#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" + +c#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 q(ip1jmp1,llm,nqmx) ! 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 + + REAL rdayvrai,rdaym_ini,rday_ecri + LOGICAL first + + LOGICAL call_iniphys + data call_iniphys/.true./ + + REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm) +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 dhecdt(ip1jmp1,llm) + REAL vcont(ip1jm,llm),ucont(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 + + + LOGICAL offline ! Controle du stockage ds "fluxmass" + PARAMETER (offline=.false.) + + character*80 dynhist_file, dynhistave_file + character*20 modname + character*80 abort_message + +C Calendrier + LOGICAL true_calendar + PARAMETER (true_calendar = .false.) + +c----------------------------------------------------------------------- +c variables pour l'initialisation de la physique : +c ------------------------------------------------ + INTEGER ngridmx,nq + 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 Iflag_phys controle l'appel a la physique : +c ------------------------------------------- +c 0 : pas de physique +c 1 : Normale (appel a phylmd, phymars ...) +c 2 : rappel Newtonien pour la temperature + friction au sol + iflag_phys=1 + +c-------------------------------------------------------------------------- +c Lecture de l'etat initial : +c --------------------------- +c T : on lit start.nc +c F : le modele s'autoinitialise avec un cas academique (iniacademic) +#ifdef CPP_IOIPSL + read_start=.true. +#else + read_start=.false. +#endif + +c----------------------------------------------------------------------- +c Choix du calendrier +c ------------------- + +#ifdef CPP_IOIPSL + if (true_calendar) then + call ioconf_calendar('gregorian') + else + call ioconf_calendar('360d') + endif +#endif +c---------------------------------------------------------------------- +c lecture des fichiers gcm.def ou run.def +c --------------------------------------- +c +#ifdef CPP_IOIPSL + CALL conf_gcm( 99, .TRUE. , clesphy0 ) +#else + CALL defrun( 99, .TRUE. , clesphy0 ) +#endif +c +c +c----------------------------------------------------------------------- +c Initialisation des traceurs +c --------------------------- +c Choix du schema pour l'advection +c dans fichier trac.def ou via INCA + + call iniadvtrac(nq) +c +c----------------------------------------------------------------------- +c Lecture de l'etat initial : +c --------------------------- + +c lecture du fichier start.nc + if (read_start) then +#ifdef CPP_IOIPSL + CALL dynetat0("start.nc",nqmx,vcov,ucov, + . teta,q,masse,ps,phis, time_0) +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 + endif + + + +c le cas echeant, creation d un etat initial + IF (prt_level > 9) WRITE(lunout,*) + . 'AVANT iniacademic AVANT AVANT AVANT AVANT' + if (.not.read_start) then + CALL iniacademic(nqmx,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,*) + . ' Attention les dates initiales lues dans le fichier' + write(lunout,*) + . ' restart ne correspondent pas a celles lues dans ' + write(lunout,*)' gcm.def' + if (raz_date .ne. 1) then + write(lunout,*) + . ' 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,*) + . ' On reinitialise a la date lue dans gcm.def' + endif + ELSE + raz_date = 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 ------------------------------- +#ifdef CPP_PHYS + 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,*) + . 'WARNING!!! vitesse verticale nulle dans la physique' + CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys , + , latfi,lonfi,airefi,zcufi,zcvfi,rad,g,r,cpp ) + call_iniphys=.false. + ENDIF +#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 + +#ifdef CPP_IOIPSL + CALL dynredem0("restart.nc", day_end, phis, nqmx) + + ecripar = .TRUE. + + 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, nqmx, histid, histvid) + + t_ops = iperiod * time_step + t_wrt = periodav * daysec + CALL initdynav(dynhistave_file,day_ref,annee_ref,time_step, + . t_ops, t_wrt, nqmx, histaveid) + + dtav = iperiod*dtvr/daysec + endif + + +#endif + +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,nq,q,clesphy0) + + + + 300 FORMAT('1'/,15x,'run du pas',i7,2x,'au pas',i7,2x, + . 'c''est a dire du jour',i7,3x,'au jour',i7//) + END + Index: /LMDZ4/trunk/libf/dyn3d/geopot.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/geopot.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/geopot.F (revision 524) @@ -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/trunk/libf/dyn3d/getparam.F90 =================================================================== --- /LMDZ4/trunk/libf/dyn3d/getparam.F90 (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/getparam.F90 (revision 524) @@ -0,0 +1,100 @@ +! +! $Header$ +! +MODULE getparam + USE IOIPSL + 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/trunk/libf/dyn3d/gr_dyn_fi.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/gr_dyn_fi.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/gr_dyn_fi.F (revision 524) @@ -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/trunk/libf/dyn3d/gr_ecrit_fi.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/gr_ecrit_fi.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/gr_ecrit_fi.F (revision 524) @@ -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/trunk/libf/dyn3d/gr_fi_dyn.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/gr_fi_dyn.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/gr_fi_dyn.F (revision 524) @@ -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/trunk/libf/dyn3d/gr_int_dyn.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/gr_int_dyn.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/gr_int_dyn.F (revision 524) @@ -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/trunk/libf/dyn3d/gr_u_scal.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/gr_u_scal.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/gr_u_scal.F (revision 524) @@ -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/trunk/libf/dyn3d/gr_v_scal.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/gr_v_scal.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/gr_v_scal.F (revision 524) @@ -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/trunk/libf/dyn3d/grad.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/grad.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/grad.F (revision 524) @@ -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/trunk/libf/dyn3d/gradiv.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/gradiv.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/gradiv.F (revision 524) @@ -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/trunk/libf/dyn3d/gradiv2.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/gradiv2.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/gradiv2.F (revision 524) @@ -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/trunk/libf/dyn3d/gradsdef.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/gradsdef.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/gradsdef.h (revision 524) @@ -0,0 +1,23 @@ +! +! $Header$ +! + integer nfmx,imx,jmx,lmx,nvarmx + parameter(nfmx=10,imx=200,jmx=150,lmx=20,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/trunk/libf/dyn3d/grid_atob.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/grid_atob.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/grid_atob.F (revision 524) @@ -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*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,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,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/trunk/libf/dyn3d/grid_noro.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/grid_noro.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/grid_noro.F (revision 524) @@ -0,0 +1,518 @@ +! +! $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 zsig(imar+1,jmar),zgam(imar+1,jmar),zthe(imar+1,jmar) + REAL zpic(imar+1,jmar),zval(imar+1,jmar) +c$$$ 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 +c$$$ if(num_lan(ii,jj)/num_tot(ii,jj).ge.0.5)then +c$$$ mask(ii,jj)=1 +c$$$ else +c$$$ mask(ii,jj)=0 +c$$$ 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. + + 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) +C$$$ Masque prenant en compte maximum de terre +C$$$ On seuil a 10% de terre de terre car en dessous les parametres de surface n'on +C$$$ 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: +c$$$ zsig(ii,jj)=sqrt(xq)*mask(ii,jj) +c$$$c isotropy: +c$$$ zgam(ii,jj)=xp/xq*mask(ii,jj) +c$$$c angle theta: +c$$$ zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask(ii,jj) +c$$$ zphi(ii,jj)=zmea(ii,jj)*mask(ii,jj) +c$$$ zmea(ii,jj)=zmea(ii,jj)*mask(ii,jj) +c$$$ zpic(ii,jj)=zpic(ii,jj)*mask(ii,jj) +c$$$ zval(ii,jj)=zval(ii,jj)*mask(ii,jj) +c$$$ zstd(ii,jj)=zstd(ii,jj)*mask(ii,jj) +C$$* 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) + zphi(ii,jj)=zmea(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/trunk/libf/dyn3d/grilles_gcm_netcdf.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/grilles_gcm_netcdf.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/grilles_gcm_netcdf.F (revision 524) @@ -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 + rlonvdeg(i)=rlonv(i)*180./pi + 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/trunk/libf/dyn3d/groupe.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/groupe.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/groupe.F (revision 524) @@ -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/trunk/libf/dyn3d/groupeun.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/groupeun.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/groupeun.F (revision 524) @@ -0,0 +1,60 @@ +! +! $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 airen,airecn,qn + real aires,airecs,qs + + integer i,j,l,ig,j1,j2,i0,jd + +Champs 3D + jd=jjp1-jjmax + do l=1,llm + j1=1+jd + j2=2 + do ig=1,ngroup + do j=j1-jd,j2-jd +c print*,'groupe ',ig,' j= ',j,2**(ngroup-ig+1),'pts groupes' + do i0=1,iim,2**(ngroup-ig+1) + airen=0. + airecn=0. + qn=0. + aires=0. + airecs=0. + qs=0. + do i=i0,i0+2**(ngroup-ig+1)-1 + airen=airen+aire(i,j) + aires=aires+aire(i,jjp1-j+1) + qn=qn+q(i,j,l) + qs=qs+q(i,jjp1-j+1-jd,l) + enddo + airecn=0. + airecs=0. + do i=i0,i0+2**(ngroup-ig+1)-1 + q(i,j,l)=qn*aire(i,j)/airen + q(i,jjp1-j+1-jd,l)=qs*aire(i,jjp1-j+1)/aires + enddo + enddo + q(iip1,j,l)=q(1,j,l) + q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l) + enddo + j1=j2+1 + j2=j2+2**ig + enddo + enddo + + return + end Index: /LMDZ4/trunk/libf/dyn3d/guide.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/guide.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/guide.F (revision 524) @@ -0,0 +1,500 @@ +! +! $Header$ +! + subroutine guide(itau,ucov,vcov,teta,q,masse,ps) + + 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: F.Hourdin +c ------- +c +c Objet: +c ------ +c +c GCM LMD nouvelle grille +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 de Van-leer pour l'advection de +c q , en faisant iadv = 10 dans traceur (29/04/97) . +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 "netcdf.inc" +#include "description.h" +#include "serre.h" +#include "tracstoke.h" +#include "guide.h" + + +c variables dynamiques + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL q(ip1jmp1,llm) ! temperature potentielle + REAL ps(ip1jmp1) ! pression au sol + REAL masse(ip1jmp1,llm) ! masse d'air + +c common passe pour des sorties + real dxdys(iip1,jjp1),dxdyu(iip1,jjp1),dxdyv(iip1,jjm) + common/comdxdy/dxdys,dxdyu,dxdyv + +c variables dynamiques pour les reanalyses. + REAL ucovrea1(ip1jmp1,llm),vcovrea1(ip1jm,llm) !vts cov reas + REAL tetarea1(ip1jmp1,llm) ! temp pot reales + REAL qrea1(ip1jmp1,llm) ! temp pot reales + REAL masserea1(ip1jmp1,llm) ! masse + REAL psrea1(ip1jmp1) ! ps + REAL ucovrea2(ip1jmp1,llm),vcovrea2(ip1jm,llm) !vts cov reas + REAL tetarea2(ip1jmp1,llm) ! temp pot reales + REAL qrea2(ip1jmp1,llm) ! temp pot reales + REAL masserea2(ip1jmp1,llm) ! masse + REAL psrea2(ip1jmp1) ! ps + real latmin + + real alpha_q(ip1jmp1) + real alpha_T(ip1jmp1),alpha_P(ip1jmp1) + real alpha_u(ip1jmp1),alpha_v(ip1jm) + real dday_step,toto,reste,itau_test + INTEGER step_rea,count_no_rea + + real aire_min,aire_max + integer ilon,ilat + real factt,ztau(ip1jmp1) + + INTEGER itau,ij,l,i,j + integer ncidt,varidpl,nlev,status + integer rcod,rid + real ditau,tau,a + save nlev + +c TEST SUR QSAT + real p(ip1jmp1,llmp1),pk(ip1jmp1,llm),pks(ip1jmp1) + real pkf(ip1jmp1,llm) + real pres(ip1jmp1,llm) + REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm) + + real qsat(ip1jmp1,llm) + real unskap + real tnat(ip1jmp1,llm) +ccccccccccccccccc + + + LOGICAL first + save first + data first/.true./ + + save ucovrea1,vcovrea1,tetarea1,masserea1,psrea1,qrea1 + save ucovrea2,vcovrea2,tetarea2,masserea2,psrea2,qrea2 + + save alpha_T,alpha_q,alpha_u,alpha_v,alpha_P,itau_test + save step_rea,count_no_rea + + character*10 file + integer igrads + real dtgrads + save igrads,dtgrads + data igrads,dtgrads/2,100./ + +C----------------------------------------------------------------------- +c calcul de l'humidite saturante +C----------------------------------------------------------------------- + print*,'OK0' + CALL pression( ip1jmp1, ap, bp, ps, p ) + call massdair(p,masse) + print*,'OK1' + CALL exner_hyb(ip1jmp1,ps,p,alpha,beta,pks,pk,pkf) + print*,'OK2' + tnat(:,:)=pk(:,:)*teta(:,:)/cpp + print*,'OK3' + unskap = 1./ kappa + pres(:,:)=preff*(pk(:,:)/cpp)**unskap + print*,'OK4' + call q_sat(iip1*jjp1*llm,tnat,pres,qsat) + +C----------------------------------------------------------------------- + +c----------------------------------------------------------------------- +c initialisations pour la lecture des reanalyses. +c alpha determine la part des injections de donnees a chaque etape +c alpha=1 signifie pas d'injection +c alpha=0 signifie injection totale +c----------------------------------------------------------------------- + + print*,'ONLINE=',online + if(online.eq.-1) then + return + endif + + if (first) then + + print*,'initialisation du guide ' + call conf_guide + print*,'apres conf_guide' + + file='guide' + call inigrads(igrads,iip1 + s ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi + s ,llm,presnivs,1. + s ,dtgrads,file,'dyn_zon ') + + print* + s ,'1: en-ligne, 0: hors-ligne (x=x_rea), -1: climat (x=x_gcm)' + + if(online.eq.-1) return + if (online.eq.1) then + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c Constantes de temps de rappel en jour +c 0.1 c'est en gros 2h30. +c 1e10 est une constante infinie donc en gros pas de guidage +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c coordonnees du centre du zoom + call coordij(clon,clat,ilon,ilat) +c aire de la maille au centre du zoom + aire_min=aire(ilon+(ilat-1)*iip1) +c aire maximale de la maille + aire_max=0. + do ij=1,ip1jmp1 + aire_max=max(aire_max,aire(ij)) + enddo +C factt = pas de temps en fraction de jour + factt=dtvr*iperiod/daysec + +c subroutine tau2alpha(type,im,jm,factt,taumin,taumax,alpha) + 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) + + call dump2d(iip1,jjp1,aire,'AIRE MAILLe ') + call dump2d(iip1,jjp1,alpha_u,'COEFF U ') + call dump2d(iip1,jjp1,alpha_T,'COEFF T ') + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c Cas ou on force exactement par les variables analysees + else + alpha_T=0. + alpha_u=0. + alpha_v=0. + alpha_P=0. +c physic=.false. + endif + + itau_test=1001 + step_rea=1 + count_no_rea=0 + +c itau_test montre si l'importation a deja ete faite au rang itau +c lecture d'un fichier netcdf pour determiner le nombre de niveaux + ncidt=NCOPN('T.nc',NCNOWRIT,rcod) + if (ncep) then + status=NF_INQ_DIMID(ncidt,'LEVEL',rid) + else + status=NF_INQ_DIMID(ncidt,'PRESSURE',rid) + endif + status=NF_INQ_DIMLEN(ncidt,rid,nlev) + print *,'nlev', nlev + call ncclos(ncidt,rcod) +c Lecture du premier etat des reanalyses. + call read_reanalyse(1,ps + s ,ucovrea2,vcovrea2,tetarea2,qrea2,masserea2,psrea2,1,nlev) + qrea2(:,:)=max(qrea2(:,:),0.1) + + +c----------------------------------------------------------------------- +c Debut de l'integration temporelle: +c ---------------------------------- + + endif ! first +c +C----------------------------------------------------------------------- +C----- IMPORTATION DES VENTS,PRESSION ET TEMPERATURE REELS: +C----------------------------------------------------------------------- + + ditau=real(itau) + DDAY_step=real(day_step) + write(*,*)'ditau,dday_step' + write(*,*)ditau,dday_step + toto=4*ditau/dday_step + reste=toto-aint(toto) +c write(*,*)'toto,reste',toto,reste + + if (reste.eq.0.) then + if (itau_test.eq.itau) then + write(*,*)'deuxieme passage de advreel a itau=',itau + stop + else + vcovrea1(:,:)=vcovrea2(:,:) + ucovrea1(:,:)=ucovrea2(:,:) + tetarea1(:,:)=tetarea2(:,:) + qrea1(:,:)=qrea2(:,:) + + print*,'LECTURE REANALYSES, pas ',step_rea + s ,'apres ',count_no_rea,' non lectures' + step_rea=step_rea+1 + itau_test=itau + call read_reanalyse(step_rea,ps + s ,ucovrea2,vcovrea2,tetarea2,qrea2,masserea2,psrea2,1,nlev) + qrea2(:,:)=max(qrea2(:,:),0.1) + factt=dtvr*iperiod/daysec + ztau(:)=factt/max(alpha_T(:),1.e-10) + call wrgrads(igrads,1,aire ,'aire ','aire ' ) + call wrgrads(igrads,1,dxdys ,'dxdy ','dxdy ' ) + call wrgrads(igrads,1,alpha_u,'au ','au ' ) + call wrgrads(igrads,1,alpha_T,'at ','at ' ) + call wrgrads(igrads,1,ztau,'taut ','taut ' ) + call wrgrads(igrads,llm,ucov,'u ','u ' ) + call wrgrads(igrads,llm,ucovrea2,'ua ','ua ' ) + call wrgrads(igrads,llm,teta,'T ','T ' ) + call wrgrads(igrads,llm,tetarea2,'Ta ','Ta ' ) + call wrgrads(igrads,llm,qrea2,'Qa ','Qa ' ) + call wrgrads(igrads,llm,q,'Q ','Q ' ) + + call wrgrads(igrads,llm,qsat,'QSAT ','QSAT ' ) + + endif + else + count_no_rea=count_no_rea+1 + endif + +C----------------------------------------------------------------------- +c Guidage +c x_gcm = a * x_gcm + (1-a) * x_reanalyses +C----------------------------------------------------------------------- + + if(ini_anal) print*,'ATTENTION !!! ON PART DU GUIDAGE' + + ditau=real(itau) + dday_step=real(day_step) + + + tau=4*ditau/dday_step + tau=tau-aint(tau) + + print*,'ATTENTION !!!! ON NE GUIDE QUE JUSQU A 15N' + +c ucov + if (guide_u) then + do l=1,llm + do ij=1,ip1jmp1 + a=(1.-tau)*ucovrea1(ij,l)+tau*ucovrea2(ij,l) + ucov(ij,l)=(1.-alpha_u(ij))*ucov(ij,l)+alpha_u(ij)*a + if (first.and.ini_anal) ucov(ij,l)=a + enddo + enddo + endif + +c teta + if (guide_T) then + do l=1,llm + do ij=1,ip1jmp1 + a=(1.-tau)*tetarea1(ij,l)+tau*tetarea2(ij,l) + teta(ij,l)=(1.-alpha_T(ij))*teta(ij,l)+alpha_T(ij)*a + if (first.and.ini_anal) teta(ij,l)=a + enddo + enddo + endif + +c P + if (guide_P) then + do ij=1,ip1jmp1 + a=(1.-tau)*psrea1(ij)+tau*psrea2(ij) + ps(ij)=(1.-alpha_P(ij))*ps(ij)+alpha_P(ij)*a + if (first.and.ini_anal) ps(ij)=a + enddo + CALL pression(ip1jmp1,ap,bp,ps,p) + CALL massdair(p,masse) + endif + + +c q + if (guide_Q) then + do l=1,llm + do ij=1,ip1jmp1 + a=(1.-tau)*qrea1(ij,l)+tau*qrea2(ij,l) +c hum relative en % -> hum specif + a=qsat(ij,l)*a*0.01 + q(ij,l)=(1.-alpha_Q(ij))*q(ij,l)+alpha_Q(ij)*a + if (first.and.ini_anal) q(ij,l)=a + enddo + enddo + endif + +c vcov + if (guide_v) then + do l=1,llm + do ij=1,ip1jm + a=(1.-tau)*vcovrea1(ij,l)+tau*vcovrea2(ij,l) + vcov(ij,l)=(1.-alpha_v(ij))*vcov(ij,l)+alpha_v(ij)*a + if (first.and.ini_anal) vcov(ij,l)=a + enddo + if (first.and.ini_anal) vcov(ij,l)=a + enddo + endif + +c call dump2d(iip1,jjp1,tetarea1,'TETA REA 1 ') +c call dump2d(iip1,jjp1,tetarea2,'TETA REA 2 ') +c call dump2d(iip1,jjp1,teta,'TETA ') + + first=.false. + + return + end + +c======================================================================= + subroutine tau2alpha(type,pim,pjm,factt,taumin,taumax,alpha) +c======================================================================= + + implicit none + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" +#include "guide.h" +#include "serre.h" + +c arguments : + integer type + integer pim,pjm + real factt,taumin,taumax,dxdymin,dxdymax + real dxdy_,alpha(pim,pjm) + real dxdy_min,dxdy_max + +c local : + real alphamin,alphamax,gamma,xi + save gamma + integer i,j,ilon,ilat + + logical first + save first + data first/.true./ + + real cus(iip1,jjp1),cvs(iip1,jjp1) + real cuv(iip1,jjm),cvu(iip1,jjp1) + real zdx(iip1,jjp1),zdy(iip1,jjp1) + + real zlat + real dxdys(iip1,jjp1),dxdyu(iip1,jjp1),dxdyv(iip1,jjm) + common/comdxdy/dxdys,dxdyu,dxdyv + + if (first) then + 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 + 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 + do j=1,jjm + do i=1,iip1 + dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j)) + enddo + enddo + + call dump2d(iip1,jjp1,dxdys,'DX2DY2 SCAL ') + call dump2d(iip1,jjp1,dxdyu,'DX2DY2 U ') + call dump2d(iip1,jjp1,dxdyv,'DX2DY2 v ') + +c coordonnees du centre du zoom + call coordij(clon,clat,ilon,ilat) +c aire de la maille au centre du zoom + dxdy_min=dxdys(ilon,ilat) +c 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 + + 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 + print*,'gamma=',gamma + gamma=log(0.5)/log(gamma) + endif + endif + + alphamin=factt/taumax + alphamax=factt/taumin + + do j=1,pjm + do i=1,pim + if (type.eq.1) then + dxdy_=dxdys(i,j) + zlat=rlatu(j)*180./pi + elseif (type.eq.2) then + dxdy_=dxdyu(i,j) + zlat=rlatu(j)*180./pi + elseif (type.eq.3) then + dxdy_=dxdyv(i,j) + zlat=rlatv(j)*180./pi + endif + xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma +c pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin + xi=min(xi,1.) + if(lat_min_guide.le.zlat .and. zlat.le.lat_max_guide) then + alpha(i,j)=xi*alphamin+(1.-xi)*alphamax + else + alpha(i,j)=0. + endif + enddo + enddo + + + return + end Index: /LMDZ4/trunk/libf/dyn3d/guide.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/guide.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/guide.h (revision 524) @@ -0,0 +1,39 @@ +! +! $Header$ +! + real tau_min_u,tau_max_u + real tau_min_v,tau_max_v + real tau_min_T,tau_max_T + real tau_min_q,tau_max_q + real tau_min_P,tau_max_P + real aire_min,aire_max + + + logical guide_u,guide_v,guide_T,guide_Q,guide_P + + real lat_min_guide,lat_max_guide + + +c data tau_min_u,tau_max_u/0.02,10./ +c data tau_min_v,tau_max_v/0.02,10./ +c data tau_min_T,tau_max_T/0.02,10./ +c data tau_min_q,tau_max_q/0.02,10./ +c data tau_min_P,tau_max_P/0.02,10./ +c + LOGICAL ncep,ini_anal + integer online + +c data online/1/ +c data ncep,ini_anal/.false.,.true./ + + common/comguide/ + s tau_min_u,tau_max_u, + s tau_min_v,tau_max_v, + s tau_min_T,tau_max_T, + s tau_min_q,tau_max_q, + s tau_min_P,tau_max_P, + s aire_min,aire_max, + s lat_min_guide,lat_max_guide, + s ncep,ini_anal, + s online, + s guide_u,guide_v,guide_T,guide_Q,guide_P Index: /LMDZ4/trunk/libf/dyn3d/heavyside.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/heavyside.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/heavyside.F (revision 524) @@ -0,0 +1,23 @@ +! +! $Header$ +! +c +c + FUNCTION heavyside(a) + +c ... P. Le Van .... +c + IMPLICIT NONE + + REAL*8 heavyside , a + + IF ( a.LE.0. ) THEN + heavyside = 0. + ELSE + heavyside = 1. + ENDIF + + RETURN + END + + Index: /LMDZ4/trunk/libf/dyn3d/iniacademic.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/iniacademic.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/iniacademic.F (revision 524) @@ -0,0 +1,194 @@ +! +! $Header$ +! +c +c + SUBROUTINE iniacademic(nq,vcov,ucov,teta,q,masse,ps,phis,time_0) + +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" + +c Arguments: +c ---------- + + integer nq + 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,nq) ! champs advectes + REAL ps(ip1jmp1) ! pression au sol + REAL masse(ip1jmp1,llm) ! masse d'air + 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 phis(ip1jmp1) ! geopotentiel au sol + REAL phi(ip1jmp1,llm) ! geopotentiel + + + + + +c Local: +c ------ + + 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----------------------------------------------------------------------- + +c + time_0=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 = 50 000. + etot0 = 0. + ptot0 = 0. + ztot0 = 0. + stot0 = 0. + ang0 = 0. + pa = 0. + + CALL inicons0 + 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 + ENDDO + + 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:nq)=0. + + +c perturbation al\351atoire sur la temp\351rature + 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. + + return + END +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/dyn3d/iniadvtrac.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/iniadvtrac.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/iniadvtrac.F (revision 524) @@ -0,0 +1,216 @@ +! +! $Header$ +! +c +c + subroutine iniadvtrac(nq) + USE ioipsl +#ifdef INCA + USE transport_controls, only : hadv_flg, vadv_flg + USE chemshut +#endif + IMPLICIT NONE +c======================================================================= +c +c Auteur: P. Le Van /L. Fairhead/F.Hourdin +c ------- +c Modif special traceur F.Forget 05/94 +c Modif M-A Filiberti 02/02 lecture de traceur.def +c +c Objet: +c ------ +c +c GCM LMD nouvelle grille +c +c======================================================================= +c ... modification de l'integration de q ( 26/04/94 ) .... +c----------------------------------------------------------------------- +c Declarations: +c ------------- +C +#include "dimensions.h" +#include "advtrac.h" + +c local + character*3 descrq(30) + character*1 txts(3) + character*2 txtp(9) + character*13 str1,str2,str3 + + integer nq,iq,iiq,iiiq,ierr,ii + integer lnblnk + external lnblnk + + data txts/'x','y','z'/ + data txtp/'x','y','z','xx','xy','xz','yy','yz','zz'/ + +c----------------------------------------------------------------------- +c Initialisations: +c ---------------- + 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' + +c----------------------------------------------------------------------- +c Choix des schemas d'advection pour l'eau et les traceurs +c +c iadv = 1 schema transport type "humidite specifique LMD" +c iadv = 2 schema amont +c iadv = 14 schema Van-leer + humidite specifique +c Modif F.Codron +c iadv = 10 schema Van-leer (retenu pour l'eau vapeur et liquide) +c iadv = 11 schema Van-Leer pour hadv et version PPM (Monotone) pour vadv +c iadv = 12 schema Frederic Hourdin I +c iadv = 13 schema Frederic Hourdin II +c iadv = 16 schema PPM Monotone(Collela & Woodward 1984) +c iadv = 17 schema PPM Semi Monotone (overshoots autorisés) +c iadv = 18 schema PPM Positif Defini (overshoots undershoots autorisés) +c iadv = 20 schema Slopes +c iadv = 30 schema Prather +c +c Dans le tableau q(ij,l,iq) : iq = 1 pour l'eau vapeur +c iq = 2 pour l'eau liquide +c Et eventuellement iq = 3,nqmx pour les autres traceurs +c +c iadv(1): choix pour l'eau vap. et iadv(2) : choix pour l'eau liq. +C------------------------------------------------------------------------ +c Choix du schema d'advection +c------------------------------------------------------------------ +c choix par defaut = van leer pour tous les traceurs + do iq=1,nqmx + iadv(iq)=10 + str1(1:1)='q' + if (nqmx.le.99) then + WRITE(str1(2:3),'(i2.2)') iq + else + WRITE(str1(2:4),'(i3.3)') iq + endif + tnom(iq)=str1 + tname(iq)=tnom(iq) + str2=tnom(iq) + ttext(iq)=str2(1:lnblnk(str2))//descrq(iadv(iq)) + end do + nq=nqmx +c------------------------------------------------------------------ +c Choix du schema pour l'advection +c dans fichier traceur.def +c------------------------------------------------------------------ +#ifdef INCA +C le module de chimie fournit les noms des traceurs +C et les schemas d'advection associes. + tnom(1)='H2Ov' + tnom(2)='H2Ol' + nq=nbtrac+2 + if (nq.gt.nqmx) then + print*,'nombre de traceurs incompatible INCA/LMDZT' + stop + endif + do iq =3,nq + tnom(iq)=tracnam(iq-2) + end do + do iq =1,nq + hadv(iq)= hadv_flg(iq) + vadv(iq)= vadv_flg(iq) + end do +#else + print*,'ouverture de traceur.def' + open(90,file='traceur.def',form='formatted',status='old', + s iostat=ierr) + if(ierr.eq.0) then + print*,'ouverture de traceur.def ok' + read(90,*) nq + print*,'nombre de traceurs ',nq + if (nq.gt.nqmx) then + print*,'nombre de traceurs trop important' + print*,'verifier traceur.def' + stop + endif +C + do iq=1,nq + read(90,999) hadv(iq),vadv(iq),tnom(iq) + end do + close(90) + PRINT*,'lecture de traceur.def :' + do iq=1,nq + write(*,*) hadv(iq),vadv(iq),tnom(iq) + end do + else + print*,'pb ouverture traceur.def' + print*,'ATTENTION on prend des valeurs par defaut' + endif +#endif +c a partir du nom court du traceur et du schema d'advection au detemine le nom long. + iiq=0 + ii=0 + do iq=1,nq + iiq=iiq+1 + if (hadv(iq).ne.vadv(iq)) then + if (hadv(iq).eq.10.and.vadv(iq).eq.16) then + iadv(iiq)=11 + else + print*,'le choix des schemas d''advection H et V' + print*, 'est non disponible actuellement' + stop + endif + else + iadv(iiq)=hadv(iq) + endif +c verification nombre de traceurs + if (iadv(iiq).lt.20) then + ii=ii+1 + elseif (iadv(iiq).eq.20) then + ii=ii+4 + elseif (iadv(iiq).eq.30) then + ii=ii+10 + endif + + str1=tnom(iq) + tname(iiq)=tnom(iq) + ttext(iiq)=str1(1:lnblnk(str1))//descrq(iadv(iiq)) + str2=ttext(iiq) +c schemas tenant compte des moments d'ordre superieur. + if (iadv(iiq).eq.20) then + do iiiq=1,3 + iiq=iiq+1 + iadv(iiq)=-20 + ttext(iiq)=str2(1:lnblnk(str2))//txts(iiiq) + tname(iiq)=str1(1:lnblnk(str1))//txts(iiiq) + enddo + elseif (iadv(iiq).eq.30) then + do iiiq=1,9 + iiq=iiq+1 + iadv(iiq)=-30 + ttext(iiq)=str2(1:lnblnk(str2))//txtp(iiiq) + tname(iiq)=str1(1:lnblnk(str1))//txtp(iiiq) + enddo + endif + end do + if(ii.ne.nqmx) then + print*,'WARNING' + print*,'le nombre de traceurs et de moments eventuels' + print*,'est inferieur a nqmx ' + endif + if (iiq.gt.nqmx) then + print*,'le choix des schemas est incompatible avec ' + print*,'la dimension nqmx (nombre de traceurs)' + print*,'verifier traceur.def ou la namelist INCA' + print*,'ou recompiler avec plus de traceurs' + stop + endif + iiq=0 + do iq=1,nqmx + if(iadv(iq).ge.0) then + iiq=iiq+1 + niadv(iiq)=iq + endif + end do + return +999 format (i2,1x,i2,1x,a8) + END Index: /LMDZ4/trunk/libf/dyn3d/inicons0.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/inicons0.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/inicons0.F (revision 524) @@ -0,0 +1,55 @@ +! +! $Header$ +! + SUBROUTINE inicons0 + 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" +#include "comdissnew.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----------------------------------------------------------------------- + r = cpp * kappa + + PRINT*,' Cp R kappa ', cpp, r , kappa +c +c----------------------------------------------------------------------- + + CALL disvert0(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig) +c +c + RETURN + END Index: /LMDZ4/trunk/libf/dyn3d/iniconst.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/iniconst.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/iniconst.F (revision 524) @@ -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/trunk/libf/dyn3d/inidissip.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/inidissip.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/inidissip.F (revision 524) @@ -0,0 +1,216 @@ +! +! $Header$ +! + 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" + + 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 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 -------------------------------------------------- + + DO l=1,llm + zvert(l)=1. + ENDDO + + fact=2. +c + DO l = 1, llm + zz = 1. - preff/presnivs(l) + zvert(l)= fact -( fact-1.)/( 1.+zz*zz ) + ENDDO + + + 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/trunk/libf/dyn3d/inigeom.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/inigeom.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/inigeom.F (revision 524) @@ -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/trunk/libf/dyn3d/inigrads.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/inigrads.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/inigrads.F (revision 524) @@ -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/trunk/libf/dyn3d/iniprint.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/iniprint.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/iniprint.h (revision 524) @@ -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/trunk/libf/dyn3d/initial0.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/initial0.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/initial0.F (revision 524) @@ -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/trunk/libf/dyn3d/integrd.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/integrd.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/integrd.F (revision 524) @@ -0,0 +1,232 @@ +! +! $Header$ +! + 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 "advtrac.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 + + 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 ) +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/trunk/libf/dyn3d/inter_barx.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/inter_barx.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/inter_barx.F (revision 524) @@ -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) = AMOD( 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(1h-)) +2 FORMAT(1x,8f8.2) + + RETURN + END Index: /LMDZ4/trunk/libf/dyn3d/inter_barxy.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/inter_barxy.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/inter_barxy.F (revision 524) @@ -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/trunk/libf/dyn3d/inter_bary.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/inter_bary.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/inter_bary.F (revision 524) @@ -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/trunk/libf/dyn3d/interpost.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/interpost.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/interpost.F (revision 524) @@ -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/trunk/libf/dyn3d/interpre.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/interpre.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/interpre.F (revision 524) @@ -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/trunk/libf/dyn3d/ismax.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/ismax.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/ismax.F (revision 524) @@ -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/trunk/libf/dyn3d/ismin.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/ismin.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/ismin.F (revision 524) @@ -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/trunk/libf/dyn3d/juldate.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/juldate.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/juldate.F (revision 524) @@ -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/trunk/libf/dyn3d/laplacien.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/laplacien.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/laplacien.F (revision 524) @@ -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/trunk/libf/dyn3d/laplacien_gam.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/laplacien_gam.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/laplacien_gam.F (revision 524) @@ -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/trunk/libf/dyn3d/laplacien_rot.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/laplacien_rot.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/laplacien_rot.F (revision 524) @@ -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/trunk/libf/dyn3d/laplacien_rotgam.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/laplacien_rotgam.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/laplacien_rotgam.F (revision 524) @@ -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/trunk/libf/dyn3d/leapfrog.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/leapfrog.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/leapfrog.F (revision 524) @@ -0,0 +1,658 @@ +! +! $Header$ +! +c +c + SUBROUTINE leapfrog(ucov,vcov,teta,ps,masse,phis,nq,q,clesphy0) + +#ifdef INCA + USE transport_controls, ONLY : hadv_flg, mmt_adj +#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 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" + +c#include "tracstoke.h" + +#include "academic.h" + + integer nq + + 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,nqmx) ! 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,nqmx),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,nqmx),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*4 iday ! jour julien + REAL time ! Heure de la journee en fraction d'1 jour + + REAL SSUM + REAL time_0 , finvmaold(ip1jmp1,llm) + + LOGICAL lafin + INTEGER ij,iq,l + INTEGER ik + + real time_step, t_wrt, t_ops + + REAL rdayvrai,rdaym_ini + LOGICAL first,callinigrads + + data callinigrads/.true./ + character*10 string10 + + REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm) +#ifdef INCA_CH4 + REAL :: flxw(ip1jmp1,llm) +#endif + +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 + INTEGER ip_ebil_dyn ! PRINT level for energy conserv. diag. + SAVE ip_ebil_dyn + DATA ip_ebil_dyn/0/ +c-jld + + LOGICAL offline ! Controle du stockage ds "fluxmass" + PARAMETER (offline=.false.) + + character*80 dynhist_file, dynhistave_file + character*20 modname + character*80 abort_message + +C Calendrier + LOGICAL true_calendar + PARAMETER (true_calendar = .false.) + + logical dissip_conservative + save dissip_conservative + data dissip_conservative/.true./ + + LOGICAL prem + save prem + DATA prem/.true./ + INTEGER testita + PARAMETER (testita = 9) + + itaufin = nday*day_step + itaufinp1 = itaufin +1 + + + 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----------------------------------------------------------------------- +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 + + +#ifdef CPP_IOIPSL + if (ok_guide) then + call guide(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 + 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 ) + + 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.NE.0 ) 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.NE.0) apphys=.TRUE. + END IF + +c----------------------------------------------------------------------- +c calcul des tendances dynamiques: +c -------------------------------- + + CALL geopot ( ip1jmp1, teta , pk , pks, phis , phi ) + + CALL caldyn + $ ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , + $ phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time+iday-day_ini ) + +c----------------------------------------------------------------------- +c calcul des tendances advection des traceurs (dont l'humidite) +c ------------------------------------------------------------- + + IF( forward. OR . leapf ) THEN + +c +#ifdef INCA_CH4 + CALL caladvtrac(q,pbaru,pbarv, + * p, masse, dq, teta, + . flxw, + . pk, + . mmt_adj, + . hadv_flg) +#else + CALL caladvtrac(q,pbaru,pbarv, + * p, masse, dq, teta, + . pk) +#endif + + IF (offline) THEN +Cmaf stokage du flux de masse pour traceurs OFF-LINE + +#ifdef CPP_IOIPSL +c CALL fluxstokenc(pbaru,pbarv,masse,teta,phi,phis, +c . time_step, itau) +#endif + + + ENDIF +c + ENDIF + + +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 + + +c rajout debug +c lafin = .true. + + +c Inbterface avec les routines de phylmd (phymars ... ) +c ----------------------------------------------------- + +#ifdef CPP_PHYS +c+jld + +c Diagnostique de conservation de l'énergie : initialisation + IF (ip_ebil_dyn.ge.1 ) THEN + ztit='bil dyn' + CALL diagedyn(ztit,2,1,1,dtphys + e , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) + ENDIF +c-jld + + CALL calfis( nq, lafin ,rdayvrai,time , + $ ucov,vcov,teta,q,masse,ps,p,pk,phis,phi , + $ du,dv,dteta,dq,w, +#ifdef INCA_CH4 + $ flxw, +#endif + $ clesphy0, dufi,dvfi,dtetafi,dqfi,dpfi ) + +c ajout des tendances physiques: +c ------------------------------ + CALL addfi( nqmx, 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' + CALL diagedyn(ztit,2,1,1,dtphys + e , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) + ENDIF +#else + +c Calcul academique de la physique = Rappel Newtonien + fritcion +c -------------------------------------------------------------- + teta(:,:)=teta(:,:) + s -iphysiq*dtvr*(teta(:,:)-tetarappel(:,:))/taurappel + call friction(ucov,vcov,iphysiq*dtvr) + +#endif + +c-jld + ENDIF + + 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 + +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 + 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 write(79,*) 'ucov',ucov +c write(80,*) 'vcov',vcov +c write(81,*) 'teta',teta +c write(82,*) 'ps',ps +c write(83,*) 'q',q +c WRITE(85,*) 'q1 = ',q(:,:,1) +c WRITE(86,*) 'q3 = ',q(:,:,3) + + 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 +#ifdef CPP_IOIPSL + CALL writedynav(histaveid, nqmx, 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 + + 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, nqmx,itau,vcov, +c s ucov,teta,phi,q,masse,ps,phis) +#else +#include "write_grads_dyn.h" +#endif + + + ENDIF + + IF(itau.EQ.itaufin) THEN + + +#ifdef CPP_IOIPSL + CALL dynredem1("restart.nc",0.0, + , vcov,ucov,teta,q,nqmx,masse,ps) +#endif + + CLOSE(99) + ENDIF + +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 + + ELSE + +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 + abort_message = 'Simulation finished' + call abort_gcm(modname,abort_message,0) + ENDIF + GO TO 2 + + ELSE + + 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 + CALL writedynav(histaveid, nqmx, 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 + + ENDIF + + 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, nqmx, itau,vcov , +c , ucov,teta,phi,q,masse,ps,phis) +#else +#include "write_grads_dyn.h" +#endif + + + ENDIF + +#ifdef CPP_IOIPSL + IF(itau.EQ.itaufin) + . CALL dynredem1("restart.nc",0.0, + . vcov,ucov,teta,q,nqmx,masse,ps) +#endif + + forward = .TRUE. + GO TO 1 + + ENDIF + + END IF + + STOP + END Index: /LMDZ4/trunk/libf/dyn3d/limit_netcdf.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/limit_netcdf.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/limit_netcdf.F (revision 524) @@ -0,0 +1,1279 @@ +! +! $Header$ +! +C +C + SUBROUTINE limit_netcdf(interbar, extrap, oldice, masque, pctsrf) +c + 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" +#include "dimphy.h" +#include "indicesol.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 pctsrf(klon,nbsrf) + 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 +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 + print *, NF_STRERROR(ierr) + STOP + 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 +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 + print *, NF_STRERROR(ierr) + STOP + 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 +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 +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 + ierr = NF_DEF_VAR (nid, "TEMPS", NF_FLOAT, 1,ntim, id_tim) + ierr = NF_PUT_ATT_TEXT (nid, id_tim, "title", 17, + . "Jour dans l annee") + IF (newlmt) THEN +c + ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 2,dims, id_FOCE) + ierr = NF_PUT_ATT_TEXT (nid, id_FOCE, "title", 14, + . "Fraction ocean") +c + ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 2,dims, id_FSIC) + ierr = NF_PUT_ATT_TEXT (nid, id_FSIC, "title", 21, + . "Fraction glace de mer") +c + ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 2,dims, id_FTER) + ierr = NF_PUT_ATT_TEXT (nid, id_FTER, "title", 14, + . "Fraction terre") +c + ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 2,dims, id_FLIC) + ierr = NF_PUT_ATT_TEXT (nid, id_FLIC, "title", 17, + . "Fraction land ice") +c + ELSE + ierr = NF_DEF_VAR (nid, "NAT", NF_FLOAT, 2,dims, id_NAT) + ierr = NF_PUT_ATT_TEXT (nid, id_NAT, "title", 23, + . "Nature du sol (0,1,2,3)") + ENDIF + ierr = NF_DEF_VAR (nid, "SST", NF_FLOAT, 2,dims, id_SST) + ierr = NF_PUT_ATT_TEXT (nid, id_SST, "title", 35, + . "Temperature superficielle de la mer") + ierr = NF_DEF_VAR (nid, "BILS", NF_FLOAT, 2,dims, id_BILS) + ierr = NF_PUT_ATT_TEXT (nid, id_BILS, "title", 32, + . "Reference flux de chaleur au sol") + ierr = NF_DEF_VAR (nid, "ALB", NF_FLOAT, 2,dims, id_ALB) + ierr = NF_PUT_ATT_TEXT (nid, id_ALB, "title", 19, + . "Albedo a la surface") + ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG) + 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 + STOP + END Index: /LMDZ4/trunk/libf/dyn3d/limx.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/limx.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/limx.F (revision 524) @@ -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/trunk/libf/dyn3d/limy.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/limy.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/limy.F (revision 524) @@ -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/trunk/libf/dyn3d/limz.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/limz.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/limz.F (revision 524) @@ -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/trunk/libf/dyn3d/logic.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/logic.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/logic.h (revision 524) @@ -0,0 +1,18 @@ +! +! $Header$ +! +c +c +c----------------------------------------------------------------------- +c INCLUDE 'logic.h' + + COMMON/logic/ purmats,iflag_phys,forward,leapf,apphys, + . statcl,conser,apdiss,apdelq,saison,ecripar,fxyhypb,ysinus + . ,read_start,ok_guide + + LOGICAL purmats,forward,leapf,apphys,statcl,conser, + . apdiss,apdelq,saison,ecripar,fxyhypb,ysinus + . ,read_start,ok_guide + + INTEGER iflag_phys +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/dyn3d/massbar.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/massbar.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/massbar.F (revision 524) @@ -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/trunk/libf/dyn3d/massbarxy.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/massbarxy.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/massbarxy.F (revision 524) @@ -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/trunk/libf/dyn3d/massdair.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/massdair.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/massdair.F (revision 524) @@ -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/trunk/libf/dyn3d/minmax.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/minmax.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/minmax.F (revision 524) @@ -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/trunk/libf/dyn3d/minmax2.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/minmax2.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/minmax2.F (revision 524) @@ -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/trunk/libf/dyn3d/nxgrad.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/nxgrad.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/nxgrad.F (revision 524) @@ -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/trunk/libf/dyn3d/nxgrad_gam.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/nxgrad_gam.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/nxgrad_gam.F (revision 524) @@ -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/trunk/libf/dyn3d/nxgradst.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/nxgradst.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/nxgradst.F (revision 524) @@ -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/trunk/libf/dyn3d/nxgraro2.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/nxgraro2.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/nxgraro2.F (revision 524) @@ -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/trunk/libf/dyn3d/nxgrarot.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/nxgrarot.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/nxgrarot.F (revision 524) @@ -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/trunk/libf/dyn3d/ord_coord.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/ord_coord.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/ord_coord.F (revision 524) @@ -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/trunk/libf/dyn3d/ord_coordm.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/ord_coordm.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/ord_coordm.F (revision 524) @@ -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/trunk/libf/dyn3d/paramet.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/paramet.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/paramet.h (revision 524) @@ -0,0 +1,22 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c 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 + s ,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 ) + +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/dyn3d/pbar.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/pbar.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/pbar.F (revision 524) @@ -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/trunk/libf/dyn3d/pentes_ini.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/pentes_ini.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/pentes_ini.F (revision 524) @@ -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/trunk/libf/dyn3d/ppm3d.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/ppm3d.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/ppm3d.F (revision 524) @@ -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,JMP,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/trunk/libf/dyn3d/prather.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/prather.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/prather.F (revision 524) @@ -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/trunk/libf/dyn3d/pres2lev.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/pres2lev.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/pres2lev.F (revision 524) @@ -0,0 +1,79 @@ +! +! $Header$ +! +c****************************************************** + SUBROUTINE pres2lev(varo,varn,lmo,lmn,po,pn, + % ni,nj) +c +c interpolation lineaire pour passer +c a une nouvelle discretisation verticale pour +c les variables de GCM +c Francois Forget (01/1995) +c +c MOdif remy roca 12/97 pour passer de pres2sig +c********************************************************** + + IMPLICIT NONE + +c Declarations: +c ============== +c +c ARGUMENTS +c """"""""" + + INTEGER lmo ! dimensions ancienne couches (input) + INTEGER lmn ! dimensions nouvelle couches (input) + INTEGER lmomx ! dimensions ancienne couches (input) + INTEGER lmnmx ! dimensions nouvelle couches (input) + + parameter(lmomx=10000,lmnmx=10000) + + real po(lmo)! niveau de pression en millibars + real pn(ni,nj,lmn) ! niveau de pression en pascals + + INTEGER i,j,Nhoriz,ni,nj ! nombre de point horizontale (input) + + REAL varo(ni,nj,lmo) ! var dans l'ancienne grille (input) + REAL varn(ni,nj,lmn) ! var dans la nouvelle grille (output) + + real zvaro(lmomx),zpo(lmomx) + +c Autres variables +c """""""""""""""" + INTEGER n, ln ,lo + REAL coef + +c run +c ==== + do i=1,ni + do j=1,nj +c a chaque point de grille correspond un nouveau sigma old +c qui vaut pres(l)/ps(i,j) + do lo=1,lmo + zpo(lo)=po(lmo+1-lo) + zvaro(lo)=varo(i,j,lmo+1-lo) + enddo + + 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/trunk/libf/dyn3d/pression.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/pression.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/pression.F (revision 524) @@ -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/trunk/libf/dyn3d/profvert.def =================================================================== --- /LMDZ4/trunk/libf/dyn3d/profvert.def (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/profvert.def (revision 524) @@ -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/trunk/libf/dyn3d/psextbar.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/psextbar.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/psextbar.F (revision 524) @@ -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/trunk/libf/dyn3d/q_sat.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/q_sat.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/q_sat.F (revision 524) @@ -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/trunk/libf/dyn3d/qminimum.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/qminimum.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/qminimum.F (revision 524) @@ -0,0 +1,85 @@ +! +! $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 + zx_defau = AMAX1( seuil_liq - q(i,k,iq_liq), 0.0 ) + q(i,k,iq_vap) = q(i,k,iq_vap) - zx_defau + q(i,k,iq_liq) = q(i,k,iq_liq) + zx_defau + 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 + zx_abc = deltap(i,k)/deltap(i,k-1) + zx_defau = AMAX1( seuil_vap - q(i,k,iq), 0.0 ) + q(i,k-1,iq) = q(i,k-1,iq) - zx_defau * zx_abc + q(i,k,iq) = q(i,k,iq) + zx_defau + 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/trunk/libf/dyn3d/ran1.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/ran1.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/ran1.F (revision 524) @@ -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/trunk/libf/dyn3d/read_reanalyse.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/read_reanalyse.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/read_reanalyse.F (revision 524) @@ -0,0 +1,531 @@ +! +! $Header$ +! +c +c + subroutine read_reanalyse(timestep,psi + s ,u,v,t,q,masse,ps,mode,nlevnc) + +c mode=0 variables naturelles +c mode=1 variabels GCM + +c ----------------------------------------------------------------- +c Declarations +c ----------------------------------------------------------------- + IMPLICIT NONE + +c common +c ------ + +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comvert.h" +#include "guide.h" + + +c arguments +c --------- + integer nlevnc + integer timestep,mode,l + + real psi(iip1,jjp1) + real u(iip1,jjp1,llm),v(iip1,jjm,llm) + real t(iip1,jjp1,llm),ps(iip1,jjp1),q(iip1,jjp1,llm) + real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm) + + +c local +c ----- + integer ncidu,varidu,ncidv,varidv,ncidt,varidt,ncidps,varidps + integer ncidpl + integer varidpl,ncidQ,varidQ + save ncidu,varidu,ncidv,varidv,ncidt,varidt,ncidps,varidps + save varidpl,ncidQ,varidQ + + real*4 unc(iip1,jjp1,nlevnc),vnc(iip1,jjm,nlevnc) + real*4 tnc(iip1,jjp1,nlevnc),psnc(iip1,jjp1) + real*4 Qnc(iip1,jjp1,nlevnc) + real*4 pl(nlevnc),presnc(iip1,jjp1,nlevnc) + + 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 (first) then + ncidpl=-99 + print*,'Intitialisation de read reanalsye' + +c Vent zonal + if (guide_u) then + ncidu=NCOPN('u.nc',NCNOWRIT,rcode) + varidu=NCVID(ncidu,'UWND',rcode) + print*,'ncidu,varidu',ncidu,varidu + if (ncidpl.eq.-99) ncidpl=ncidu + endif + +c Vent meridien + if (guide_v) then + ncidv=NCOPN('v.nc',NCNOWRIT,rcode) + varidv=NCVID(ncidv,'VWND',rcode) + print*,'ncidv,varidv',ncidv,varidv + if (ncidpl.eq.-99) ncidpl=ncidu + endif + +c Temperature + if (guide_T) then + ncidt=NCOPN('T.nc',NCNOWRIT,rcode) + varidt=NCVID(ncidt,'AIR',rcode) + print*,'ncidt,varidt',ncidt,varidt + if (ncidpl.eq.-99) ncidpl=ncidu + endif + +c Humidite + if (guide_Q) then + ncidQ=NCOPN('hur.nc',NCNOWRIT,rcode) + varidQ=NCVID(ncidQ,'RH',rcode) + print*,'ncidQ,varidQ',ncidQ,varidQ + if (ncidpl.eq.-99) ncidpl=ncidu + endif + +c Pression de surface + if (guide_P) then + ncidps=NCOPN('ps.nc',NCNOWRIT,rcode) + varidps=NCVID(ncidps,'SP',rcode) + print*,'ncidps,varidps',ncidps,varidps + endif + +c Coordonnee vertcale + if (ncep) then + print*,'Vous etes entrain de lire des donnees NCEP' + varidpl=NCVID(ncidpl,'LEVEL',rcode) + else + print*,'Vous etes entrain de lire des donnees ECMWF' + varidpl=NCVID(ncidpl,'PRESSURE',rcode) + endif + print*,'ncidu,varidpl',ncidu,varidpl + + endif + + print*,'ok1' + +c ----------------------------------------------------------------- +c lecture des champs u, v, T, ps +c ----------------------------------------------------------------- + +c niveaux de pression +c ------------------- + + print*,'WARNING!!! Il n y a pas de test de coherence' + print*,'sur le nombre de niveaux verticaux dans le fichier nc' +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,pl) +#else + status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,pl) +#endif +c passage en pascal + pl(:)=100.*pl(:) +c passage des presions sur une grille 3D + do l=1,nlevnc + presnc(:,:,l)=pl(l) + enddo + if(first) then + do l=1,nlevnc + print*,'PL(',l,')=',pl(l) + enddo + endif + + +c dimensions pour les champs scalaires et le vent zonal +c ----------------------------------------------------- + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=timestep + + count(1)=iip1 + count(2)=jjp1 + count(3)=nlevnc + count(4)=1 + +c Vent zonal +c ---------- + + if (guide_u) then + print*,'avant la lecture de UNCEP nd de niv:',nlevnc +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,unc) +#else + status=NF_GET_VARA_REAL(ncidu,varidu,start,count,unc) +#endif +c call dump2d(iip1,jjp1,unc,'VENT NCEP ') +c call dump2d(iip1,40,unc(1,1,nlevnc),'VENT NCEP ') + print*,'WARNING!!! Correction bidon pour palier a un ' + print*,'probleme dans la creation des fichiers nc' + call correctbid(iim,jjp1*nlevnc,unc) + call dump2d(iip1,jjp1,unc,'UNC COUCHE 1 ') + endif + +c Temperature +c ----------- + + print*,'ncidt=',ncidt,'varidt=',varidt,'start=',start + print*,'count=',count + if (guide_T) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,tnc) +#else + status=NF_GET_VARA_REAL(ncidt,varidt,start,count,tnc) +#endif + call dump2d(iip1,jjp1,tnc,'TNC COUCHE 1 AAA ') + call correctbid(iim,jjp1*nlevnc,tnc) + call dump2d(iip1,jjp1,tnc,'TNC COUCHE 1 BBB ') + endif + +c Humidite +c -------- + + if (guide_Q) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,Qnc) +#else + status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,Qnc) +#endif + call correctbid(iim,jjp1*nlevnc,Qnc) + call dump2d(iip1,jjp1,Qnc,'QNC COUCHE 1 ') + endif + + count(2)=jjm +c Vent meridien +c ------------- + + if (guide_v) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,vnc) +#else + status=NF_GET_VARA_REAL(ncidv,varidv,start,count,vnc) +#endif + call correctbid(iim,jjm*nlevnc,vnc) + call dump2d(iip1,jjm,vnc,'VNC COUCHE 1 ') + endif + + start(3)=timestep + start(4)=0 + count(2)=jjp1 + count(3)=1 + count(4)=0 + +c Pression de surface +c ------------------- + + if (guide_P) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,psnc) +#else + status=NF_GET_VARA_REAL(ncidps,varidps,start,count,psnc) +#endif + call dump2d(iip1,jjp1,psnc,'PSNC COUCHE 1 ') + call correctbid(iim,jjp1,psnc) + endif + + + +c ----------------------------------------------------------------- +c Interpollation verticale sur les niveaux modele +c ----------------------------------------------------------------- + call reanalyse2nat(nlevnc,psi,unc,vnc,tnc,Qnc,psnc,pl,u,v,t,Q + s ,ps,masse,pk) + + call dump2d(iip1,jjm,v,'V COUCHE APRES ') + + +c ----------------------------------------------------------------- +c Passage aux variables du modele (vents covariants, temperature +c potentielle et humidite specifique) +c ----------------------------------------------------------------- + call nat2gcm(u,v,t,Q,pk,u,v,t,Q) + print*,'TIMESTEP ',timestep + if(mode.ne.1) stop'mode pas egal 0' +c call dump2d(iip1,jjm,v,'VCOV COUCHE 1 ') + +c Lignes introduites a une epoque pour un probleme oublie... +c do l=1,llm +c do i=1,iip1 +c v(i,1,l)=0. +c v(i,jjm,l)=0. +c enddo +c enddo + first=.false. + + return + end + + +c=========================================================================== + subroutine reanalyse2nat(nlevnc,psi + s ,unc,vnc,tnc,qnc,psnc,pl,u,v,t,q + s ,ps,masse,pk) +c=========================================================================== + +c ----------------------------------------------------------------- +c Inversion Nord/sud de la grille + interpollation sur les niveaux +c verticaux du modele. +c ----------------------------------------------------------------- + + implicit none + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comvert.h" +#include "comconst.h" +#include "guide.h" + + integer nlevnc + real psi(iip1,jjp1) + real u(iip1,jjp1,llm),v(iip1,jjm,llm) + real t(iip1,jjp1,llm),ps(iip1,jjp1),q(iip1,jjp1,llm) + + real pl(nlevnc) + real unc(iip1,jjp1,nlevnc),vnc(iip1,jjm,nlevnc) + real tnc(iip1,jjp1,nlevnc),psnc(iip1,jjp1) + real qnc(iip1,jjp1,nlevnc) + + real zu(iip1,jjp1,llm),zv(iip1,jjm,llm) + real zt(iip1,jjp1,llm),zq(iip1,jjp1,llm) + + real pext(iip1,jjp1,llm) + real pbarx(iip1,jjp1,llm),pbary(iip1,jjm,llm) + real plunc(iip1,jjp1,llm),plvnc(iip1,jjm,llm) + real plsnc(iip1,jjp1,llm) + + REAL alpha(iip1,jjp1,llm),beta(iip1,jjp1,llm) + real p(iip1,jjp1,llmp1),pk(iip1,jjp1,llm),pks(iip1,jjp1) + real pkf(iip1,jjp1,llm) + real masse(iip1,jjp1,llm),pls(iip1,jjp1,llm) + real prefkap,unskap + + + integer i,j,l + + +c ----------------------------------------------------------------- +c calcul de la pression au milieu des couches. +c ----------------------------------------------------------------- + + CALL pression( ip1jmp1, ap, bp, psi, p ) + call massdair(p,masse) + CALL exner_hyb(ip1jmp1,psi,p,alpha,beta,pks,pk,pkf) + +c .... Calcul de pls , pression au milieu des couches ,en Pascals + unskap=1./kappa + prefkap = preff ** kappa +c PRINT *,' Pref kappa unskap ',preff,kappa,unskap + 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 + + +c ----------------------------------------------------------------- +c calcul des pressions pour les grilles u et v +c ----------------------------------------------------------------- + + 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,jjp1+1-j,l)=pbarx(i,j,l)/aireu(i,j) + plsnc(i,jjp1+1-j,l)=pls(i,j,l) + enddo + enddo + enddo + do l=1,llm + do j=1,jjm + do i=1,iip1 + plvnc(i,jjm+1-j,l)=pbary(i,j,l)/airev(i,j) + enddo + enddo + enddo + +c ----------------------------------------------------------------- + + if (guide_P) then + do j=1,jjp1 + do i=1,iim + ps(i,j)=psnc(i,jjp1+1-j) + enddo + ps(iip1,j)=ps(1,j) + enddo + endif + + +c ----------------------------------------------------------------- + call pres2lev(unc,zu,nlevnc,llm,pl,plunc,iip1,jjp1) + call pres2lev(vnc,zv,nlevnc,llm,pl,plvnc,iip1,jjm ) + call pres2lev(tnc,zt,nlevnc,llm,pl,plsnc,iip1,jjp1) + call pres2lev(qnc,zq,nlevnc,llm,pl,plsnc,iip1,jjp1) + +c call dump2d(iip1,jjp1,ps,'PS ') +c call dump2d(iip1,jjp1,psu,'PS ') +c call dump2d(iip1,jjm,psv,'PS ') +c Inversion Nord/Sud + do l=1,llm + do j=1,jjp1 + do i=1,iim + u(i,j,l)=zu(i,jjp1+1-j,l) + t(i,j,l)=zt(i,jjp1+1-j,l) + q(i,j,l)=zq(i,jjp1+1-j,l) + enddo + u(iip1,j,l)=u(1,j,l) + t(iip1,j,l)=t(1,j,l) + q(iip1,j,l)=q(1,j,l) + enddo + enddo + + do l=1,llm + do j=1,jjm + do i=1,iim + v(i,j,l)=zv(i,jjm+1-j,l) + enddo + v(iip1,j,l)=v(1,j,l) + enddo + enddo + + return + end + +c=========================================================================== + subroutine nat2gcm(u,v,t,rh,pk,ucov,vcov,teta,q) +c=========================================================================== + + implicit none + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comconst.h" +#include "comvert.h" +#include "guide.h" + + real u(iip1,jjp1,llm),v(iip1,jjm,llm) + real t(iip1,jjp1,llm),pk(iip1,jjp1,llm),rh(iip1,jjp1,llm) + real ps(iip1,jjp1) + + real ucov(iip1,jjp1,llm),vcov(iip1,jjm,llm) + real teta(iip1,jjp1,llm),q(iip1,jjp1,llm) + + real pres(iip1,jjp1,llm),qsat(iip1,jjp1,llm) + + real unskap + + integer i,j,l + + + print*,'Entree dans nat2gcm' +c ucov(:,:,:)=0. +c do l=1,llm +c ucov(:,2:jjm,l)=u(:,2:jjm,l)*cu(:,2:jjm) +c enddo +c ucov(iip1,:,:)=ucov(1,:,:) + +c teta(:,:,:)=t(:,:,:)*cpp/pk(:,:,:) +c teta(iip1,:,:)=teta(1,:,:) + +c calcul de ucov et de la temperature potentielle + do l=1,llm + do j=1,jjp1 + do i=1,iim + ucov(i,j,l)=u(i,j,l)*cu(i,j) + teta(i,j,l)=t(i,j,l)*cpp/pk(i,j,l) + enddo + ucov(iip1,j,l)=ucov(1,j,l) + teta(iip1,j,l)=teta(1,j,l) + enddo + do i=1,iip1 + ucov(i,1,l)=0. + ucov(i,jjp1,l)=0. + teta(i,1,l)=teta(1,1,l) + teta(i,jjp1,l)=teta(1,jjp1,l) + enddo + enddo + +c calcul de ucov + do l=1,llm + do j=1,jjm + do i=1,iim + vcov(i,j,l)=v(i,j,l)*cv(i,j) + enddo + vcov(iip1,j,l)=vcov(1,j,l) + enddo + enddo + +c call dump2d(iip1,jjp1,teta,'TETA EN BAS ') +c call dump2d(iip1,jjp1,teta(1,1,llm),'TETA EN HAUT ') + +c Humidite relative -> specifique +c ------------------------------- + if (1.eq.0) then +c FINALEMENT ON GUIDE EN HUMIDITE RELATIVE + print*,'calcul de unskap' + unskap = 1./ kappa + print*,'calcul de pres' + pres(:,:,:)=preff*(pk(:,:,:)/cpp)**unskap + print*,'calcul de qsat' + call q_sat(iip1*jjp1*llm,t,pres,qsat) + print*,'calcul de q' +c ATTENTION : humidites relatives en % + rh(:,:,:)=max(rh(:,:,:)*0.01,1.e-6) + q(:,:,:)=qsat(:,:,:)*rh(:,:,:) + print*,'calcul de q OK' + + call dump2d(iip1,jjp1,pres,'PRESSION PREMIERE COUCHE ') + call dump2d(iip1,jjp1,q,'HUMIDITE SPECIFIQUE COUCHE 1 ') + endif + + + return + end + + + +c=========================================================================== + subroutine correctbid(iim,nl,x) +c=========================================================================== + 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)) +c print*,'correction ',i,l,x(i,l),zz + x(i,l)=zz + endif + enddo + enddo + return + end Index: /LMDZ4/trunk/libf/dyn3d/rotat.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/rotat.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/rotat.F (revision 524) @@ -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/trunk/libf/dyn3d/rotat_nfil.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/rotat_nfil.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/rotat_nfil.F (revision 524) @@ -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/trunk/libf/dyn3d/rotatf.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/rotatf.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/rotatf.F (revision 524) @@ -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/trunk/libf/dyn3d/rotatst.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/rotatst.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/rotatst.F (revision 524) @@ -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/trunk/libf/dyn3d/serre.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/serre.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/serre.h (revision 524) @@ -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/trunk/libf/dyn3d/sort.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/sort.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/sort.F (revision 524) @@ -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/trunk/libf/dyn3d/sortvarc.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/sortvarc.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/sortvarc.F (revision 524) @@ -0,0 +1,165 @@ +! +! $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 ) + + rday = FLOAT(INT ( day_ini + time )) +c + 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('0'10(1h*),4x,'pas'i7,5x,'jour'f5.0,'heure'f5.1,4x + * ,'date',f10.5,4x,10(1h*)) +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/trunk/libf/dyn3d/sortvarc0.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/sortvarc0.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/sortvarc0.F (revision 524) @@ -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 ( day_ini + time )) +c + PRINT 3500, itau, rday, heure, time + PRINT *, ptot0,etot0,ztot0,stot0,ang0 + +3500 FORMAT('0',10(1h*),4x,'pas',i7,5x,'jour',f5.0,'heure',f5.1,4x + * ,'date',f10.5,4x,10(1h*)) + RETURN + END + Index: /LMDZ4/trunk/libf/dyn3d/spline.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/spline.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/spline.F (revision 524) @@ -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/trunk/libf/dyn3d/splint.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/splint.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/splint.F (revision 524) @@ -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/trunk/libf/dyn3d/startvar.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/startvar.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/startvar.F (revision 524) @@ -0,0 +1,1178 @@ +! +! $Header$ +! +C +C + MODULE startvar + ! + ! + ! 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 + CASE ('deltat') + 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 + ! + REAL :: lev(1), date, dt + INTEGER :: itau(1) + INTEGER :: llm_tmp, ttm_tmp + INTEGER :: i, j + INTEGER :: iret + ! + 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)) + ! + CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, + . llm_tmp, lon_phys, lat_phys, lev, ttm_tmp, + . itau, date, dt, fid_phys) + ! + ! 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 + ! + if (allocated(lon_rad)) DEALLOCATE(lon_rad, stat=iret) + if (allocated(lon_ini)) DEALLOCATE(lon_ini, stat=iret) + + 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(lat_rad) + DEALLOCATE(var_tmp2d) + DEALLOCATE(var_tmp3d) + DEALLOCATE(ax) + DEALLOCATE(ay) + DEALLOCATE(yder) + DEALLOCATE(lind) + + ! + RETURN + ! + END SUBROUTINE start_inter_3d + ! + END MODULE startvar Index: /LMDZ4/trunk/libf/dyn3d/temps.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/temps.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/temps.h (revision 524) @@ -0,0 +1,16 @@ +! +! $Header$ +! +! +!----------------------------------------------------------------------- +! INCLUDE 'temps.h' + + COMMON/temps/itaufin, dt, day_ini, day_end, annee_ref, day_ref, + . itau_dyn, itau_phy + + INTEGER itaufin + INTEGER*4 itau_dyn, itau_phy + INTEGER*4 day_ini, day_end, annee_ref, day_ref + REAL dt + +!----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/dyn3d/temps.inc =================================================================== --- /LMDZ4/trunk/libf/dyn3d/temps.inc (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/temps.inc (revision 524) @@ -0,0 +1,17 @@ +! +! $Header$ +! +! +! +!----------------------------------------------------------------------- +! INCLUDE 'temps.h' + + COMMON/temps/itaufin, dt, & + & day_ini, day_end, annee_ref, day_ref, itau_dyn, itau_phy + + INTEGER itaufin + INTEGER*4 itau_dyn, itau_phy + INTEGER*4 day_ini, day_end, annee_ref, day_ref + REAL dt + +!----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/dyn3d/test_period.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/test_period.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/test_period.F (revision 524) @@ -0,0 +1,114 @@ +! +! $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 +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,nqmx), 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, nqmx + 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/trunk/libf/dyn3d/tourpot.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/tourpot.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/tourpot.F (revision 524) @@ -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/trunk/libf/dyn3d/traceurpole.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/traceurpole.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/traceurpole.F (revision 524) @@ -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/trunk/libf/dyn3d/tracstoke.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/tracstoke.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/tracstoke.h (revision 524) @@ -0,0 +1,5 @@ +! +! $Header$ +! + common /tracstoke/istdyn,istphy,unittrac + integer istdyn,istphy,unittrac Index: /LMDZ4/trunk/libf/dyn3d/ugeostr.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/ugeostr.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/ugeostr.F (revision 524) @@ -0,0 +1,67 @@ +! +! $Header$ +! + 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 + + 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(jjp1,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/trunk/libf/dyn3d/vitvert.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/vitvert.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/vitvert.F (revision 524) @@ -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/trunk/libf/dyn3d/vlsplt.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/vlsplt.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/vlsplt.F (revision 524) @@ -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.1) 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/trunk/libf/dyn3d/vlspltqs.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/vlspltqs.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/vlspltqs.F (revision 524) @@ -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.1) 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/trunk/libf/dyn3d/wrgrads.F =================================================================== --- /LMDZ4/trunk/libf/dyn3d/wrgrads.F (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/wrgrads.F (revision 524) @@ -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. + +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 + 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 + +c print*,'ivar(if),nvar(if),var(ivar(if),if),writectl' +c 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/trunk/libf/dyn3d/write_grads_dyn.h =================================================================== --- /LMDZ4/trunk/libf/dyn3d/write_grads_dyn.h (revision 524) +++ /LMDZ4/trunk/libf/dyn3d/write_grads_dyn.h (revision 524) @@ -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,nqmx + string10='q' + write(string10(2:2),'(i1)') iq + CALL wrgrads(1,llm,q(:,:,iq),string10,string10) + enddo + Index: /LMDZ4/trunk/libf/filtrez/acc.F =================================================================== --- /LMDZ4/trunk/libf/filtrez/acc.F (revision 524) +++ /LMDZ4/trunk/libf/filtrez/acc.F (revision 524) @@ -0,0 +1,14 @@ +! +! $Header$ +! + subroutine acc(vec,d,im) + dimension vec(im,im),d(im) + do 10 j=1,im + do 9 i=1,im + 9 d(i)=vec(i,j)*vec(i,j) + sum=ssum(im,d,1) + sum=sqrt(sum) + do 10 i=1,im + 10 vec(i,j)=vec(i,j)/sum + return + end Index: /LMDZ4/trunk/libf/filtrez/coefils.h =================================================================== --- /LMDZ4/trunk/libf/filtrez/coefils.h (revision 524) +++ /LMDZ4/trunk/libf/filtrez/coefils.h (revision 524) @@ -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/trunk/libf/filtrez/eigen.F =================================================================== --- /LMDZ4/trunk/libf/filtrez/eigen.F (revision 524) +++ /LMDZ4/trunk/libf/filtrez/eigen.F (revision 524) @@ -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/trunk/libf/filtrez/eigen_sort.F =================================================================== --- /LMDZ4/trunk/libf/filtrez/eigen_sort.F (revision 524) +++ /LMDZ4/trunk/libf/filtrez/eigen_sort.F (revision 524) @@ -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/trunk/libf/filtrez/filtreg.F =================================================================== --- /LMDZ4/trunk/libf/filtrez/filtreg.F (revision 524) +++ /LMDZ4/trunk/libf/filtrez/filtreg.F (revision 524) @@ -0,0 +1,300 @@ +! +! $Header$ +! + SUBROUTINE filtreg ( champ, nlat, nbniv, ifiltre,iaire, + . griscal ,iter) + + 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 "parafilt.h" +#include "coefils.h" +c + 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 matriceun,matriceus,matricevn,matricevs,matrinvn,matrinvs + COMMON/matrfil/matriceun(iim,iim,nfilun),matriceus(iim,iim,nfilus) + , , matricevn(iim,iim,nfilvn),matricevs(iim,iim,nfilvs) + , , matrinvn(iim,iim,nfilun),matrinvs (iim,iim,nfilus) + REAL eignq(iim), sdd1(iim),sdd2(iim) + LOGICAL griscal + INTEGER hemisph, iaire +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 + CALL SCOPY( iim, sddv, 1, sdd1, 1 ) + CALL SCOPY( iim, unsddv, 1, sdd2, 1 ) + ELSE + CALL SCOPY( iim, unsddv, 1, sdd1, 1 ) + CALL SCOPY( iim, sddv, 1, sdd2, 1 ) + END IF +c + jdfil1 = 2 + jffil1 = jfiltnu + jdfil2 = jfiltsu + jffil2 = jjm + END IF + ELSE + IF( nlat.NE.jjm ) THEN + PRINT 2222 + STOP + ELSE +c + IF( iaire.EQ.1 ) THEN + CALL SCOPY( iim, sddu, 1, sdd1, 1 ) + CALL SCOPY( iim, unsddu, 1, sdd2, 1 ) + ELSE + CALL SCOPY( iim, unsddu, 1, sdd1, 1 ) + CALL SCOPY( iim, sddu, 1, sdd2, 1 ) + END IF +c + jdfil1 = 1 + jffil1 = jfiltnv + jdfil2 = jfiltsv + jffil2 = jjm + END IF + END IF +c +c + DO 100 hemisph = 1, 2 +c + IF ( hemisph.EQ.1 ) THEN + jdfil = jdfil1 + jffil = jffil1 + ELSE + jdfil = jdfil2 + jffil = jffil2 + END IF + + + DO 50 l = 1, nbniv + DO 30 j = jdfil,jffil + + + DO 5 i = 1, iim + champ(i,j,l) = champ(i,j,l) * sdd1(i) + 5 CONTINUE +c + + IF( hemisph. EQ. 1 ) THEN + + IF( ifiltre. EQ. -2 ) THEN +#ifdef CRAY + CALL MXVA( matrinvn(1,1,j), 1, iim, champ(1,j,l), 1, eignq , + * 1, iim, iim ) +#else +#ifdef BLAS + CALL SGEMV("N", iim,iim, 1.0, matrinvn(1,1,j),iim, + . champ(1,j,l), 1, 0.0, eignq, 1) +#else + DO k = 1, iim + eignq(k) = 0.0 + ENDDO + DO k = 1, iim + DO i = 1, iim + eignq(k) = eignq(k) + matrinvn(k,i,j)*champ(i,j,l) + ENDDO + ENDDO +#endif +#endif + ELSE IF ( griscal ) THEN +#ifdef CRAY + CALL MXVA( matriceun(1,1,j), 1, iim, champ(1,j,l), 1, eignq , + * 1, iim, iim ) +#else +#ifdef BLAS + CALL SGEMV("N", iim,iim, 1.0, matriceun(1,1,j),iim, + . champ(1,j,l), 1, 0.0, eignq, 1) +#else + DO k = 1, iim + eignq(k) = 0.0 + ENDDO + DO i = 1, iim + DO k = 1, iim + eignq(k) = eignq(k) + matriceun(k,i,j)*champ(i,j,l) + ENDDO + ENDDO +#endif +#endif + ELSE +#ifdef CRAY + CALL MXVA( matricevn(1,1,j), 1, iim, champ(1,j,l), 1, eignq , + * 1, iim, iim ) +#else +#ifdef BLAS + CALL SGEMV("N", iim,iim, 1.0, matricevn(1,1,j),iim, + . champ(1,j,l), 1, 0.0, eignq, 1) +#else + DO k = 1, iim + eignq(k) = 0.0 + ENDDO + DO i = 1, iim + DO k = 1, iim + eignq(k) = eignq(k) + matricevn(k,i,j)*champ(i,j,l) + ENDDO + ENDDO +#endif +#endif + ENDIF + + ELSE + + IF( ifiltre. EQ. -2 ) THEN +#ifdef CRAY + CALL MXVA( matrinvs(1,1,j-jfiltsu+1), 1, iim, champ(1,j,l),1 , + * eignq, 1, iim, iim ) +#else +#ifdef BLAS + CALL SGEMV("N", iim,iim, 1.0, matrinvs(1,1,j-jfiltsu+1),iim, + . champ(1,j,l), 1, 0.0, eignq, 1) +#else + DO k = 1, iim + eignq(k) = 0.0 + ENDDO + DO i = 1, iim + DO k = 1, iim + eignq(k) = eignq(k) + matrinvs(k,i,j-jfiltsu+1)*champ(i,j,l) + ENDDO + ENDDO +#endif +#endif + ELSE IF ( griscal ) THEN +#ifdef CRAY + CALL MXVA( matriceus(1,1,j-jfiltsu+1), 1, iim, champ(1,j,l),1 , + * eignq, 1, iim, iim ) +#else +#ifdef BLAS + CALL SGEMV("N", iim,iim, 1.0, matriceus(1,1,j-jfiltsu+1),iim, + . champ(1,j,l), 1, 0.0, eignq, 1) +#else + DO k = 1, iim + eignq(k) = 0.0 + ENDDO + DO i = 1, iim + DO k = 1, iim + eignq(k) = eignq(k) + matriceus(k,i,j-jfiltsu+1)*champ(i,j,l) + ENDDO + ENDDO +#endif +#endif + ELSE +#ifdef CRAY + CALL MXVA( matricevs(1,1,j-jfiltsv+1), 1, iim, champ(1,j,l),1 , + * eignq, 1, iim, iim ) +#else +#ifdef BLAS + CALL SGEMV("N", iim,iim, 1.0, matricevs(1,1,j-jfiltsv+1),iim, + . champ(1,j,l), 1, 0.0, eignq, 1) +#else + DO k = 1, iim + eignq(k) = 0.0 + ENDDO + DO i = 1, iim + DO k = 1, iim + eignq(k) = eignq(k) + matricevs(k,i,j-jfiltsv+1)*champ(i,j,l) + ENDDO + ENDDO +#endif +#endif + ENDIF + + ENDIF +c + IF( ifiltre.EQ. 2 ) THEN + DO 15 i = 1, iim + champ( i,j,l ) = ( champ(i,j,l) + eignq(i) ) * sdd2(i) + 15 CONTINUE + ELSE + DO 16 i=1,iim + champ( i,j,l ) = ( champ(i,j,l) - eignq(i) ) * sdd2(i) +16 CONTINUE + ENDIF +c + champ( iip1,j,l ) = champ( 1,j,l ) +c + 30 CONTINUE +c + 50 CONTINUE +c + 100 CONTINUE +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'/) + RETURN + END Index: /LMDZ4/trunk/libf/filtrez/inifgn.F =================================================================== --- /LMDZ4/trunk/libf/filtrez/inifgn.F (revision 524) +++ /LMDZ4/trunk/libf/filtrez/inifgn.F (revision 524) @@ -0,0 +1,106 @@ +! +! $Header$ +! + 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/trunk/libf/filtrez/inifilr.F =================================================================== --- /LMDZ4/trunk/libf/filtrez/inifilr.F (revision 524) +++ /LMDZ4/trunk/libf/filtrez/inifilr.F (revision 524) @@ -0,0 +1,591 @@ +! +! $Header$ +! + SUBROUTINE inifilr +c +c ... H. Upadhyaya, O.Sharma ... +c + IMPLICIT NONE +c +c version 3 ..... + +c Correction le 28/10/97 P. Le Van . +c ------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "parafilt.h" +c ------------------------------------------------------------------- +#include "comgeom.h" +#include "coefils.h" +#include "logic.h" +#include "serre.h" + + REAL dlonu(iim),dlatu(jjm) + REAL rlamda( iim ), eignvl( iim ) +c + + REAL lamdamax,pi,cof + INTEGER i,j,modemax,imx,k,kf,ii + REAL dymin,dxmin,colat0 + REAL eignft(iim,iim), coff + REAL matriceun,matriceus,matricevn,matricevs,matrinvn,matrinvs + COMMON/matrfil/matriceun(iim,iim,nfilun),matriceus(iim,iim,nfilus) + , , matricevn(iim,iim,nfilvn),matricevs(iim,iim,nfilvs) + , , matrinvn(iim,iim,nfilun),matrinvs (iim,iim,nfilus) +#ifdef CRAY + INTEGER ISMIN + EXTERNAL ISMIN + INTEGER iymin + INTEGER ixmineq +#endif + EXTERNAL inifgn +c +c ------------------------------------------------------------ +c This routine computes the eigenfunctions of the laplacien +c on the stretched grid, and the filtering coefficients +c +c We designate: +c eignfn eigenfunctions of the discrete laplacien +c eigenvl eigenvalues +c jfiltn indexof the last scalar line filtered in NH +c jfilts index of the first line filtered in SH +c modfrst index of the mode from where modes are filtered +c modemax maximum number of modes ( im ) +c coefil filtering coefficients ( lamda_max*cos(rlat)/lamda ) +c sdd SQRT( dx ) +c +c the modes are filtered from modfrst to modemax +c +c----------------------------------------------------------- +c + + pi = 2. * ASIN( 1. ) + + DO i = 1,iim + dlonu(i) = xprimu( i ) + ENDDO +c + CALL inifgn(eignvl) +c + print *,' EIGNVL ' + PRINT 250,eignvl +250 FORMAT( 1x,5e13.6) +c +c compute eigenvalues and eigenfunctions +c +c +c................................................................. +c +c compute the filtering coefficients for scalar lines and +c meridional wind v-lines +c +c we filter all those latitude lines where coefil < 1 +c NO FILTERING AT POLES +c +c colat0 is to be used when alpha (stretching coefficient) +c is set equal to zero for the regular grid case +c +c ....... Calcul de colat0 ......... +c ..... colat0 = minimum de ( 0.5, min dy/ min dx ) ... +c +c + DO 45 j = 1,jjm + dlatu( j ) = rlatu( j ) - rlatu( j+1 ) + 45 CONTINUE +c +#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 +c +c + colat0 = MIN( 0.5, dymin/dxmin ) +c + IF( .NOT.fxyhypb.AND.ysinus ) THEN + colat0 = 0.6 +c ...... a revoir pour ysinus ! ....... + alphax = 0. + ENDIF +c + PRINT 50, colat0,alphax + 50 FORMAT(/15x,' Inifilr colat0 alphax ',2e16.7) +c + IF(alphax.EQ.1. ) THEN + PRINT *,' Inifilr alphax doit etre < a 1. Corriger ' + STOP + ENDIF +c + lamdamax = iim / ( pi * colat0 * ( 1. - alphax ) ) + +cc ... Correction le 28/10/97 ( P.Le Van ) .. +c + DO 71 i = 2,iim + rlamda( i ) = lamdamax/ SQRT( ABS( eignvl(i) ) ) + 71 CONTINUE +c + + DO 72 j = 1,jjm + DO 73 i = 1,iim + coefilu( i,j ) = 0.0 + coefilv( i,j ) = 0.0 + coefilu2( i,j ) = 0.0 + coefilv2( i,j ) = 0.0 + 73 CONTINUE + 72 CONTINUE + +c +c ... Determination de jfiltnu,jfiltnv,jfiltsu,jfiltsv .... +c ......................................................... +c + modemax = iim + +cccc imx = modemax - 4 * (modemax/iim) + + imx = iim +c + PRINT *,' TRUNCATION AT ',imx +c + DO 75 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 + 75 CONTINUE +c + DO 76 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 + 76 CONTINUE +c + + 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 + +c +c ... Determination de coefilu,coefilv,n=modfrstu,modfrstv .... +c................................................................ +c +c + DO 77 j = 1,jjm + modfrstu( j ) = iim + modfrstv( j ) = iim + 77 CONTINUE +c + DO 84 j = 2,jfiltnu + DO 81 k = 2,modemax + cof = rlamda(k) * COS( rlatu(j) ) + IF ( cof .LT. 1. ) GOTO 82 + 81 CONTINUE + GOTO 84 + 82 modfrstu( j ) = k +c + kf = modfrstu( j ) + DO 83 k = kf , modemax + cof = rlamda(k) * COS( rlatu(j) ) + coefilu(k,j) = cof - 1. + coefilu2(k,j) = cof*cof - 1. + 83 CONTINUE + 84 CONTINUE +c +c + DO 89 j = 1,jfiltnv +c + DO 86 k = 2,modemax + cof = rlamda(k) * COS( rlatv(j) ) + IF ( cof .LT. 1. ) GOTO 87 + 86 CONTINUE + GOTO 89 + 87 modfrstv( j ) = k +c + kf = modfrstv( j ) + DO 88 k = kf , modemax + cof = rlamda(k) * COS( rlatv(j) ) + coefilv(k,j) = cof - 1. + coefilv2(k,j) = cof*cof - 1. + 88 CONTINUE +c + 89 CONTINUE +c + DO 94 j = jfiltsu,jjm + DO 91 k = 2,modemax + cof = rlamda(k) * COS( rlatu(j) ) + IF ( cof .LT. 1. ) GOTO 92 + 91 CONTINUE + GOTO 94 + 92 modfrstu( j ) = k +c + kf = modfrstu( j ) + DO 93 k = kf , modemax + cof = rlamda(k) * COS( rlatu(j) ) + coefilu(k,j) = cof - 1. + coefilu2(k,j) = cof*cof - 1. + 93 CONTINUE + 94 CONTINUE +c + DO 99 j = jfiltsv,jjm + DO 96 k = 2,modemax + cof = rlamda(k) * COS( rlatv(j) ) + IF ( cof .LT. 1. ) GOTO 97 + 96 CONTINUE + GOTO 99 + 97 modfrstv( j ) = k +c + kf = modfrstv( j ) + DO 98 k = kf , modemax + cof = rlamda(k) * COS( rlatv(j) ) + coefilv(k,j) = cof - 1. + coefilv2(k,j) = cof*cof - 1. + 98 CONTINUE + 99 CONTINUE +c + + 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 + + + IF( nfilun.LT. jfiltnu ) THEN + PRINT *,' le parametre nfilun utilise pour la matrice ', + * ' matriceun est trop petit ! ' + PRINT *,'Le changer dans parafilt.h et le mettre a ',jfiltnu + PRINT *,' Pour information, nfilun,nfilus,nfilvn,nfilvs ' + * ,'doivent etre egaux successivement a ',jfiltnu,jjm-jfiltsu+1 + * ,jfiltnv,jjm-jfiltsv+1 + STOP + ENDIF + IF( nfilun.GT. jfiltnu+ 2 ) THEN + PRINT *,' le parametre nfilun utilise pour la matrice ', + *' matriceun est trop grand ! Gachis de memoire ! ' + PRINT *,'Le changer dans parafilt.h et le mettre a ',jfiltnu + PRINT *,' Pour information, nfilun,nfilus,nfilvn,nfilvs ' + * ,'doivent etre egaux successivement a ',jfiltnu,jjm-jfiltsu+1 + * ,jfiltnv,jjm-jfiltsv+1 +c STOP + ENDIF + IF( nfilus.LT. jjm - jfiltsu +1 ) THEN + PRINT *,' le parametre nfilus utilise pour la matrice ', + * ' matriceus est trop petit ! ' + PRINT *,' Le changer dans parafilt.h et le mettre a ', + * jjm - jfiltsu + 1 + PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs ' + * ,'doivent etre egaux successivement a ',jfiltnu,jjm-jfiltsu+1 + * ,jfiltnv,jjm-jfiltsv+1 + STOP + ENDIF + IF( nfilus.GT. jjm - jfiltsu + 3 ) THEN + PRINT *,' le parametre nfilus utilise pour la matrice ', + * ' matriceus est trop grand ! ' + PRINT *,' Le changer dans parafilt.h et le mettre a ' , + * jjm - jfiltsu + 1 + PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs ' + * ,'doivent etre egaux successivement a ',jfiltnu,jjm-jfiltsu+1 + * ,jfiltnv,jjm-jfiltsv+1 +c STOP + ENDIF + IF( nfilvn.LT. jfiltnv ) THEN + PRINT *,' le parametre nfilvn utilise pour la matrice ', + * ' matricevn est trop petit ! ' + PRINT *,'Le changer dans parafilt.h et le mettre a ',jfiltnv + PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs ' + * ,'doivent etre egaux successivement a ',jfiltnu,jjm-jfiltsu+1 + * ,jfiltnv,jjm-jfiltsv+1 + STOP + ENDIF + IF( nfilvn.GT. jfiltnv+ 2 ) THEN + PRINT *,' le parametre nfilvn utilise pour la matrice ', + *' matricevn est trop grand ! Gachis de memoire ! ' + PRINT *,'Le changer dans parafilt.h et le mettre a ',jfiltnv + PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs ' + * ,'doivent etre egaux successivement a ',jfiltnu,jjm-jfiltsu+1 + * ,jfiltnv,jjm-jfiltsv+1 +c STOP + ENDIF + IF( nfilvs.LT. jjm - jfiltsv +1 ) THEN + PRINT *,' le parametre nfilvs utilise pour la matrice ', + * ' matricevs est trop petit ! Le changer dans parafilt.h ' + PRINT *,' Le changer dans parafilt.h et le mettre a ' + * , jjm - jfiltsv + 1 + PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs ' + * ,'doivent etre egaux successivement a ',jfiltnu,jjm-jfiltsu+1 + * ,jfiltnv,jjm-jfiltsv+1 + STOP + ENDIF + IF( nfilvs.GT. jjm - jfiltsv + 3 ) THEN + PRINT *,' le parametre nfilvs utilise pour la matrice ', + * ' matricevs est trop grand ! Gachis de memoire ! ' + PRINT *,' Le changer dans parafilt.h et le mettre a ' + * , jjm - jfiltsv + 1 + PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs ' + * ,'doivent etre egaux successivement a ',jfiltnu,jjm-jfiltsu+1 + * ,jfiltnv,jjm-jfiltsv+1 +c STOP + ENDIF + +c +c ................................................................... +c +c ... Calcul de la matrice filtre 'matriceu' pour les champs situes +c sur la grille scalaire ........ +c ................................................................... +c + 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 + +c ................................................................... +c +c ... Calcul de la matrice filtre 'matricev' pour les champs situes +c sur la grille de V ou de Z ........ +c ................................................................... +c + 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 + +c ................................................................... +c +c ... Calcul de la matrice filtre 'matrinv' pour les champs situes +c sur la grille scalaire , pour le filtre inverse ........ +c ................................................................... +c + 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 + +c ................................................................... + +c +334 FORMAT(1x,24i3) +755 FORMAT(1x,6f10.3,i3) + + RETURN + END Index: /LMDZ4/trunk/libf/filtrez/jacobi.F =================================================================== --- /LMDZ4/trunk/libf/filtrez/jacobi.F (revision 524) +++ /LMDZ4/trunk/libf/filtrez/jacobi.F (revision 524) @@ -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/trunk/libf/filtrez/parafilt.h =================================================================== --- /LMDZ4/trunk/libf/filtrez/parafilt.h (revision 524) +++ /LMDZ4/trunk/libf/filtrez/parafilt.h (revision 524) @@ -0,0 +1,43 @@ +! +! $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: + PARAMETER (nfilun=13, nfilus=12, nfilvn=12, nfilvs=12) +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/trunk/libf/filtrez/parafilt.h_192x142x29 =================================================================== --- /LMDZ4/trunk/libf/filtrez/parafilt.h_192x142x29 (revision 524) +++ /LMDZ4/trunk/libf/filtrez/parafilt.h_192x142x29 (revision 524) @@ -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/trunk/libf/filtrez/parafilt.h_96x71x19 =================================================================== --- /LMDZ4/trunk/libf/filtrez/parafilt.h_96x71x19 (revision 524) +++ /LMDZ4/trunk/libf/filtrez/parafilt.h_96x71x19 (revision 524) @@ -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/trunk/libf/grid/dimension/dimensions.192.142.29.t4 =================================================================== --- /LMDZ4/trunk/libf/grid/dimension/dimensions.192.142.29.t4 (revision 524) +++ /LMDZ4/trunk/libf/grid/dimension/dimensions.192.142.29.t4 (revision 524) @@ -0,0 +1,16 @@ +c----------------------------------------------------------------------- +c INCLUDE 'dimensions.h' +c +c dimensions.h contient les dimensions du modele +c ndm est tel que iim=2**ndm +c nqmx est la dimension de la variable traceur q +c----------------------------------------------------------------------- + + INTEGER iim,jjm,llm,ndm + + PARAMETER (iim= 192,jjm=142,llm=29,ndm=1) + + integer nqmx + parameter (nqmx=4) + +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/grid/dimension/dimensions.192.144.29.t4 =================================================================== --- /LMDZ4/trunk/libf/grid/dimension/dimensions.192.144.29.t4 (revision 524) +++ /LMDZ4/trunk/libf/grid/dimension/dimensions.192.144.29.t4 (revision 524) @@ -0,0 +1,16 @@ +c----------------------------------------------------------------------- +c INCLUDE 'dimensions.h' +c +c dimensions.h contient les dimensions du modele +c ndm est tel que iim=2**ndm +c nqmx est la dimension de la variable traceur q +c----------------------------------------------------------------------- + + INTEGER iim,jjm,llm,ndm + + PARAMETER (iim= 192,jjm=144,llm=29,ndm=1) + + integer nqmx + parameter (nqmx=4) + +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/grid/dimension/dimensions.48.32.19.t4 =================================================================== --- /LMDZ4/trunk/libf/grid/dimension/dimensions.48.32.19.t4 (revision 524) +++ /LMDZ4/trunk/libf/grid/dimension/dimensions.48.32.19.t4 (revision 524) @@ -0,0 +1,16 @@ +c----------------------------------------------------------------------- +c INCLUDE 'dimensions.h' +c +c dimensions.h contient les dimensions du modele +c ndm est tel que iim=2**ndm +c nqmx est la dimension de la variable traceur q +c----------------------------------------------------------------------- + + INTEGER iim,jjm,llm,ndm + + PARAMETER (iim= 48,jjm=32,llm=19,ndm=1) + + integer nqmx + parameter (nqmx=4) + +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/grid/dimension/dimensions.48.32.19.t6 =================================================================== --- /LMDZ4/trunk/libf/grid/dimension/dimensions.48.32.19.t6 (revision 524) +++ /LMDZ4/trunk/libf/grid/dimension/dimensions.48.32.19.t6 (revision 524) @@ -0,0 +1,16 @@ +c----------------------------------------------------------------------- +c INCLUDE 'dimensions.h' +c +c dimensions.h contient les dimensions du modele +c ndm est tel que iim=2**ndm +c nqmx est la dimension de la variable traceur q +c----------------------------------------------------------------------- + + INTEGER iim,jjm,llm,ndm + + PARAMETER (iim= 48,jjm=32,llm=19,ndm=1) + + integer nqmx + parameter (nqmx=6) + +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/grid/dimension/dimensions.72.45.19.t4 =================================================================== --- /LMDZ4/trunk/libf/grid/dimension/dimensions.72.45.19.t4 (revision 524) +++ /LMDZ4/trunk/libf/grid/dimension/dimensions.72.45.19.t4 (revision 524) @@ -0,0 +1,16 @@ +c----------------------------------------------------------------------- +c INCLUDE 'dimensions.h' +c +c dimensions.h contient les dimensions du modele +c ndm est tel que iim=2**ndm +c nqmx est la dimension de la variable traceur q +c----------------------------------------------------------------------- + + INTEGER iim,jjm,llm,ndm + + PARAMETER (iim= 72,jjm=45,llm=19,ndm=1) + + integer nqmx + parameter (nqmx=4) + +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/grid/dimension/dimensions.96.71.19.t13 =================================================================== --- /LMDZ4/trunk/libf/grid/dimension/dimensions.96.71.19.t13 (revision 524) +++ /LMDZ4/trunk/libf/grid/dimension/dimensions.96.71.19.t13 (revision 524) @@ -0,0 +1,16 @@ +c----------------------------------------------------------------------- +c INCLUDE 'dimensions.h' +c +c dimensions.h contient les dimensions du modele +c ndm est tel que iim=2**ndm +c nqmx est la dimension de la variable traceur q +c----------------------------------------------------------------------- + + INTEGER iim,jjm,llm,ndm + + PARAMETER (iim= 96,jjm=71,llm=19,ndm=1) + + integer nqmx + parameter (nqmx=13) + +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/grid/dimension/dimensions.96.71.19.t4 =================================================================== --- /LMDZ4/trunk/libf/grid/dimension/dimensions.96.71.19.t4 (revision 524) +++ /LMDZ4/trunk/libf/grid/dimension/dimensions.96.71.19.t4 (revision 524) @@ -0,0 +1,16 @@ +c----------------------------------------------------------------------- +c INCLUDE 'dimensions.h' +c +c dimensions.h contient les dimensions du modele +c ndm est tel que iim=2**ndm +c nqmx est la dimension de la variable traceur q +c----------------------------------------------------------------------- + + INTEGER iim,jjm,llm,ndm + + PARAMETER (iim= 96,jjm=71,llm=19,ndm=1) + + integer nqmx + parameter (nqmx=4) + +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/grid/dimension/dimensions.96.72.19.t12 =================================================================== --- /LMDZ4/trunk/libf/grid/dimension/dimensions.96.72.19.t12 (revision 524) +++ /LMDZ4/trunk/libf/grid/dimension/dimensions.96.72.19.t12 (revision 524) @@ -0,0 +1,16 @@ +c----------------------------------------------------------------------- +c INCLUDE 'dimensions.h' +c +c dimensions.h contient les dimensions du modele +c ndm est tel que iim=2**ndm +c nqmx est la dimension de la variable traceur q +c----------------------------------------------------------------------- + + INTEGER iim,jjm,llm,ndm + + PARAMETER (iim= 96,jjm=72,llm=19,ndm=1) + + integer nqmx + parameter (nqmx=12) + +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/grid/dimension/dimensions.96.72.19.t4 =================================================================== --- /LMDZ4/trunk/libf/grid/dimension/dimensions.96.72.19.t4 (revision 524) +++ /LMDZ4/trunk/libf/grid/dimension/dimensions.96.72.19.t4 (revision 524) @@ -0,0 +1,16 @@ +c----------------------------------------------------------------------- +c INCLUDE 'dimensions.h' +c +c dimensions.h contient les dimensions du modele +c ndm est tel que iim=2**ndm +c nqmx est la dimension de la variable traceur q +c----------------------------------------------------------------------- + + INTEGER iim,jjm,llm,ndm + + PARAMETER (iim= 96,jjm=72,llm=19,ndm=1) + + integer nqmx + parameter (nqmx=4) + +c----------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/grid/dimension/makdim =================================================================== --- /LMDZ4/trunk/libf/grid/dimension/makdim (revision 524) +++ /LMDZ4/trunk/libf/grid/dimension/makdim (revision 524) @@ -0,0 +1,70 @@ +nqmx=$1 +shift +for i in $* ; do + list=$list.$i +done +fichdim=dimensions${list}.t${nqmx} + +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 +c----------------------------------------------------------------------- +c INCLUDE 'dimensions.h' +c +c dimensions.h contient les dimensions du modele +c ndm est tel que iim=2**ndm +c nqmx est la dimension de la variable traceur q +c----------------------------------------------------------------------- + + INTEGER iim,jjm,llm,ndm + + PARAMETER (iim= $im,jjm=$jm,llm=$lm,ndm=$ndm) + + integer nqmx + parameter (nqmx=$nqmx) + +c----------------------------------------------------------------------- +EOF +fi + +\rm ../dimensions.h +tar cf - $fichdim | ( cd .. ; tar xf - ; mv $fichdim dimensions.h ) Index: /LMDZ4/trunk/libf/grid/fxy_new.h =================================================================== --- /LMDZ4/trunk/libf/grid/fxy_new.h (revision 524) +++ /LMDZ4/trunk/libf/grid/fxy_new.h (revision 524) @@ -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/trunk/libf/grid/fxy_reg.h =================================================================== --- /LMDZ4/trunk/libf/grid/fxy_reg.h (revision 524) +++ /LMDZ4/trunk/libf/grid/fxy_reg.h (revision 524) @@ -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/trunk/libf/grid/fxy_sin.h =================================================================== --- /LMDZ4/trunk/libf/grid/fxy_sin.h (revision 524) +++ /LMDZ4/trunk/libf/grid/fxy_sin.h (revision 524) @@ -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/trunk/libf/grid/fxyprim.h =================================================================== --- /LMDZ4/trunk/libf/grid/fxyprim.h (revision 524) +++ /LMDZ4/trunk/libf/grid/fxyprim.h (revision 524) @@ -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/trunk/libf/makdim =================================================================== --- /LMDZ4/trunk/libf/makdim (revision 524) +++ /LMDZ4/trunk/libf/makdim (revision 524) @@ -0,0 +1,3 @@ +! +! $Header$ +! Index: /LMDZ4/trunk/libf/phylmd/FCTTRE.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/FCTTRE.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/FCTTRE.h (revision 524) @@ -0,0 +1,39 @@ +! +! $Header$ +! +C ------------------------------------------------------------------ +C This COMDECK includes the Thermodynamical functions for the cy39 +C ECMWF Physics package. +C Consistent with YOMCST Basic physics constants, assuming the +C partial pressure of water vapour is given by a first order +C Taylor expansion of Qs(T) w.r.t. to Temperature, using constants +C in YOETHF +C ------------------------------------------------------------------ + REAL PTARG, PDELARG, P5ARG, PQSARG, PCOARG + REAL FOEEW, FOEDE, qsats, qsatl, dqsats, dqsatl + LOGICAL thermcep + PARAMETER (thermcep=.TRUE.) +C + FOEEW ( PTARG,PDELARG ) = EXP ( + S (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT) + S / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) ) +C + FOEDE ( PTARG,PDELARG,P5ARG,PQSARG,PCOARG ) = PQSARG*PCOARG*P5ARG + S / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG))**2 +c + 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)) +c + 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/trunk/libf/phylmd/FCTTRE.inc =================================================================== --- /LMDZ4/trunk/libf/phylmd/FCTTRE.inc (revision 524) +++ /LMDZ4/trunk/libf/phylmd/FCTTRE.inc (revision 524) @@ -0,0 +1,39 @@ +! +! $Header$ +! +! ------------------------------------------------------------------ +! 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/trunk/libf/phylmd/YOECUMF.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/YOECUMF.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/YOECUMF.h (revision 524) @@ -0,0 +1,42 @@ +! +! $Header$ +! +C ---------------------------------------------------------------- +C* *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME +C ---------------------------------------------------------------- +C + COMMON /YOECUMF/ + L LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV, + R ENTRPEN,ENTRSCV,ENTRMID,ENTRDD,CMFCTOP, + R CMFCMAX,CMFCMIN,CMFDEPS,RHCDD,CPRCON +C + LOGICAL LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV + REAL ENTRPEN, ENTRSCV, ENTRMID, ENTRDD + REAL CMFCTOP, CMFCMAX, CMFCMIN, CMFDEPS, RHCDD, CPRCON +C +*if (DOC,declared) <> 'UNKNOWN' +C* *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME +C +C M.TIEDTKE E. C. M. W. F. 18/1/89 +C +C NAME TYPE PURPOSE +C ---- ---- ------- +C +C LMFPEN LOGICAL TRUE IF PENETRATIVE CONVECTION IS SWITCHED ON +C LMFSCV LOGICAL TRUE IF SHALLOW CONVECTION IS SWITCHED ON +C LMFMID LOGICAL TRUE IF MIDLEVEL CONVECTION IS SWITCHED ON +C LMFDD LOGICAL TRUE IF CUMULUS DOWNDRAFT IS SWITCHED ON +C LMFDUDV LOGICAL TRUE IF CUMULUS FRICTION IS SWITCHED ON +C ENTRPEN REAL ENTRAINMENT RATE FOR PENETRATIVE CONVECTION +C ENTRSCV REAL ENTRAINMENT RATE FOR SHALLOW CONVECTION +C ENTRMID REAL ENTRAINMENT RATE FOR MIDLEVEL CONVECTION +C ENTRDD REAL ENTRAINMENT RATE FOR CUMULUS DOWNDRAFTS +C CMFCTOP REAL RELAT. CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANC +C CMFCMAX REAL MAXIMUM MASSFLUX VALUE ALLOWED FOR +C CMFCMIN REAL MINIMUM MASSFLUX VALUE (FOR SAFETY) +C CMFDEPS REAL FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS +C RHCDD REAL RELATIVE SATURATION IN DOWNDRAFTS +C CPRCON REAL COEFFICIENTS FOR DETERMINING CONVERSION +C FROM CLOUD WATER TO RAIN +*ifend +C ---------------------------------------------------------------- Index: /LMDZ4/trunk/libf/phylmd/YOEGWD.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/YOEGWD.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/YOEGWD.h (revision 524) @@ -0,0 +1,15 @@ +! +! $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 + + Index: /LMDZ4/trunk/libf/phylmd/YOETHF.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/YOETHF.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/YOETHF.h (revision 524) @@ -0,0 +1,15 @@ +! +! $Header$ +! +C* COMMON *YOETHF* DERIVED CONSTANTS SPECIFIC TO ECMWF THERMODYNAMICS +C +C *R__ES* *CONSTANTS USED FOR COMPUTATION OF SATURATION +C MIXING RATIO OVER LIQUID WATER(*R_LES*) OR +C ICE(*R_IES*). +C *RVTMP2* *RVTMP2=RCPV/RCPD-1. +C *RHOH2O* *DENSITY OF LIQUID WATER. (RATM/100.) +C + REAL R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES + REAL RVTMP2, RHOH2O + COMMON /YOETHF/R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES, + . RVTMP2, RHOH2O Index: /LMDZ4/trunk/libf/phylmd/YOETHF.inc =================================================================== --- /LMDZ4/trunk/libf/phylmd/YOETHF.inc (revision 524) +++ /LMDZ4/trunk/libf/phylmd/YOETHF.inc (revision 524) @@ -0,0 +1,15 @@ +! +! $Header$ +! +!* 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 Index: /LMDZ4/trunk/libf/phylmd/YOMCST.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/YOMCST.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/YOMCST.h (revision 524) @@ -0,0 +1,38 @@ +! +! $Header$ +! +! 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,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 +! +! S ,RSIGMA,RI0 + COMMON/YOMCST/RPI ,RCLUM ,RHPLA ,RKBOL ,RNAVO + S ,RDAY ,REA ,REPSM ,RSIYEA,RSIDAY,ROMEGA + s ,R_ecc, R_peri, R_incl + S ,RA ,RG ,R1SA + S ,RSIGMA + S ,R ,RMD ,RMV ,RD ,RV ,RCPD + S ,RCPV ,RCVD ,RCVV ,RKAPPA,RETV + S ,RCW ,RCS + S ,RLVTT ,RLSTT ,RLMLT ,RTT ,RATM + S ,RESTT ,RALPW ,RBETW ,RGAMW ,RALPS ,RBETS ,RGAMS + S ,RALPD ,RBETD ,RGAMD +! ------------------------------------------------------------------ Index: /LMDZ4/trunk/libf/phylmd/YOMCST.inc =================================================================== --- /LMDZ4/trunk/libf/phylmd/YOMCST.inc (revision 524) +++ /LMDZ4/trunk/libf/phylmd/YOMCST.inc (revision 524) @@ -0,0 +1,31 @@ +! +! $Header$ +! +! 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,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 +! +!IM & ,R1SA ,RSIGMA,RI0,R ,RMD ,RMV ,RD ,RV ,RCPD ,RCPV,RCVD & + 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 ,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 Index: /LMDZ4/trunk/libf/phylmd/aeropt.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/aeropt.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/aeropt.F (revision 524) @@ -0,0 +1,133 @@ +! +! $Header$ +! + SUBROUTINE aeropt(pplay, paprs, t_seri, msulfate, RHcl, + . tau_ae, piz_ae, cg_ae, ai ) +c + IMPLICIT none +c +c +c +#include "dimensions.h" +#include "dimphy.h" +#include "YOMCST.h" +c +c Arguments: +c + REAL paprs(klon,klev+1) + REAL pplay(klon,klev), t_seri(klon,klev) + REAL msulfate(klon,klev) ! masse sulfate ug SO4/m3 [ug/m^3] + REAL RHcl(klon,klev) ! humidite relative ciel clair + REAL tau_ae(klon,klev,2) ! epaisseur optique aerosol + REAL piz_ae(klon,klev,2) ! single scattering albedo aerosol + REAL cg_ae(klon,klev,2) ! asymmetry parameter aerosol + REAL 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/trunk/libf/phylmd/ajsec.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/ajsec.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/ajsec.F (revision 524) @@ -0,0 +1,243 @@ +! +! $Header$ +! + SUBROUTINE ajsec(paprs, pplay, t,q, d_t,d_q) + 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====================================================================== +#include "dimensions.h" +#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) + 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 + 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) + 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====================================================================== +#include "dimensions.h" +#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/trunk/libf/phylmd/albedo.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/albedo.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/albedo.F (revision 524) @@ -0,0 +1,186 @@ +! +! $Header$ +! +c +c + SUBROUTINE alboc(rjour,rlat,albedo) + 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====================================================================== +#include "dimensions.h" +#include "dimphy.h" +#include "YOMCST.h" +c + REAL fmagic ! un facteur magique pour regler l'albedo +ccc PARAMETER (fmagic=0.7) +cccIM => a remplacer + 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 + 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 + ELSE ! nuit polaire (on peut prendre une valeur quelconque) + albedo(i) = fmagic + ENDIF +1999 CONTINUE + ENDIF + RETURN + END +c===================================================================== + SUBROUTINE alboc_cd(rmu0,albedo) + 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====================================================================== +#include "dimensions.h" +#include "dimphy.h" + REAL rmu0(klon), albedo(klon) +c + REAL fmagic ! un facteur magique pour regler l'albedo +ccc PARAMETER (fmagic=0.7) +cccIM => a remplacer + 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)) + 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) + albedo(i) = MAX(MIN(albedo(i),0.60),0.04) + ENDDO +c + ENDIF +c + RETURN + END +c======================================================================== Index: /LMDZ4/trunk/libf/phylmd/atm2geo.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/atm2geo.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/atm2geo.F (revision 524) @@ -0,0 +1,47 @@ +! +! $Header$ +! +C + SUBROUTINE atm2geo ( im, jm, pte, ptn, plon, plat, pxx, pyy, pzz ) +cc +cc Change wind local atmospheric coordinates to +cc geocentric +cc +c$$$ INCLUDE 'param.h' +c + 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 +c + REAL, PARAMETER :: rpi = 3.141592653E0 + REAL, PARAMETER :: rad = rpi / 180.0E0 +c + REAL, DIMENSION (im,jm) :: zsinlon, zcoslon + REAL, DIMENSION (im,jm) :: zsinlat, zcoslat +c + LOGICAL, SAVE :: linit = .FALSE. +c +c$$$ IF ( .NOT. linit ) THEN + zsinlon = SIN (rad * plon) + zcoslon = COS (rad * plon) + zsinlat = SIN (rad * plat) + zcoslat = COS (rad * plat) + linit = .TRUE. +c$$$ ENDIF +c + pxx = - zsinlon * pte - zsinlat * zcoslon * ptn + pyy = zcoslon * pte - zsinlat * zsinlon * ptn + pzz = zcoslat * ptn +c +c Value at North Pole + pxx ( :, 1) = - ptn ( 1, 1) + pyy ( :, 1) = - pte ( 1, 1) + pzz ( :, 1) = 0.0 +c Value at South Pole + pxx ( :, jm) = + ptn ( 1, jm) + pyy ( :, jm) = + pte ( 1, jm) + pzz ( :, jm) = 0.0 +c + RETURN + END SUBROUTINE atm2geo Index: /LMDZ4/trunk/libf/phylmd/calcratqs.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/calcratqs.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/calcratqs.F (revision 524) @@ -0,0 +1,162 @@ +! +! $Header$ +! + SUBROUTINE calcratqs ( flag_ratqs, + I paprs,pplay,q_seri,d_t_con,d_t_ajs + O ,ratqs,zpt_conv) + 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) +#include "dimensions.h" +#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./ + + + 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 + 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/trunk/libf/phylmd/chem.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/chem.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/chem.h (revision 524) @@ -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/trunk/libf/phylmd/clcdrag.F90 =================================================================== --- /LMDZ4/trunk/libf/phylmd/clcdrag.F90 (revision 524) +++ /LMDZ4/trunk/libf/phylmd/clcdrag.F90 (revision 524) @@ -0,0 +1,108 @@ +! +! $Header$ +! + SUBROUTINE clcdrag(klon, knon, nsrf, zxli, & + u, v, t, q, zgeop, & + ts, qsurf, rugos, & + pcfm, pcfh) + IMPLICIT NONE +! ================================================================= c +! +! Objet : calcul des cdrags pour le moment (pcfm) et +! les flux de chaleur sensible et latente (pcfh). +! +! ================================================================= c +! +! 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.inc +! zxli----input-L- calcul des cdrags selon Laurent Li +! u-------input-R- vent zonal au 1er niveau du modele +! v-------input-R- vent meridien 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 +! ts------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) :: klon, knon, nsrf + LOGICAL, intent(in) :: zxli + REAL, intent(in), dimension(klon) :: u, v, t, q, zgeop + REAL, intent(in), dimension(klon) :: ts, qsurf + REAL, intent(in), dimension(klon) :: rugos + REAL, intent(out), dimension(klon) :: pcfm, pcfh +! ================================================================= c +! +#include "YOMCST.inc" +#include "YOETHF.inc" +#include "indicesol.inc" +! +! 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, 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 +! +! 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 frottement au sol (Cdrag) +! + DO i = 1, knon + zdu2 = max(cepdu2,u(i)**2+v(i)**2) + ztsolv = ts(i) * (1.0+RETV*qsurf(i)) + ztvd = (t(i)+zgeop(i)/RCPD/(1.+RVTMP2*q(i))) & + *(1.+RETV*q(i)) + zri(i) = zgeop(i)*(ztvd-ztsolv)/(zdu2*ztvd) + zcdn(i) = (ckap/log(1.+zgeop(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 + zcfh1(i) = 0.8 * zcdn(i) * FRIH + 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+zgeop(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) = 0.8 * 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) =0.8* zcdn(i)*(1.0+zcr**1.25)**(1./1.25) + ENDIF + END DO + RETURN + END SUBROUTINE clcdrag Index: /LMDZ4/trunk/libf/phylmd/clesphys.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/clesphys.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/clesphys.h (revision 524) @@ -0,0 +1,30 @@ +! +! $Header$ +! +c..include cles_phys.h +c + LOGICAL cycle_diurne,soil_model,new_oliq,ok_orodr,ok_orolf + LOGICAL ok_limitvrai + INTEGER nbapp_rad, iflag_con + REAL co2_ppm, solaire + REAL*8 RCO2, RCH4, RN2O, RCFC11, RCFC12 + REAL*8 CH4_ppb, N2O_ppb, CFC11_ppt, CFC12_ppt +cIM simulateur ISCCP + INTEGER top_height, overlap +cIM seuils cdrm, cdrh + REAL cdmmax, cdhmax +cIM param. stabilite s/ terres et en dehors + REAL ksta, ksta_ter +cIM ok_kzmin : clef calcul Kzmin dans la CL de surface cf FH + LOGICAL ok_kzmin +cIM lev_histhf : niveau sorties 6h +cIM lev_histday : niveau sorties journalieres +cIM lev_histmth : niveau sorties mensuelles + INTEGER lev_histhf, lev_histday, lev_histmth + + 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, lev_histhf, lev_histday, lev_histmth Index: /LMDZ4/trunk/libf/phylmd/clesphys.inc =================================================================== --- /LMDZ4/trunk/libf/phylmd/clesphys.inc (revision 524) +++ /LMDZ4/trunk/libf/phylmd/clesphys.inc (revision 524) @@ -0,0 +1,23 @@ +! +! $Header$ +! +!..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, solaire + DOUBLE PRECISION :: RCO2, RCH4, RN2O, RCFC11, RCFC12 + DOUBLE PRECISION :: CH4_ppb, N2O_ppb, CFC11_ppt, CFC12_ppt + INTEGER :: top_height, overlap + REAL :: cdmmax, cdhmax + REAL :: ksta, ksta_ter + LOGICAL :: ok_kzmin + INTEGER :: lev_histhf, lev_histday, lev_histmth + + 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, lev_histhf, lev_histday, lev_histmth Index: /LMDZ4/trunk/libf/phylmd/clift.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/clift.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/clift.F (revision 524) @@ -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/trunk/libf/phylmd/clim.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/clim.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/clim.h (revision 524) @@ -0,0 +1,112 @@ +! +! $Header$ +! +C +C - - - - - - - - - - - - - - - - - - - - - - - - - +C +C* =clim.h= CLIM 1.1 include file +C Coupling Library for Interfacing Models +C +C - - - - - - - - - - - - - - - - - - - - - - - - - +C + INTEGER*4 CLIM_Void +C + INTEGER*4 CLIM_MaxMod, + * CLIM_MaxPort, + * CLIM_MaxSegments, + * CLIM_MaxTag, + * CLIM_MaxLink, + * CLIM_ParSize, + * CLIM_Clength +C + INTEGER*4 CLIM_In, CLIM_Out, CLIM_InOut +C + INTEGER*4 CLIM_Strategy, CLIM_Serial, + * CLIM_Apple, CLIM_Orange, CLIM_Box, + * CLIM_Segments, CLIM_Length, CLIM_Offset, + * CLIM_SizeX, CLIM_SizeY, CLIM_LdX +C + INTEGER*4 CLIM_Integer, CLIM_Real, CLIM_Double +C + INTEGER*4 CLIM_StopPvm, CLIM_ContPvm +C + INTEGER*4 CLIM_MaxCodes, CLIM_Ok, + * CLIM_FastExit, CLIM_BadName, CLIM_BadPort, + * CLIM_BadType, CLIM_DoubleDef, CLIM_NotStep, + * CLIM_IncStep, CLIM_IncSize, CLIM_NotClim, + * CLIM_TimeOut, + * CLIM_Pvm, CLIM_FirstCall, CLIM_PbRoute, + * CLIM_Group, CLIM_BadTaskId, CLIM_NoTask, + * CLIM_InitBuff, CLIM_Pack, CLIM_Unpack, + * CLIM_Down, CLIM_PvmExit +C +C-----Parameter sizes +C + PARAMETER ( CLIM_Void = 0 ) + PARAMETER ( CLIM_MaxMod = 8 ) + PARAMETER ( CLIM_MaxPort = 40 ) + PARAMETER ( CLIM_MaxSegments = 160 ) + PARAMETER ( CLIM_MaxLink = CLIM_MaxMod * CLIM_MaxPort ) + PARAMETER ( CLIM_ParSize = 2 * CLIM_MaxSegments + 2 ) + PARAMETER ( CLIM_MaxTag = 16777215 ) + PARAMETER ( CLIM_Clength = 32 ) +C +C-----Ports status +C + PARAMETER ( CLIM_In = 1 ) + PARAMETER ( CLIM_Out = 0 ) + PARAMETER ( CLIM_InOut = 2 ) +C +C-----Parallel distribution +C + PARAMETER ( CLIM_Strategy = 1 ) + PARAMETER ( CLIM_Segments = 2 ) + PARAMETER ( CLIM_Serial = 0 ) + PARAMETER ( CLIM_Apple = 1 ) + PARAMETER ( CLIM_Box = 2 ) + PARAMETER ( CLIM_Orange = 3 ) + PARAMETER ( CLIM_Offset = 2 ) + PARAMETER ( CLIM_Length = 3 ) + PARAMETER ( CLIM_SizeX = 3 ) + PARAMETER ( CLIM_SizeY = 4 ) + PARAMETER ( CLIM_LdX = 5 ) +C +C-----Datatypes +C + PARAMETER ( CLIM_Integer = 1 ) + PARAMETER ( CLIM_Real = 4 ) + PARAMETER ( CLIM_Double = 8 ) +C +C-----Quit parameters +C + PARAMETER ( CLIM_ContPvm = 0 ) + PARAMETER ( CLIM_StopPvm = 1 ) +C +C-----Error Codes +C + PARAMETER ( CLIM_MaxCodes = -21 ) +C + PARAMETER ( CLIM_Ok = 0 ) + PARAMETER ( CLIM_FastExit = -1 ) + PARAMETER ( CLIM_BadName = -2 ) + PARAMETER ( CLIM_BadPort = -3 ) + PARAMETER ( CLIM_BadType = -4 ) + PARAMETER ( CLIM_DoubleDef = -5 ) + PARAMETER ( CLIM_NotStep = -6 ) + PARAMETER ( CLIM_IncStep = -7 ) + PARAMETER ( CLIM_IncSize = -8 ) + PARAMETER ( CLIM_NotClim = -9 ) + PARAMETER ( CLIM_TimeOut = -10 ) + PARAMETER ( CLIM_Pvm = -11 ) + PARAMETER ( CLIM_FirstCall = -12 ) + PARAMETER ( CLIM_PbRoute = -13 ) + PARAMETER ( CLIM_Group = -14 ) + PARAMETER ( CLIM_BadTaskId = -15 ) + PARAMETER ( CLIM_NoTask = -16 ) + PARAMETER ( CLIM_InitBuff = -17 ) + PARAMETER ( CLIM_Pack = -18 ) + PARAMETER ( CLIM_Unpack = -19 ) + PARAMETER ( CLIM_Down = -20 ) + PARAMETER ( CLIM_PvmExit = -21 ) +C +C-----End of clim.h Index: /LMDZ4/trunk/libf/phylmd/clmain.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/clmain.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/clmain.F (revision 524) @@ -0,0 +1,2174 @@ +! +! $Header$ +! +c +c + SUBROUTINE clmain(dtime,itap,date0,pctsrf,pctsrf_new, + . t,q,u,v, + . jour, rmu0, co2_ppm, + . ok_veget, ocean, npas, nexca, ts, + . soil_model,cdmmax, cdhmax, + . ksta, ksta_ter, ok_kzmin, ftsoil,qsol, + . paprs,pplay,radsol,snow,qsurf,evap,albe,alblw, + . fluxlat, + . rain_f, snow_f, solsw, sollw, sollwdown, fder, + . rlon, rlat, cufi, cvfi, rugos, + . debut, lafin, agesno,rugoro, + . d_t,d_q,d_u,d_v,d_ts, + . flux_t,flux_q,flux_u,flux_v,cdragh,cdragm, + . dflux_t,dflux_q, +cIM cf JLD . zcoefh,zu1,zv1, t2m, q2m, u10m, v10m) + . zcoefh,zu1,zv1, t2m, q2m, u10m, v10m, + . fqcalving,ffonte, run_off_lic_0) +cAA . itr, tr, flux_surf, d_tr) +cAA REM: +cAA----- +cAA Tout ce qui a trait au traceurs est dans phytrac maintenant +cAA pour l'instant le calcul de la couche limite pour les traceurs +cAA se fait avec cltrac et ne tient pas compte de la differentiation +cAA des sous-fraction de sol. +cAA REM bis : +cAA---------- +cAA Pour pouvoir extraire les coefficient d'echanges et le vent +cAA dans la premiere couche, 3 champs supplementaires ont ete crees +cAA zcoefh,zu1 et zv1. Pour l'instant nous avons moyenne les valeurs +cAA de ces trois champs sur les 4 subsurfaces du modele. Dans l'avenir +cAA si les informations des subsurfaces doivent etre prises en compte +cAA il faudra sortir ces memes champs en leur ajoutant une dimension, +cAA c'est a dire nbsrf (nbre de subsurface). + USE ioipsl + USE interface_surf + IMPLICIT none +c====================================================================== +c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: interface de "couche limite" (diffusion verticale) +c Arguments: +c dtime----input-R- interval du temps (secondes) +c itap-----input-I- numero du pas de temps +c date0----input-R- jour initial +c t--------input-R- temperature (K) +c q--------input-R- vapeur d'eau (kg/kg) +c u--------input-R- vitesse u +c v--------input-R- vitesse v +c ts-------input-R- temperature du sol (en Kelvin) +c paprs----input-R- pression a intercouche (Pa) +c pplay----input-R- pression au milieu de couche (Pa) +c radsol---input-R- flux radiatif net (positif vers le sol) en W/m**2 +c rlat-----input-R- latitude en degree +c rugos----input-R- longeur de rugosite (en m) +c cufi-----input-R- resolution des mailles en x (m) +c cvfi-----input-R- resolution des mailles en y (m) +c +c d_t------output-R- le changement pour "t" +c d_q------output-R- le changement pour "q" +c d_u------output-R- le changement pour "u" +c d_v------output-R- le changement pour "v" +c d_ts-----output-R- le changement pour "ts" +c flux_t---output-R- flux de chaleur sensible (CpT) J/m**2/s (W/m**2) +c (orientation positive vers le bas) +c flux_q---output-R- flux de vapeur d'eau (kg/m**2/s) +c flux_u---output-R- tension du vent X: (kg m/s)/(m**2 s) ou Pascal +c flux_v---output-R- tension du vent Y: (kg m/s)/(m**2 s) ou Pascal +c dflux_t derive du flux sensible +c dflux_q derive du flux latent +c ffonte----Flux thermique utilise pour fondre la neige +c fqcalving-Flux d'eau "perdue" par la surface et necessaire pour limiter la +c hauteur de neige, en kg/m2/s +cAA on rajoute en output yu1 et yv1 qui sont les vents dans +cAA la premiere couche +cAA ces 4 variables sont maintenant traites dans phytrac +c itr--------input-I- nombre de traceurs +c tr---------input-R- q. de traceurs +c flux_surf--input-R- flux de traceurs a la surface +c d_tr-------output-R tendance de traceurs +c====================================================================== +#include "dimensions.h" +#include "dimphy.h" +#include "indicesol.h" +c$$$ PB ajout pour soil +#include "dimsoil.h" +#include "iniprint.h" +c + REAL dtime + real date0 + integer itap + REAL t(klon,klev), q(klon,klev) + REAL u(klon,klev), v(klon,klev) + REAL paprs(klon,klev+1), pplay(klon,klev), radsol(klon) + REAL rlon(klon), rlat(klon), cufi(klon), cvfi(klon) + REAL d_t(klon, klev), d_q(klon, klev) + REAL d_u(klon, klev), d_v(klon, klev) + REAL flux_t(klon,klev, nbsrf), flux_q(klon,klev, nbsrf) + REAL dflux_t(klon), dflux_q(klon) +cIM cf JLD + REAL y_fqcalving(klon), y_ffonte(klon) + REAL fqcalving(klon,nbsrf), ffonte(klon,nbsrf) + REAL run_off_lic_0(klon), y_run_off_lic_0(klon) + + REAL flux_u(klon,klev, nbsrf), flux_v(klon,klev, nbsrf) + REAL rugmer(klon), agesno(klon,nbsrf),rugoro(klon) + REAL cdragh(klon), cdragm(klon) + integer jour ! jour de l'annee en cours + real rmu0(klon) ! cosinus de l'angle solaire zenithal + REAL co2_ppm ! taux CO2 atmosphere + LOGICAL debut, lafin, ok_veget + character*6 ocean + integer npas, nexca +cAA INTEGER itr +cAA REAL tr(klon,klev,nbtr) +cAA REAL d_tr(klon,klev,nbtr) +cAA REAL flux_surf(klon,nbtr) +c + REAL pctsrf(klon,nbsrf) + REAL ts(klon,nbsrf) + REAL d_ts(klon,nbsrf) + REAL snow(klon,nbsrf) + REAL qsurf(klon,nbsrf) + REAL evap(klon,nbsrf) + REAL albe(klon,nbsrf) + REAL alblw(klon,nbsrf) +c$$$ PB + REAL fluxlat(klon,nbsrf) +C + real rain_f(klon), snow_f(klon) + REAL fder(klon) +cIM cf. JLD REAL sollw(klon), solsw(klon), sollwdown(klon) + REAL sollw(klon,nbsrf), solsw(klon,nbsrf), sollwdown(klon) + REAL rugos(klon,nbsrf) +C la nouvelle repartition des surfaces sortie de l'interface + REAL pctsrf_new(klon,nbsrf) +cAA + REAL zcoefh(klon,klev) + REAL zu1(klon) + REAL zv1(klon) +cAA +c$$$ PB ajout pour soil + LOGICAL soil_model +cIM ajout seuils cdrm, cdrh + REAL cdmmax, cdhmax +cIM: 261103 + REAL ksta, ksta_ter + LOGICAL ok_kzmin +cIM: 261103 + REAL ftsoil(klon,nsoilmx,nbsrf) + REAL ytsoil(klon,nsoilmx) + REAL qsol(klon) +c====================================================================== + EXTERNAL clqh, clvent, coefkz, calbeta, cltrac +c====================================================================== + REAL yts(klon), yrugos(klon), ypct(klon), yz0_new(klon) + REAL yalb(klon) + REAL yalblw(klon) + REAL yu1(klon), yv1(klon) + real ysnow(klon), yqsurf(klon), yagesno(klon), yqsol(klon) + real yrain_f(klon), ysnow_f(klon) + real ysollw(klon), ysolsw(klon), ysollwdown(klon) + real yfder(klon), ytaux(klon), ytauy(klon) + REAL yrugm(klon), yrads(klon),yrugoro(klon) +c$$$ PB + REAL yfluxlat(klon) +C + REAL y_d_ts(klon) + REAL y_d_t(klon, klev), y_d_q(klon, klev) + REAL y_d_u(klon, klev), y_d_v(klon, klev) + REAL y_flux_t(klon,klev), y_flux_q(klon,klev) + REAL y_flux_u(klon,klev), y_flux_v(klon,klev) + REAL y_dflux_t(klon), y_dflux_q(klon) + REAL ycoefh(klon,klev), ycoefm(klon,klev) + REAL yu(klon,klev), yv(klon,klev) + REAL yt(klon,klev), yq(klon,klev) + REAL ypaprs(klon,klev+1), ypplay(klon,klev), ydelp(klon,klev) +cAA REAL ytr(klon,klev,nbtr) +cAA REAL y_d_tr(klon,klev,nbtr) +cAA REAL yflxsrf(klon,nbtr) +c + LOGICAL contreg + PARAMETER (contreg=.TRUE.) +c + LOGICAL ok_nonloc + PARAMETER (ok_nonloc=.FALSE.) + REAL ycoefm0(klon,klev), ycoefh0(klon,klev) +c +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" + REAL u1lay(klon), v1lay(klon) + REAL delp(klon,klev) + INTEGER i, k, nsrf +cAA INTEGER it + INTEGER ni(klon), knon, j +c Introduction d'une variable "pourcentage potentiel" pour tenir compte +c des eventuelles apparitions et/ou disparitions de la glace de mer + REAL pctsrf_pot(klon,nbsrf) + +c====================================================================== + REAL zx_alf1, zx_alf2 !valeur ambiante par extrapola. +c====================================================================== +c +c maf pour sorties IOISPL en cas de debugagage +c + CHARACTER*80 cldebug + SAVE cldebug + CHARACTER*8 cl_surf(nbsrf) + SAVE cl_surf + INTEGER nhoridbg, nidbg + SAVE nhoridbg, nidbg + INTEGER ndexbg(iim*(jjm+1)) + REAL zx_lon(iim,jjm+1), zx_lat(iim,jjm+1), zjulian + REAL tabindx(klon) + REAL debugtab(iim,jjm+1) + LOGICAL first_appel + SAVE first_appel + DATA first_appel/.false./ + LOGICAL debugindex + SAVE debugindex + DATA debugindex/.false./ + integer idayref +#include "temps.h" + REAL t2m(klon,nbsrf), q2m(klon,nbsrf) + REAL u10m(klon,nbsrf), v10m(klon,nbsrf) +c + REAL yt2m(klon), yq2m(klon), yu10m(klon) +c + REAL uzon(klon), vmer(klon) + REAL tair1(klon), qair1(klon), tairsol(klon) + REAL psfce(klon), patm(klon) +c + REAL qairsol(klon), zgeo1(klon) + REAL rugo1(klon) +c + LOGICAL zxli ! utiliser un jeu de fonctions simples + PARAMETER (zxli=.FALSE.) +c + REAL zt, zqs, zdelta, zcor + REAL t_coup + PARAMETER(t_coup=273.15) +C + character (len = 20) :: modname = 'clmain' + LOGICAL check + PARAMETER (check=.false.) +C + if (check) THEN + write(*,*) modname,' klon=',klon + call flush(6) + endif + IF (first_appel) THEN + first_appel=.false. +! +! initialisation sorties netcdf +! + 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) + cldebug='sous_index' + CALL histbeg(cldebug, 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) + ENDIF + + DO k = 1, klev ! epaisseur de couche + DO i = 1, klon + delp(i,k) = paprs(i,k)-paprs(i,k+1) + ENDDO + ENDDO + DO i = 1, klon ! vent de la premiere couche +ccc zx_alf1 = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2)) + zx_alf1 = 1.0 + zx_alf2 = 1.0 - zx_alf1 + u1lay(i) = u(i,1)*zx_alf1 + u(i,2)*zx_alf2 + v1lay(i) = v(i,1)*zx_alf1 + v(i,2)*zx_alf2 + ENDDO +c +c initialisation: +c + DO i = 1, klon + rugmer(i) = 0.0 + cdragh(i) = 0.0 + cdragm(i) = 0.0 + dflux_t(i) = 0.0 + dflux_q(i) = 0.0 + zu1(i) = 0.0 + zv1(i) = 0.0 + ENDDO + ypct = 0.0 + yts = 0.0 + ysnow = 0.0 + yqsurf = 0.0 + yalb = 0.0 + yalblw = 0.0 + yrain_f = 0.0 + ysnow_f = 0.0 + yfder = 0.0 + ytaux = 0.0 + ytauy = 0.0 + ysolsw = 0.0 + ysollw = 0.0 + ysollwdown = 0.0 + yrugos = 0.0 + yu1 = 0.0 + yv1 = 0.0 + yrads = 0.0 + ypaprs = 0.0 + ypplay = 0.0 + ydelp = 0.0 + yu = 0.0 + yv = 0.0 + yt = 0.0 + yq = 0.0 + pctsrf_new = 0.0 + y_flux_u = 0.0 + y_flux_v = 0.0 +C$$ PB + y_dflux_t = 0.0 + y_dflux_q = 0.0 + ytsoil = 999999. + yrugoro = 0. + + DO nsrf = 1, nbsrf + DO i = 1, klon + d_ts(i,nsrf) = 0.0 + ENDDO + END DO +C§§§ PB + yfluxlat=0. + flux_t = 0. + flux_q = 0. + flux_u = 0. + flux_v = 0. + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 +c$$$ flux_t(i,k) = 0.0 +c$$$ flux_q(i,k) = 0.0 + d_u(i,k) = 0.0 + d_v(i,k) = 0.0 +c$$$ flux_u(i,k) = 0.0 +c$$$ flux_v(i,k) = 0.0 + zcoefh(i,k) = 0.0 + ENDDO + ENDDO +cAA IF (itr.GE.1) THEN +cAA DO it = 1, itr +cAA DO k = 1, klev +cAA DO i = 1, klon +cAA d_tr(i,k,it) = 0.0 +cAA ENDDO +cAA ENDDO +cAA ENDDO +cAA ENDIF + +c +c Boucler sur toutes les sous-fractions du sol: +c +C Initialisation des "pourcentages potentiels". On considere ici qu'on +C peut avoir potentiellementdela glace sur tout le domaine oceanique +C (a affiner) + + pctsrf_pot = pctsrf + pctsrf_pot(:,is_oce) = 1. - zmasq(:) + pctsrf_pot(:,is_sic) = 1. - zmasq(:) + + DO 99999 nsrf = 1, nbsrf + +c chercher les indices: + DO j = 1, klon + ni(j) = 0 + ENDDO + knon = 0 + DO i = 1, klon + +C pour determiner le domaine a traiter on utilise les surfaces "potentielles" +C + IF (pctsrf_pot(i,nsrf).GT.epsfra) THEN + knon = knon + 1 + ni(knon) = i + ENDIF + ENDDO +c + if (check) THEN + write(*,*)'CLMAIN, nsrf, knon =',nsrf, knon + call flush(6) + endif +c +c variables pour avoir une sortie IOIPSL des INDEX +c + IF (debugindex) THEN + tabindx(:)=0. +c tabindx(1:knon)=(/FLOAT(i),i=1:knon/) + DO i=1,knon + tabindx(1:knon)=FLOAT(i) + END DO + debugtab(:,:)=0. + ndexbg(:)=0 + CALL gath2cpl(tabindx,debugtab,klon,knon,iim,jjm,ni) + CALL histwrite(nidbg,cl_surf(nsrf),itap,debugtab,iim*(jjm+1) + $ ,ndexbg) + ENDIF + IF (knon.EQ.0) GOTO 99999 + 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) = albe(i,nsrf) + yalblw(j) = alblw(i,nsrf) + yrain_f(j) = rain_f(i) + ysnow_f(j) = snow_f(i) + yagesno(j) = agesno(i,nsrf) + yfder(j) = fder(i) + ytaux(j) = flux_u(i,1,nsrf) + ytauy(j) = flux_v(i,1,nsrf) + ysolsw(j) = solsw(i,nsrf) + ysollw(j) = sollw(i,nsrf) + ysollwdown(j) = sollwdown(i) + yrugos(j) = rugos(i,nsrf) + yrugoro(j) = rugoro(i) + yu1(j) = u1lay(i) + yv1(j) = v1lay(i) + yrads(j) = ysolsw(j)+ ysollw(j) + ypaprs(j,klev+1) = paprs(i,klev+1) + y_run_off_lic_0(j) = run_off_lic_0(i) + END DO +C +C IF bucket model for continent, copy soil water content + IF ( nsrf .eq. is_ter .and. .not. ok_veget ) THEN + DO j = 1, knon + i = ni(j) + yqsol(j) = qsol(i) + END DO + ELSE + yqsol(:)=0. + ENDIF +c$$$ PB ajour pour soil + DO k = 1, nsoilmx + DO j = 1, knon + i = ni(j) + ytsoil(j,k) = ftsoil(i,k,nsrf) + END DO + 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) + 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 +c +c +c calculer Cdrag et les coefficients d'echange + CALL coefkz(nsrf, knon, ypaprs, ypplay, +cIM 261103 + . ksta, ksta_ter, +cIM 261103 + . yts, yrugos, yu, yv, yt, yq, + . yqsurf, + . ycoefm, ycoefh) + CALL coefkz2(nsrf, knon, ypaprs, ypplay,yt, + . ycoefm0, ycoefh0) + DO k = 1, 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 +c +cIM cf JLD : on seuille ycoefm et ycoefh + if (nsrf.eq.is_oce) then + do j=1,knon +c ycoefm(j,1)=min(ycoefm(j,1),1.1E-3) + ycoefm(j,1)=min(ycoefm(j,1),cdmmax) +c ycoefh(j,1)=min(ycoefh(j,1),1.1E-3) + ycoefh(j,1)=min(ycoefh(j,1),cdhmax) + enddo + endif + +c +cIM: 261103 + if (ok_kzmin) THEN +cIM cf FH: 201103 BEG +c Calcul d'une diffusion minimale pour les conditions tres stables. + call coefkzmin(knon,ypaprs,ypplay,yu,yv,yt,yq,ycoefm + . ,ycoefm0,ycoefh0) +c call dump2d(iim,jjm-1,ycoefm(2:klon-1,2), 'KZ ') +c call dump2d(iim,jjm-1,ycoefm0(2:klon-1,2),'KZMIN ') + + if ( 1.eq.1 ) then + DO k = 1, 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 +cIM cf FH: 201103 END + endif !ok_kzmin +cIM: 261103 + +c +c calculer la diffusion des vitesses "u" et "v" + CALL clvent(knon,dtime,yu1,yv1,ycoefm,yt,yu,ypaprs,ypplay,ydelp, + s y_d_u,y_flux_u) + CALL clvent(knon,dtime,yu1,yv1,ycoefm,yt,yv,ypaprs,ypplay,ydelp, + s y_d_v,y_flux_v) + +c pour le couplage + ytaux = y_flux_u(:,1) + ytauy = y_flux_v(:,1) + +c FH modif sur le cdrag temperature +c$$$PB : déplace dans clcdrag +c$$$ do i=1,knon +c$$$ ycoefh(i,1)=ycoefm(i,1)*0.8 +c$$$ enddo + +c calculer la diffusion de "q" et de "h" + CALL clqh(dtime, itap, date0,jour, debut,lafin, + e rlon, rlat, cufi, cvfi, + e knon, nsrf, ni, pctsrf, + e soil_model, ytsoil,yqsol, + e ok_veget, ocean, npas, nexca, + e rmu0, co2_ppm, yrugos, yrugoro, + e yu1, yv1, ycoefh, + e yt,yq,yts,ypaprs,ypplay, + e ydelp,yrads,yalb, yalblw, ysnow, yqsurf, + e yrain_f, ysnow_f, yfder, ytaux, ytauy, +c$$$ e ysollw, ysolsw, + e ysollw, ysollwdown, ysolsw,yfluxlat, + s pctsrf_new, yagesno, + s y_d_t, y_d_q, y_d_ts, yz0_new, +cIM cf JLD s y_flux_t, y_flux_q, y_dflux_t, y_dflux_q) + s y_flux_t, y_flux_q, y_dflux_t, y_dflux_q, + s y_fqcalving,y_ffonte,y_run_off_lic_0) +c +c calculer la longueur de rugosite sur ocean + yrugm=0. + IF (nsrf.EQ.is_oce) THEN + DO j = 1, knon + yrugm(j) = 0.018*ycoefm(j,1) * (yu1(j)**2+yv1(j)**2)/RG + $ + 0.11*14e-6 / sqrt(ycoefm(j,1) * (yu1(j)**2+yv1(j)**2)) + yrugm(j) = MAX(1.5e-05,yrugm(j)) + ENDDO + ENDIF + DO j = 1, knon + y_dflux_t(j) = y_dflux_t(j) * ypct(j) + y_dflux_q(j) = y_dflux_q(j) * ypct(j) + yu1(j) = yu1(j) * ypct(j) + yv1(j) = yv1(j) * ypct(j) + ENDDO +c + DO k = 1, klev + DO j = 1, knon + i = ni(j) + ycoefh(j,k) = ycoefh(j,k) * ypct(j) + ycoefm(j,k) = ycoefm(j,k) * ypct(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) +C§§§ PB + 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) +c$$$ PB y_flux_t(j,k) = y_flux_t(j,k) * ypct(j) +c$$$ PB y_flux_q(j,k) = y_flux_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) +c$$$ PB y_flux_u(j,k) = y_flux_u(j,k) * ypct(j) +c$$$ PB y_flux_v(j,k) = y_flux_v(j,k) * ypct(j) + ENDDO + ENDDO + + + evap(:,nsrf) = - flux_q(:,1,nsrf) +c + albe(:, nsrf) = 0. + alblw(:, 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) + albe(i,nsrf) = yalb(j) + alblw(i,nsrf) = yalblw(j) + snow(i,nsrf) = ysnow(j) + qsurf(i,nsrf) = yqsurf(j) + rugos(i,nsrf) = yz0_new(j) + fluxlat(i,nsrf) = yfluxlat(j) +c$$$ pb rugmer(i) = yrugm(j) + IF (nsrf .EQ. is_oce) then + rugmer(i) = yrugm(j) + rugos(i,nsrf) = yrugm(j) + endif +cIM cf JLD ?? + fqcalving(i,nsrf) = y_fqcalving(j) + ffonte(i,nsrf) = y_ffonte(j) + cdragh(i) = cdragh(i) + ycoefh(j,1) + cdragm(i) = cdragm(i) + ycoefm(j,1) + dflux_t(i) = dflux_t(i) + y_dflux_t(j) + dflux_q(i) = dflux_q(i) + y_dflux_q(j) + zu1(i) = zu1(i) + yu1(j) + zv1(i) = zv1(i) + yv1(j) + END DO + IF ( nsrf .eq. is_ter ) THEN + DO j = 1, knon + i = ni(j) + qsol(i) = yqsol(j) + END DO + END IF + IF ( nsrf .eq. is_lic ) THEN + DO j = 1, knon + i = ni(j) + run_off_lic_0(i) = y_run_off_lic_0(j) + END DO + END IF +c$$$ PB ajout pour soil + 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 +c +#ifdef CRAY + DO k = 1, klev + DO j = 1, knon + i = ni(j) +#else + DO j = 1, knon + i = ni(j) + DO k = 1, klev +#endif + 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) +c$$$ PB flux_t(i,k) = flux_t(i,k) + y_flux_t(j,k) +c$$$ flux_q(i,k) = flux_q(i,k) + y_flux_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) +c$$$ PB flux_u(i,k) = flux_u(i,k) + y_flux_u(j,k) +c$$$ flux_v(i,k) = flux_v(i,k) + y_flux_v(j,k) + zcoefh(i,k) = zcoefh(i,k) + ycoefh(j,k) + ENDDO + ENDDO +c +c +#undef T2m +#define T2m +#ifdef T2m +ccc diagnostic t,q a 2m et u, v a 10m +c + 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) +c + qairsol(j) = yqsurf(j) +c$$$ IF (nsrf.EQ.1) THEN +c$$$ qairsol(j) = yqsurf(j) +c$$$ ELSE IF(nsrf.GT.1) THEN +c$$$ zt = ts(i,nsrf) +c$$$ IF (thermcep) THEN +c$$$ zdelta = MAX(0.,SIGN(1.,RTT-zt)) +c$$$ zqs = R2ES * FOEEW(zt,zdelta) / ypplay(j,1) +c$$$ zqs = MIN(0.5,zqs) +c$$$ zcor = 1./(1.-RETV*zqs) +c$$$ zqs = zqs*zcor +c$$$ ELSE +c$$$ IF (zt .LT. t_coup) THEN +c$$$ zqs = qsats(zt) / ypplay(j,1) +c$$$ ELSE +c$$$ zqs = qsatl(zt) / ypplay(j,1) +c$$$ ENDIF +c$$$ ENDIF +c$$$ qairsol(j) = zqs +c$$$ ENDIF + ENDDO +c + if (check) THEN + WRITE(*,*)' avant stdlevvar. nsrf=',nsrf + IF(nsrf.EQ.3) THEN + j=1465 + WRITE(*,*)' INstO',klon,knon,nsrf,zxli,uzon(j),vmer(j), + & tair1(j),qair1(j),zgeo1(j),tairsol(j),qairsol(j),rugo1(j), + & psfce(j),patm(j) + ENDIF + WRITE(*,*)' qairsol (min, max)' + $ , minval(qairsol(1:knon)), maxval(qairsol(1:knon)) + call flush(6) + ENDIF +c + CALL stdlevvar(klon, knon, nsrf, zxli, + & uzon, vmer, tair1, qair1, zgeo1, + & tairsol, qairsol, rugo1, psfce, patm, + & yt2m, yq2m, yu10m) + +c + if (check) THEN + IF(nsrf.EQ.3) THEN + j=1465 + WRITE(*,*)' OUstd',klon,knon,nsrf,zxli,uzon(j),vmer(j), + & tair1(j),qair1(j),zgeo1(j),tairsol(j),qairsol(j),rugo1(j), + & psfce(j),patm(j) + WRITE(*,*)' tqu',yt2m(j),yq2m(j),yu10m(j) + call flush(6) + ENDIF + ENDIF +c + DO j=1, knon + i = ni(j) + t2m(i,nsrf)=yt2m(j) + + if (check) THEN + IF(nsrf.EQ.3 .and. j.EQ.1465) THEN + WRITE(*,*) 't2m APRES stdlev',j,i,tair1(j),t2m(i,nsrf), + $ tairsol(j),rlon(i),rlat(i) + call flush(6) + ENDIF + ENDIF +c + q2m(i,nsrf)=yq2m(j) +c +c 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) +c + ENDDO +#else + DO j=1, knon + i = ni(j) + t2m(i,nsrf)=0. + q2m(i,nsrf)=0. + u10m(i,nsrf)=0. + v10m(i,nsrf)=0. + ENDDO +#endif +99999 CONTINUE +c +C +C On utilise les nouvelles surfaces +C A rajouter: conservation de l'albedo +C + rugos(:,is_oce) = rugmer + pctsrf = pctsrf_new + + RETURN + END + SUBROUTINE clqh(dtime,itime, date0,jour,debut,lafin, + e rlon, rlat, cufi, cvfi, + e knon, nisurf, knindex, pctsrf, + $ soil_model,tsoil,qsol, + e ok_veget, ocean, npas, nexca, + e rmu0, co2_ppm, rugos, rugoro, + e u1lay,v1lay,coef, + e t,q,ts,paprs,pplay, + e delp,radsol,albedo,alblw,snow,qsurf, + e precip_rain, precip_snow, fder, taux, tauy, + $ sollw, sollwdown, swnet,fluxlat, + s pctsrf_new, agesno, + s d_t, d_q, d_ts, z0_new, +cIM cf JLD s flux_t, flux_q,dflux_s,dflux_l) + s flux_t, flux_q,dflux_s,dflux_l, + s fqcalving,ffonte,run_off_lic_0) + + USE interface_surf + + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: diffusion verticale de "q" et de "h" +c====================================================================== +#include "dimensions.h" +#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +#include "indicesol.h" +#include "dimsoil.h" + +c Arguments: + INTEGER knon + REAL dtime ! intervalle du temps (s) + real date0 + REAL u1lay(klon) ! vitesse u de la 1ere couche (m/s) + REAL v1lay(klon) ! vitesse v de la 1ere couche (m/s) + REAL coef(klon,klev) ! le coefficient d'echange (m**2/s) +c multiplie par le cisaillement du +c vent (dV/dz); la premiere valeur +c indique la valeur de Cdrag (sans unite) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (kg/kg) + REAL ts(klon) ! temperature du sol (K) + REAL evap(klon) ! evaporation au sol + REAL paprs(klon,klev+1) ! pression a inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) + REAL delp(klon,klev) ! epaisseur de couche en pression (Pa) + REAL radsol(klon) ! ray. net au sol (Solaire+IR) W/m2 + REAL albedo(klon) ! albedo de la surface + REAL alblw(klon) + REAL snow(klon) ! hauteur de neige + REAL qsurf(klon) ! humidite de l'air au dessus de la surface + real precip_rain(klon), precip_snow(klon) + REAL agesno(klon) + REAL rugoro(klon) + REAL run_off_lic_0(klon)! runof glacier au pas de temps precedent + integer jour ! jour de l'annee en cours + real rmu0(klon) ! cosinus de l'angle solaire zenithal + real rugos(klon) ! rugosite + integer knindex(klon) + real pctsrf(klon,nbsrf) + real rlon(klon), rlat(klon), cufi(klon), cvfi(klon) + logical ok_veget + REAL co2_ppm ! taux CO2 atmosphere + character*6 ocean + integer npas, nexca + +c + REAL d_t(klon,klev) ! incrementation de "t" + REAL d_q(klon,klev) ! incrementation de "q" + REAL d_ts(klon) ! incrementation de "ts" + REAL flux_t(klon,klev) ! (diagnostic) flux de la chaleur +c sensible, flux de Cp*T, positif vers +c le bas: j/(m**2 s) c.a.d.: W/m2 + REAL flux_q(klon,klev) ! flux de la vapeur d'eau:kg/(m**2 s) + REAL dflux_s(klon) ! derivee du flux sensible dF/dTs + REAL dflux_l(klon) ! derivee du flux latent dF/dTs +cIM cf JLD +c Flux thermique utiliser pour fondre la neige + REAL ffonte(klon) +c Flux d'eau "perdue" par la surface et nécessaire pour que limiter la +c hauteur de neige, en kg/m2/s + REAL fqcalving(klon) +c====================================================================== + REAL t_grnd ! temperature de rappel pour glace de mer + PARAMETER (t_grnd=271.35) + REAL t_coup + PARAMETER(t_coup=273.15) +c====================================================================== + INTEGER i, k + REAL zx_cq(klon,klev) + REAL zx_dq(klon,klev) + REAL zx_ch(klon,klev) + REAL zx_dh(klon,klev) + REAL zx_buf1(klon) + REAL zx_buf2(klon) + REAL zx_coef(klon,klev) + REAL local_h(klon,klev) ! enthalpie potentielle + REAL local_q(klon,klev) + REAL local_ts(klon) + REAL psref(klon) ! pression de reference pour temperature potent. + REAL zx_pkh(klon,klev), zx_pkf(klon,klev) +c====================================================================== +c contre-gradient pour la vapeur d'eau: (kg/kg)/metre + REAL gamq(klon,2:klev) +c contre-gradient pour la chaleur sensible: Kelvin/metre + REAL gamt(klon,2:klev) + REAL z_gamaq(klon,2:klev), z_gamah(klon,2:klev) + REAL zdelz +c====================================================================== + logical contreg + parameter (contreg=.true.) +c====================================================================== +c Rajout pour l'interface + integer itime + integer nisurf + logical debut, lafin + real zlev1(klon) + real fder(klon), taux(klon), tauy(klon) + real temp_air(klon), spechum(klon) + real epot_air(klon), ccanopy(klon) + real tq_cdrag(klon), petAcoef(klon), peqAcoef(klon) + real petBcoef(klon), peqBcoef(klon) + real sollw(klon), sollwdown(klon), swnet(klon), swdown(klon) + real p1lay(klon) +c$$$C PB ajout pour soil + LOGICAL soil_model + REAL tsoil(klon, nsoilmx) + REAL qsol(klon) + +! Parametres de sortie + real fluxsens(klon), fluxlat(klon) + real tsol_rad(klon), tsurf_new(klon), alb_new(klon) + real emis_new(klon), z0_new(klon) + real pctsrf_new(klon,nbsrf) +c JLD + real zzpk +C + character (len = 20) :: modname = 'Debut clqh' + LOGICAL check + PARAMETER (check=.false.) +C + if (check) THEN + write(*,*) modname,' nisurf=',nisurf + call flush(6) + endif +c + if (check) THEN + WRITE(*,*)' qsurf (min, max)' + $ , minval(qsurf(1:knon)), maxval(qsurf(1:knon)) + call flush(6) + ENDIF +C + if (.not. contreg) then + do k = 2, klev + do i = 1, knon + gamq(i,k) = 0.0 + gamt(i,k) = 0.0 + enddo + enddo + else + do k = 3, klev + do i = 1, knon + gamq(i,k)= 0.0 + gamt(i,k)= -1.0e-03 + enddo + enddo + do i = 1, knon + gamq(i,2) = 0.0 + gamt(i,2) = -2.5e-03 + enddo + endif + + DO i = 1, knon + psref(i) = paprs(i,1) !pression de reference est celle au sol + local_ts(i) = ts(i) + ENDDO + DO k = 1, klev + DO i = 1, knon + zx_pkh(i,k) = (psref(i)/paprs(i,k))**RKAPPA + zx_pkf(i,k) = (psref(i)/pplay(i,k))**RKAPPA + local_h(i,k) = RCPD * t(i,k) * zx_pkf(i,k) + local_q(i,k) = q(i,k) + ENDDO + ENDDO +c +c Convertir les coefficients en variables convenables au calcul: +c +c + DO k = 2, klev + DO i = 1, knon + 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 +c +c Preparer les flux lies aux contre-gardients +c + DO k = 2, klev + DO i = 1, knon + zdelz = RD * (t(i,k-1)+t(i,k))/2.0 / RG /paprs(i,k) + . *(pplay(i,k-1)-pplay(i,k)) + z_gamaq(i,k) = gamq(i,k) * zdelz + z_gamah(i,k) = gamt(i,k) * zdelz *RCPD * zx_pkh(i,k) + ENDDO + ENDDO + DO i = 1, knon + zx_buf1(i) = zx_coef(i,klev) + delp(i,klev) + zx_cq(i,klev) = (local_q(i,klev)*delp(i,klev) + . -zx_coef(i,klev)*z_gamaq(i,klev))/zx_buf1(i) + zx_dq(i,klev) = zx_coef(i,klev) / zx_buf1(i) +c + zzpk=(pplay(i,klev)/psref(i))**RKAPPA + zx_buf2(i) = zzpk*delp(i,klev) + zx_coef(i,klev) + zx_ch(i,klev) = (local_h(i,klev)*zzpk*delp(i,klev) + . -zx_coef(i,klev)*z_gamah(i,klev))/zx_buf2(i) + zx_dh(i,klev) = zx_coef(i,klev) / zx_buf2(i) + ENDDO + DO k = klev-1, 2 , -1 + DO i = 1, knon + zx_buf1(i) = delp(i,k)+zx_coef(i,k) + . +zx_coef(i,k+1)*(1.-zx_dq(i,k+1)) + zx_cq(i,k) = (local_q(i,k)*delp(i,k) + . +zx_coef(i,k+1)*zx_cq(i,k+1) + . +zx_coef(i,k+1)*z_gamaq(i,k+1) + . -zx_coef(i,k)*z_gamaq(i,k))/zx_buf1(i) + zx_dq(i,k) = zx_coef(i,k) / zx_buf1(i) +c + zzpk=(pplay(i,k)/psref(i))**RKAPPA + zx_buf2(i) = zzpk*delp(i,k)+zx_coef(i,k) + . +zx_coef(i,k+1)*(1.-zx_dh(i,k+1)) + zx_ch(i,k) = (local_h(i,k)*zzpk*delp(i,k) + . +zx_coef(i,k+1)*zx_ch(i,k+1) + . +zx_coef(i,k+1)*z_gamah(i,k+1) + . -zx_coef(i,k)*z_gamah(i,k))/zx_buf2(i) + zx_dh(i,k) = zx_coef(i,k) / zx_buf2(i) + ENDDO + ENDDO +C +C nouvelle formulation JL Dufresne +C +C q1 = zx_cq(i,1) + zx_dq(i,1) * Flux_Q(i,1) * dt +C h1 = zx_ch(i,1) + zx_dh(i,1) * Flux_H(i,1) * dt +C + DO i = 1, knon + zx_buf1(i) = delp(i,1) + zx_coef(i,2)*(1.-zx_dq(i,2)) + zx_cq(i,1) = (local_q(i,1)*delp(i,1) + . +zx_coef(i,2)*(z_gamaq(i,2)+zx_cq(i,2))) + . /zx_buf1(i) + zx_dq(i,1) = -1. * RG / zx_buf1(i) +c + zzpk=(pplay(i,1)/psref(i))**RKAPPA + zx_buf2(i) = zzpk*delp(i,1) + zx_coef(i,2)*(1.-zx_dh(i,2)) + zx_ch(i,1) = (local_h(i,1)*zzpk*delp(i,1) + . +zx_coef(i,2)*(z_gamah(i,2)+zx_ch(i,2))) + . /zx_buf2(i) + zx_dh(i,1) = -1. * RG / zx_buf2(i) + ENDDO + +C Appel a interfsurf (appel generique) routine d'interface avec la surface + +c initialisation + petAcoef =0. + peqAcoef = 0. + petBcoef =0. + peqBcoef = 0. + p1lay =0. + +c do i = 1, knon + petAcoef(1:knon) = zx_ch(1:knon,1) + peqAcoef(1:knon) = zx_cq(1:knon,1) + petBcoef(1:knon) = zx_dh(1:knon,1) + peqBcoef(1:knon) = zx_dq(1:knon,1) + tq_cdrag(1:knon) =coef(1:knon,1) + temp_air(1:knon) =t(1:knon,1) + epot_air(1:knon) =local_h(1:knon,1) + spechum(1:knon)=q(1:knon,1) + p1lay(1:knon) = pplay(1:knon,1) + zlev1(1:knon) = delp(1:knon,1) +c swnet = swdown * (1. - albedo) + swdown(1:knon) = swnet(1:knon) +c enddo + ccanopy = co2_ppm + + CALL interfsurf(itime, dtime, date0, jour, rmu0, + e klon, iim, jjm, nisurf, knon, knindex, pctsrf, + e rlon, rlat, cufi, cvfi, + e debut, lafin, ok_veget, soil_model, nsoilmx,tsoil, qsol, + e zlev1, u1lay, v1lay, temp_air, spechum, epot_air, ccanopy, + e tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, + e precip_rain, precip_snow, sollw, sollwdown, swnet, swdown, + e fder, taux, tauy, rugos, rugoro, + e albedo, snow, qsurf, + e ts, p1lay, psref, radsol, + e ocean, npas, nexca, zmasq, + s evap, fluxsens, fluxlat, dflux_l, dflux_s, + s tsol_rad, tsurf_new, alb_new, alblw, emis_new, z0_new, +cIM cf JLD s pctsrf_new, agesno) + s pctsrf_new, agesno,fqcalving,ffonte, run_off_lic_0) + + + do i = 1, knon + flux_t(i,1) = fluxsens(i) + flux_q(i,1) = - evap(i) + d_ts(i) = tsurf_new(i) - ts(i) + albedo(i) = alb_new(i) + enddo + +c==== une fois on a zx_h_ts, on peut faire l'iteration ======== + DO i = 1, knon + local_h(i,1) = zx_ch(i,1) + zx_dh(i,1)*flux_t(i,1)*dtime + local_q(i,1) = zx_cq(i,1) + zx_dq(i,1)*flux_q(i,1)*dtime + ENDDO + DO k = 2, klev + DO i = 1, knon + local_q(i,k) = zx_cq(i,k) + zx_dq(i,k)*local_q(i,k-1) + local_h(i,k) = zx_ch(i,k) + zx_dh(i,k)*local_h(i,k-1) + ENDDO + ENDDO +c====================================================================== +c== flux_q est le flux de vapeur d'eau: kg/(m**2 s) positive vers bas +c== flux_t est le flux de cpt (energie sensible): j/(m**2 s) + DO k = 2, klev + DO i = 1, knon + flux_q(i,k) = (zx_coef(i,k)/RG/dtime) + . * (local_q(i,k)-local_q(i,k-1)+z_gamaq(i,k)) + flux_t(i,k) = (zx_coef(i,k)/RG/dtime) + . * (local_h(i,k)-local_h(i,k-1)+z_gamah(i,k)) + . / zx_pkh(i,k) + ENDDO + ENDDO +c====================================================================== +C Calcul tendances + DO k = 1, klev + DO i = 1, knon + d_t(i,k) = local_h(i,k)/zx_pkf(i,k)/RCPD - t(i,k) + d_q(i,k) = local_q(i,k) - q(i,k) + ENDDO + ENDDO +c + + RETURN + END + SUBROUTINE clvent(knon,dtime, u1lay,v1lay,coef,t,ven, + e paprs,pplay,delp, + s d_ven,flux_v) + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: diffusion vertical de la vitesse "ven" +c====================================================================== +c Arguments: +c dtime----input-R- intervalle du temps (en second) +c u1lay----input-R- vent u de la premiere couche (m/s) +c v1lay----input-R- vent v de la premiere couche (m/s) +c coef-----input-R- le coefficient d'echange (m**2/s) multiplie par +c le cisaillement du vent (dV/dz); la premiere +c valeur indique la valeur de Cdrag (sans unite) +c t--------input-R- temperature (K) +c ven------input-R- vitesse horizontale (m/s) +c paprs----input-R- pression a inter-couche (Pa) +c pplay----input-R- pression au milieu de couche (Pa) +c delp-----input-R- epaisseur de couche (Pa) +c +c +c d_ven----output-R- le changement de "ven" +c flux_v---output-R- (diagnostic) flux du vent: (kg m/s)/(m**2 s) +c====================================================================== +#include "dimensions.h" +#include "dimphy.h" + INTEGER knon + REAL dtime + REAL u1lay(klon), v1lay(klon) + REAL coef(klon,klev) + REAL t(klon,klev), ven(klon,klev) + REAL paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev) + REAL d_ven(klon,klev) + REAL flux_v(klon,klev) +c====================================================================== +#include "YOMCST.h" +c====================================================================== + INTEGER i, k + REAL zx_cv(klon,2:klev) + REAL zx_dv(klon,2:klev) + REAL zx_buf(klon) + REAL zx_coef(klon,klev) + REAL local_ven(klon,klev) + REAL zx_alf1(klon), zx_alf2(klon) +c====================================================================== + DO k = 1, klev + DO i = 1, knon + local_ven(i,k) = ven(i,k) + ENDDO + ENDDO +c====================================================================== + DO i = 1, knon +ccc zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2)) + zx_alf1(i) = 1.0 + zx_alf2(i) = 1.0 - zx_alf1(i) + zx_coef(i,1) = coef(i,1) + . * (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 +c====================================================================== + DO k = 2, klev + DO i = 1, knon + 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 +c====================================================================== + DO i = 1, knon + zx_buf(i) = delp(i,1) + zx_coef(i,1)*zx_alf1(i)+zx_coef(i,2) + zx_cv(i,2) = local_ven(i,1)*delp(i,1) / zx_buf(i) + zx_dv(i,2) = (zx_coef(i,2)-zx_alf2(i)*zx_coef(i,1)) + . /zx_buf(i) + ENDDO + DO k = 3, klev + DO i = 1, knon + zx_buf(i) = delp(i,k-1) + zx_coef(i,k) + . + zx_coef(i,k-1)*(1.-zx_dv(i,k-1)) + zx_cv(i,k) = (local_ven(i,k-1)*delp(i,k-1) + . +zx_coef(i,k-1)*zx_cv(i,k-1) )/zx_buf(i) + zx_dv(i,k) = zx_coef(i,k)/zx_buf(i) + ENDDO + ENDDO + DO i = 1, knon + local_ven(i,klev) = ( local_ven(i,klev)*delp(i,klev) + . +zx_coef(i,klev)*zx_cv(i,klev) ) + . / ( delp(i,klev) + zx_coef(i,klev) + . -zx_coef(i,klev)*zx_dv(i,klev) ) + ENDDO + DO k = klev-1, 1, -1 + DO i = 1, knon + local_ven(i,k) = zx_cv(i,k+1) + zx_dv(i,k+1)*local_ven(i,k+1) + ENDDO + ENDDO +c====================================================================== +c== flux_v est le flux de moment angulaire (positif vers bas) +c== dont l'unite est: (kg m/s)/(m**2 s) + DO i = 1, knon + flux_v(i,1) = zx_coef(i,1)/(RG*dtime) + . *(local_ven(i,1)*zx_alf1(i) + . +local_ven(i,2)*zx_alf2(i)) + ENDDO + DO k = 2, klev + DO i = 1, knon + flux_v(i,k) = zx_coef(i,k)/(RG*dtime) + . * (local_ven(i,k)-local_ven(i,k-1)) + ENDDO + ENDDO +c + DO k = 1, klev + DO i = 1, knon + d_ven(i,k) = local_ven(i,k) - ven(i,k) + ENDDO + ENDDO +c + RETURN + END + SUBROUTINE coefkz(nsrf, knon, paprs, pplay, +cIM 261103 + . ksta, ksta_ter, +cIM 261103 + . ts, rugos, + . u,v,t,q, + . qsurf, + . pcfm, pcfh) + IMPLICIT none +c====================================================================== +c Auteur(s) F. Hourdin, M. Forichon, Z.X. Li (LMD/CNRS) date: 19930922 +c (une version strictement identique a l'ancien modele) +c Objet: calculer le coefficient du frottement du sol (Cdrag) et les +c coefficients d'echange turbulent dans l'atmosphere. +c Arguments: +c nsrf-----input-I- indicateur de la nature du sol +c knon-----input-I- nombre de points a traiter +c paprs----input-R- pression a chaque intercouche (en Pa) +c pplay----input-R- pression au milieu de chaque couche (en Pa) +c ts-------input-R- temperature du sol (en Kelvin) +c rugos----input-R- longeur de rugosite (en m) +c u--------input-R- vitesse u +c v--------input-R- vitesse v +c t--------input-R- temperature (K) +c q--------input-R- vapeur d'eau (kg/kg) +c +c itop-----output-I- numero de couche du sommet de la couche limite +c pcfm-----output-R- coefficients a calculer (vitesse) +c pcfh-----output-R- coefficients a calculer (chaleur et humidite) +c====================================================================== +#include "dimensions.h" +#include "dimphy.h" +#include "YOMCST.h" +#include "indicesol.h" +c +c Arguments: +c + INTEGER knon, nsrf + REAL ts(klon) + REAL paprs(klon,klev+1), pplay(klon,klev) + REAL u(klon,klev), v(klon,klev), t(klon,klev), q(klon,klev) + REAL rugos(klon) +c + REAL pcfm(klon,klev), pcfh(klon,klev) + INTEGER itop(klon) +c +c Quelques constantes et options: +c + REAL cepdu2, ckap, cb, cc, cd, clam + PARAMETER (cepdu2 =(0.1)**2) + PARAMETER (CKAP=0.4) + PARAMETER (cb=5.0) + PARAMETER (cc=5.0) + PARAMETER (cd=5.0) + PARAMETER (clam=160.0) + REAL ratqs ! largeur de distribution de vapeur d'eau + PARAMETER (ratqs=0.05) + LOGICAL richum ! utilise le nombre de Richardson humide + PARAMETER (richum=.TRUE.) + REAL ric ! nombre de Richardson critique + PARAMETER(ric=0.4) + REAL prandtl + PARAMETER (prandtl=0.4) + REAL kstable ! diffusion minimale (situation stable) + ! GKtest + ! PARAMETER (kstable=1.0e-10) + REAL ksta, ksta_ter +cIM: 261103 REAL kstable_ter, kstable_sinon +cIM: 211003 cf GK PARAMETER (kstable_ter = 1.0e-6) +cIM: 261103 PARAMETER (kstable_ter = 1.0e-8) +cIM: 261103 PARAMETER (kstable_ter = 1.0e-10) +cIM: 261103 PARAMETER (kstable_sinon = 1.0e-10) + ! fin GKtest + REAL mixlen ! constante controlant longueur de melange + PARAMETER (mixlen=35.0) + INTEGER isommet ! le sommet de la couche limite + PARAMETER (isommet=klev) + LOGICAL tvirtu ! calculer Ri d'une maniere plus performante + PARAMETER (tvirtu=.TRUE.) + LOGICAL opt_ec ! formule du Centre Europeen dans l'atmosphere + PARAMETER (opt_ec=.FALSE.) + LOGICAL contreg ! utiliser le contre-gradient dans Ri + PARAMETER (contreg=.TRUE.) +c +c Variables locales: +c + INTEGER i, k + REAL zgeop(klon,klev) + REAL zmgeom(klon) + REAL zri(klon) + REAL zl2(klon) + + REAL u1(klon), v1(klon), t1(klon), q1(klon), z1(klon) + REAL pcfm1(klon), pcfh1(klon) +c + REAL zdphi, zdu2, ztvd, ztvu, zcdn + REAL zscf + REAL zt, zq, zdelta, zcvm5, zcor, zqs, zfr, zdqs + REAL z2geomf, zalh2, zalm2, zscfh, zscfm + REAL t_coup + PARAMETER (t_coup=273.15) +cIM + LOGICAL check + PARAMETER (check=.false.) +c +c contre-gradient pour la chaleur sensible: Kelvin/metre + REAL gamt(2:klev) + real qsurf(klon) +c + LOGICAL appel1er + SAVE appel1er +c +c Fonctions thermodynamiques et fonctions d'instabilite + REAL fsta, fins, x + LOGICAL zxli ! utiliser un jeu de fonctions simples + PARAMETER (zxli=.FALSE.) +c +#include "YOETHF.h" +#include "FCTTRE.h" + fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x)) + fins(x) = SQRT(1.0-18.0*x) +c + DATA appel1er /.TRUE./ +c + IF (appel1er) THEN + PRINT*, 'coefkz, opt_ec:', opt_ec + PRINT*, 'coefkz, richum:', richum + IF (richum) PRINT*, 'coefkz, ratqs:', ratqs + PRINT*, 'coefkz, isommet:', isommet + PRINT*, 'coefkz, tvirtu:', tvirtu + appel1er = .FALSE. + ENDIF +c +c Initialiser les sorties +c + 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 + +c$$$ IF(nsrf.NE.1) THEN +c$$$ do i = 1, knon +c$$$ qsurf(i) = qsatl(ts(i))/paprs(i,1) +c$$$ enddo +c$$$ ENDIF + +c +c Prescrire la valeur de contre-gradient +c + IF (.NOT.contreg) THEN + DO k = 2, klev + gamt(k) = 0.0 + ENDDO + ELSE + DO k = 3, klev + gamt(k) = -1.0E-03 + ENDDO + gamt(2) = -2.5E-03 + ENDIF +cIM cf JLD/ GKtest + IF ( nsrf .NE. is_oce ) THEN +cIM 261103 kstable = kstable_ter + kstable = ksta_ter + ELSE +cIM 261103 kstable = kstable_sinon + kstable = ksta + ENDIF +cIM cf JLD/ GKtest fin +c +c Calculer les geopotentiels de chaque couche +c + 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 +c +c Calculer le frottement au sol (Cdrag) +c + DO i = 1, knon + u1(i) = u(i,1) + v1(i) = v(i,1) + t1(i) = t(i,1) + q1(i) = q(i,1) + z1(i) = zgeop(i,1) + ENDDO +c + CALL clcdrag(klon, knon, nsrf, zxli, + $ u1, v1, t1, q1, z1, + $ ts, qsurf, rugos, + $ pcfm1, pcfh1) +cIM $ ts, qsurf, rugos, +C + DO i = 1, knon + pcfm(i,1)=pcfm1(i) + pcfh(i,1)=pcfh1(i) + ENDDO +c +c Calculer les coefficients turbulents dans l'atmosphere +c + DO i = 1, knon + itop(i) = isommet + ENDDO + + IF (check) THEN + PRINT*,' isommet=',isommet,' knon=',knon + ENDIF + + 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 +c +c calculer Qs et dQs/dT: +c + 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 +c +c calculer la fraction nuageuse (processus humide): +c + zfr = (zq+ratqs*zq-zqs) / (2.0*ratqs*zq) + zfr = MAX(0.0,MIN(1.0,zfr)) + IF (.NOT.richum) zfr = 0.0 +c +c calculer le nombre de Richardson: +c + 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)) +c + ELSE ! calcul de Ridchardson compatible LMD5 +c + 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 +cSB . /(paprs(i,k)/101325.0)**RKAPPA + . *(paprs(i,k)/101325.0)**RKAPPA + . /(zdu2*0.5*(t(i,k-1)+t(i,k))) + ENDIF +c +c finalement, les coefficients d'echange sont obtenus: +c + zcdn=SQRT(zdu2) / zmgeom(i) * RG +c + 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 +c +c Au-dela du sommet, pas de diffusion turbulente: +c + 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 +c + RETURN + END + + SUBROUTINE coefkz2(nsrf, knon, paprs, pplay,t, + . pcfm, pcfh) + IMPLICIT none +c====================================================================== +c J'introduit un peu de diffusion sauf dans les endroits +c ou une forte inversion est presente +c On peut dire qu'il represente la convection peu profonde +c +c Arguments: +c nsrf-----input-I- indicateur de la nature du sol +c knon-----input-I- nombre de points a traiter +c paprs----input-R- pression a chaque intercouche (en Pa) +c pplay----input-R- pression au milieu de chaque couche (en Pa) +c t--------input-R- temperature (K) +c +c pcfm-----output-R- coefficients a calculer (vitesse) +c pcfh-----output-R- coefficients a calculer (chaleur et humidite) +c====================================================================== +#include "dimensions.h" +#include "dimphy.h" +#include "YOMCST.h" +#include "indicesol.h" +c +c Arguments: +c + INTEGER knon, nsrf + REAL paprs(klon,klev+1), pplay(klon,klev) + REAL t(klon,klev) +c + REAL pcfm(klon,klev), pcfh(klon,klev) +c +c Quelques constantes et options: +c + REAL prandtl + PARAMETER (prandtl=0.4) + REAL kstable + PARAMETER (kstable=0.002) +ccc PARAMETER (kstable=0.001) + REAL mixlen ! constante controlant longueur de melange + PARAMETER (mixlen=35.0) + REAL seuil ! au-dela l'inversion est consideree trop faible + PARAMETER (seuil=-0.02) +ccc PARAMETER (seuil=-0.04) +ccc PARAMETER (seuil=-0.06) +ccc PARAMETER (seuil=-0.09) +c +c Variables locales: +c + INTEGER i, k, invb(knon) + REAL zl2(knon) + REAL zdthmin(knon), zdthdp +c +c Initialiser les sorties +c + DO k = 1, klev + DO i = 1, knon + pcfm(i,k) = 0.0 + pcfh(i,k) = 0.0 + ENDDO + ENDDO +c +c Chercher la zone d'inversion forte +c + 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 +c +c Introduire une diffusion: +c + DO k = 2, klev + DO i = 1, knon +cIM cf FH/GK IF ( (nsrf.NE.is_oce) .OR. ! si ce n'est pas sur l'ocean +cIM 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 + IF ( (nsrf.EQ.is_oce) .AND. ! si on est sur ocean et si + . ( (invb(i).EQ.klev) .OR. ! s'il n'y a pas d'inversion + . (zdthmin(i).GT.seuil) ) )THEN ! si l'inversion est trop faible + 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 +c + RETURN + END + SUBROUTINE calbeta(dtime,indice,knon,snow,qsol, + . vbeta,vcal,vdif) + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM du LMD) +c date: 19940414 +c====================================================================== +c +c Calculer quelques parametres pour appliquer la couche limite +c ------------------------------------------------------------ +#include "dimensions.h" +#include "dimphy.h" +#include "YOMCST.h" +#include "indicesol.h" + REAL tau_gl ! temps de relaxation pour la glace de mer +ccc PARAMETER (tau_gl=86400.0*30.0) + PARAMETER (tau_gl=86400.0*5.0) + REAL mx_eau_sol + PARAMETER (mx_eau_sol=150.0) +c + REAL calsol, calsno, calice ! epaisseur du sol: 0.15 m + PARAMETER (calsol=1.0/(2.5578E+06*0.15)) + PARAMETER (calsno=1.0/(2.3867E+06*0.15)) + PARAMETER (calice=1.0/(5.1444E+06*0.15)) +C + INTEGER i +c + REAL dtime + REAL snow(klon), qsol(klon) + INTEGER indice, knon +C + REAL vbeta(klon) + REAL vcal(klon) + REAL vdif(klon) +C + + IF (indice.EQ.is_oce) THEN + DO i = 1, knon + vcal(i) = 0.0 + vbeta(i) = 1.0 + vdif(i) = 0.0 + ENDDO + ENDIF +c + 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 +ccc vdif(i) = calice/tau_gl ! c'etait une erreur + ENDDO + ENDIF +c + 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 +c + 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 +c + RETURN + END +C====================================================================== + SUBROUTINE nonlocal(knon, paprs, pplay, + . tsol,beta,u,v,t,q, + . cd_h, cd_m, pcfh, pcfm, cgh, cgq) + 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 "dimensions.h" +#include "dimphy.h" +#include "YOMCST.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 + PARAMETER (isommet=klev) + 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 + 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/trunk/libf/phylmd/clouds_gno.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/clouds_gno.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/clouds_gno.F (revision 524) @@ -0,0 +1,248 @@ +! +! $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(klon), delta(klon), beta(klon) + real zu2(klon),zv2(klon) + REAL xx(klon), aux(klon), coeff(klon), block(klon) + REAL dist(klon), fprime(klon), det(klon) + REAL pi, u(klon), v(klon), erfcu(klon), erfcv(klon) + REAL xx1(klon), xx2(klon) + real erf,kkk + real sqrtpi,sqrt2,zx1,zx2,exdel +c lconv = true si le calcul a converge (entre autre si qsub < min_q) + LOGICAL lconv(klon) + + + pi = ACOS(-1.) + sqrtpi=sqrt(pi) + sqrt2=sqrt(2.) + + ptconv=.false. + ratqsc=0. + + + DO 500 K = 1, ND + + do i=1,klon ! vector + mu(i) = R(i,K) + mu(i) = MAX(mu(i),min_mu) + qsat(i) = RS(i,K) + qsat(i) = MAX(qsat(i),min_mu) + delta(i) = log(mu(i)/qsat(i)) + 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. + + 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(i) = delta(i) + vmax(i)**2. + if (det(i).LE.0.0) vmax(i) = vmax0 + 1.0 + det(i) = delta(i) + vmax(i)**2. + + if (det(i).LE.0.) then + xx(i) = -0.0001 + else + zx1=-sqrt2*vmax(i) + zx2=SQRT(1.0+delta(i)/(vmax(i)**2.)) + xx1(i)=zx1*(1.0-zx2) + xx2(i)=zx1*(1.0+zx2) + xx(i) = 1.01 * xx1(i) + if ( xx1(i) .GE. 0.0 ) xx(i) = 0.5*xx2(i) + endif + if (delta(i).LT.0.) xx(i) = -0.5*SQRT(log(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(i) = delta(i)/(xx(i)*sqrt2) + xx(i)/(2.*sqrt2) + v(i) = delta(i)/(xx(i)*sqrt2) - xx(i)/(2.*sqrt2) + + IF ( v(i) .GT. vmax(i) ) THEN + + IF ( ABS(u(i)) .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(i) = EXP(-v(i)*v(i)) / v(i) / sqrtpi + dist(i) = 0.0 + fprime(i) = 1.0 + + ELSE + +c -- erfv -> 1.0, use an asymptotic expression of erfv for v large: + + erfcu(i) = 1.0-ERF(u(i)) +c !!! ATTENTION : rajout d'un seuil pour l'exponentiel + aux(i) = sqrtpi*erfcu(i)*EXP(min(v(i)*v(i),100.)) + coeff(i) = 1.0 - 1./2./(v(i)**2.) + 3./4./(v(i)**4.) + block(i) = coeff(i) * EXP(-v(i)*v(i)) / v(i) / sqrtpi + dist(i) = v(i) * aux(i) / coeff(i) - beta(i) + fprime(i) = 2.0 / xx(i) * (v(i)**2.) + : * ( coeff(i)*EXP(-delta(i)) - u(i) * aux(i) ) + : / coeff(i) / coeff(i) + + ENDIF ! ABS(u) + + ELSE + +c -- general case: + + erfcu(i) = 1.0-ERF(u(i)) + erfcv(i) = 1.0-ERF(v(i)) + block(i) = erfcv(i) + dist(i) = erfcu(i) / erfcv(i) - beta(i) + zu2(i)=u(i)*u(i) + zv2(i)=v(i)*v(i) + if(zu2(i).gt.20..or. zv2(i).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(i)=20. + zv2(i)=20. + fprime(i) = 0. + else + fprime(i) = 2. /sqrtpi /xx(i) /erfcv(i)**2. + : * ( erfcv(i)*v(i)*EXP(-zu2(i)) + : - erfcu(i)*u(i)*EXP(-zv2(i)) ) + endif + ENDIF ! x + +c -- test numerical convergence: + +c print*,'avant test ',i,k,lconv(i),u(i),v(i) + if ( ABS(dist(i)/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(i)-u(i))**2,20.) + ratqsc(i,k)=sqrt(exp(ratqsc(i,k))-1.) + CLDF(i,K) = 0.5 * block(i) + else + xx(i) = xx(i) - dist(i)/fprime(i) + 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/trunk/libf/phylmd/cltrac.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/cltrac.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/cltrac.F (revision 524) @@ -0,0 +1,121 @@ +! +! $Header$ +! + SUBROUTINE cltrac(dtime,coef,t,tr,flux,paprs,pplay,delp, + s d_tr) + IMPLICIT none +c====================================================================== +c Auteur(s): O. Boucher (LOA/LMD) date: 19961127 +c inspire de clvent +c Objet: diffusion verticale de traceurs avec flux fixe a la surface +c ou/et flux du type c-drag +c====================================================================== +c Arguments: +c dtime----input-R- intervalle du temps (en second) +c coef-----input-R- le coefficient d'echange (m**2/s) l>1 +c t--------input-R- temperature (K) +c tr-------input-R- la q. de traceurs +c flux-----input-R- le flux de traceurs a la surface +c paprs----input-R- pression a inter-couche (Pa) +c pplay----input-R- pression au milieu de couche (Pa) +c delp-----input-R- epaisseur de couche (Pa) +c cdrag----input-R- cdrag pour le flux de surface (non active) +c tr0------input-R- traceurs a la surface ou dans l'ocean (non active) +c d_tr-----output-R- le changement de tr +c flux_tr--output-R- flux de tr +c====================================================================== +#include "dimensions.h" +#include "dimphy.h" + REAL dtime + REAL coef(klon,klev) + REAL t(klon,klev), tr(klon,klev) + REAL paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev) + REAL d_tr(klon,klev) + REAL flux(klon), cdrag(klon), tr0(klon) +c REAL flux_tr(klon,klev) +c====================================================================== +#include "YOMCST.h" +c====================================================================== + INTEGER i, k + REAL zx_ctr(klon,2:klev) + REAL zx_dtr(klon,2:klev) + REAL zx_buf(klon) + REAL zx_coef(klon,klev) + REAL local_tr(klon,klev) + REAL zx_alf1(klon), zx_alf2(klon), zx_flux(klon) +c====================================================================== + DO k = 1, klev + DO i = 1, klon + local_tr(i,k) = tr(i,k) + ENDDO + ENDDO +c + +c====================================================================== + 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 +c--pour le moment le flux est prescrit +c--cdrag et zx_coef(1) vaut 0 + cdrag(i) = 0.0 + tr0(i) = 0.0 + zx_coef(i,1) = cdrag(i)*dtime*RG + ENDDO +c====================================================================== + 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 +c====================================================================== + 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 +c + 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 +c====================================================================== +c== flux_tr est le flux de traceur (positif vers bas) +c DO i = 1, klon +c flux_tr(i,1) = zx_coef(i,1)/(RG*dtime) +c ENDDO +c DO k = 2, klev +c DO i = 1, klon +c flux_tr(i,k) = zx_coef(i,k)/(RG*dtime) +c . * (local_tr(i,k)-local_tr(i,k-1)) +c ENDDO +c ENDDO +c====================================================================== + DO k = 1, klev + DO i = 1, klon + d_tr(i,k) = local_tr(i,k) - tr(i,k) + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/trunk/libf/phylmd/cltracrn.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/cltracrn.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/cltracrn.F (revision 524) @@ -0,0 +1,293 @@ +! +! $Header$ +! + SUBROUTINE cltracrn( itr, dtime,u1lay, v1lay, + e coef,t,ftsol,pctsrf, + e tr,trs,paprs,pplay,delp, + e masktr,fshtr,hsoltr,tautr,vdeptr, + e lat, + s d_tr,d_trs ) + + IMPLICIT none +c====================================================================== +c Auteur(s): Alex/LMD) date: fev 99 +c inspire de clqh + clvent +c Objet: diffusion verticale de traceurs avec quantite de traceur ds +c le sol ( reservoir de sol de radon ) +c +c note : pour l'instant le traceur dans le sol et le flux sont +c calcules mais ils ne servent que de diagnostiques +c seule la tendance sur le traceur est sortie (d_tr) +c====================================================================== +c Arguments: +c itr--- -input-R- le type de traceur 1- Rn 2 - Pb +c dtime----input-R- intervalle du temps (en second) +c u1lay----input-R- vent u de la premiere couche (m/s) +c v1lay----input-R- vent v de la premiere couche (m/s) +c coef-----input-R- le coefficient d'echange (m**2/s) l>1 +c t--------input-R- temperature (K) +c paprs----input-R- pression a inter-couche (Pa) +c pplay----input-R- pression au milieu de couche (Pa) +c delp-----input-R- epaisseur de couche (Pa) +c ftsol----input-R- temperature du sol (en Kelvin) +c tr-------input-R- traceurs +c trs------input-R- traceurs dans le sol +c masktr---input-R- Masque reservoir de sol traceur (1 = reservoir) +c fshtr----input-R- Flux surfacique de production dans le sol +c tautr----input-R- Constante de decroissance du traceur +c vdeptr---input-R- Vitesse de depot sec dans la couche brownienne +c hsoltr---input-R- Epaisseur equivalente du reservoir de sol +c lat-----input-R- latitude en degree +c d_tr-----output-R- le changement de "tr" +c d_trs----output-R- le changement de "trs" +c====================================================================== +#include "dimensions.h" +#include "dimphy.h" +#include "YOMCST.h" +#include "indicesol.h" +c====================================================================== + REAL dtime + REAL u1lay(klon), v1lay(klon) + REAL coef(klon,klev) + REAL t(klon,klev), ftsol(klon,nbsrf), pctsrf(klon,nbsrf) + REAL tr(klon,klev), trs(klon) + REAL paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev) + REAL masktr(klon) + REAL fshtr(klon) + REAL hsoltr + REAL tautr + REAL vdeptr + REAL lat(klon) + REAL d_tr(klon,klev) +c====================================================================== + REAL flux_tr(klon,klev) ! (diagnostic) flux de traceur + REAL d_trs(klon) ! (diagnostic) traceur ds le sol +c====================================================================== + INTEGER i, k, itr, n, l + REAL rotrhi(klon) + REAL zx_coef(klon,klev) + REAL zx_buf(klon) + REAL zx_ctr(klon,klev) + REAL zx_dtr(klon,klev) + REAL zx_trs(klon) + REAL zx_a, zx_b + + REAL local_tr(klon,klev) + REAL local_trs(klon) + REAL zts(klon) + REAL zx_alpha1(klon), zx_alpha2(klon) +c====================================================================== +cAA Pour l'instant les 4 types de surface ne sont pas pris en compte +cAA On fabrique avec zts un champ de temperature de sol +cAA que le pondere par la fraction de nature de sol. +c + print*,'PASSAGE DANS CLTRACRN' + + DO i = 1,klon + zts(i) = 0. + ENDDO +c + DO n=1,nbsrf + DO i = 1,klon + zts(i) = zts(i) + ftsol(i,n)*pctsrf(i,n) + ENDDO + ENDDO +c + DO i = 1,klon + rotrhi(i) = RD * zts(i) / hsoltr + END DO +c + DO k = 1, klev + DO i = 1, klon + local_tr(i,k) = tr(i,k) + ENDDO + ENDDO +c + DO i = 1, klon + local_trs(i) = trs(i) + ENDDO +c====================================================================== +cAA Attention si dans clmain zx_alf1(i) = 1.0 +cAA Il doit y avoir coherence (dc la meme chose ici) + + DO i = 1, klon +cAA 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 +c====================================================================== + DO i = 1, klon + zx_coef(i,1) = coef(i,1) + . * (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 +c + 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 +c====================================================================== + 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 +c + 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 +c + 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 +c====================================================================== +c Calculer d'abord local_trs nouvelle quantite dans le reservoir +c de sol +c +c------------------------- +c Au dessus des continents +c------------------------- +c Le pb peut se deposer partout : vdeptr = 10-3 m/s +c Le Rn est traiter commme une couche Brownienne puisque vdeptr = 0. +c + DO i = 1, klon +c + 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)) + 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 +cAA: Pour l'instant, pour aller vite, le depot sec est traite +C comme une decroissance + . + dtime * vdeptr / hsoltr + zx_trs(i) = zx_a / zx_b + local_trs(i) = zx_trs(i) + ENDIF +c +c Si on est entre 60N et 70N on divise par 2 l'emanation +c-------------------------------------------------------- +c + 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 +c +c---------------------------------------------- +c Au dessus des oceans et aux hautes latitudes +c---------------------------------------------- +c +c au dessous de -60S pas d'emission de radon au dessus +c des oceans et des continents +c--------------------------------------------------------------- + + 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 + +c au dessus de 70 N pas d'emission de radon au dessus +c des oceans et des continents +c-------------------------------------------------------------- + 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 + +c Au dessus des oceans la source est nulle +c----------------------------------------- +c + IF (itr.eq.1.AND.NINT(masktr(i)).EQ.0) THEN + zx_trs(i) = 0. + local_trs(i) = 0. + END IF +c + ENDDO ! sur le i=1,klon +c +c====================================================================== +c==== une fois on a zx_trs, on peut faire l'iteration ======== +c + 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 +c====================================================================== +c== Calcul du flux de traceur (flux_tr): UA/(m**2 s) +c + 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 +c====================================================================== +c== Calcul des tendances du traceur ds le sol et dans l'atmosphere +c + 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 +c====================================================================== +c + RETURN + END Index: /LMDZ4/trunk/libf/phylmd/coefcdrag.F90 =================================================================== --- /LMDZ4/trunk/libf/phylmd/coefcdrag.F90 (revision 524) +++ /LMDZ4/trunk/libf/phylmd/coefcdrag.F90 (revision 524) @@ -0,0 +1,147 @@ +! +! $Header$ +! +! +! +! + 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.inc +! 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.inc" +#include "YOETHF.inc" +#include "indicesol.inc" +! Quelques constantes : + REAL, parameter :: RKAR=0.40, CB=5.0, CC=5.0, CD=5.0 +! +! 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) = 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/trunk/libf/phylmd/coefkzmin.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/coefkzmin.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/coefkzmin.F (revision 524) @@ -0,0 +1,144 @@ +! +! $Header$ +! + SUBROUTINE coefkzmin(ngrid,ypaprs,ypplay,yu,yv,yt,yq,ycoefm + . ,km,kn) +c SUBROUTINE coefkzmin(ngrid,zlev,teta,ustar,km,kn) + IMPLICIT NONE + +#include "dimensions.h" +#include "dimphy.h" +#include "YOMCST.h" + +c....................................................................... +c Entrees modifies en attendant une version ou les zlev, et zlay soient +c disponibles. + + REAL ycoefm(klon,klev) + + 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 l_mix,ngrid + + + integer nlay,nlev + PARAMETER (nlay=klev) + PARAMETER (nlev=klev+1) + + integer ig,k + + real kap + save kap + data kap/0.4/ + + real frif,falpha,fsm + real fl,zzz,zl0,zq2,zn2 + + +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,ngrid + 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,ngrid + 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,ngrid +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,ngrid + yzlev(i,1)=0. + yzlev(i,klev+1)=2.*yzlay(i,klev)-yzlay(i,klev-1) + enddo + do k=2,klev + do i=1,ngrid + yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1)) + enddo + enddo + + +cIM cf FH yustar(:) =SQRT(ycoefm(:,1)*(yu(:,1)*yu(:,1)+yv(:,1)*yv(:,1))) + yustar(1:ngrid) =SQRT(ycoefm(1:ngrid,1)* + $ (yu(1:ngrid,1)*yu(1:ngrid,1)+yv(1:ngrid,1)*yv(1:ngrid,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,ngrid + 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,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=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/trunk/libf/phylmd/comgeomphy.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/comgeomphy.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/comgeomphy.h (revision 524) @@ -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/trunk/libf/phylmd/conccm.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/conccm.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/conccm.F (revision 524) @@ -0,0 +1,833 @@ +! +! $Header$ +! + SUBROUTINE conccm (dtime,paprs,pplay,t,q,conv_q, + s d_t, d_q, rain, snow, kbascm, ktopcm) +c + 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====================================================================== +#include "dimensions.h" +#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) + 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----------------------------------------------------------------------- +#include "dimensions.h" +#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/trunk/libf/phylmd/concvl.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/concvl.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/concvl.F (revision 524) @@ -0,0 +1,176 @@ +! +! $Header$ +! + SUBROUTINE concvl (iflag_con,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, + . qcondc,wd) + +c + 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" +#include "dimphy.h" +c + integer NTRAC + PARAMETER (NTRAC=nqmx-2) +c + INTEGER iflag_con +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,ntrac) + 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,ntrac) + 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) + REAL qcondc(klon,klev) + REAL wd(klon) +c + REAL zx_t,zdelta,zx_qs,zcor +c + INTEGER noff, minorig + INTEGER i,k,itra + REAL qs(klon,klev) + REAL cbmf(klon) + SAVE cbmf + INTEGER ifrst + SAVE ifrst + DATA ifrst /0/ +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +c +c + IF (ifrst .EQ. 0) THEN + ifrst = 1 + 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 + 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 + 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 + ENDDO + endif ! iflag_con +c +C------------------------------------------------------------------ + +C Main driver for convection: +C iflag_con = 3 -> equivalent to convect3 +C iflag_con = 4 -> equivalent to convect1/2 + + 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, + $ cbmf,work1,work2, + $ dtime,Ma,upwd,dnwd,dnwdbis,qcondc,wd,cape) + +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 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 + + RETURN + END + Index: /LMDZ4/trunk/libf/phylmd/conema3.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/conema3.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/conema3.F (revision 524) @@ -0,0 +1,372 @@ +! +! $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) + + 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 "dimphy.h" +#include "conema3.h" + INTEGER i, l,m,itra + INTEGER ntra,ntrac !number of tracers; if no tracer transport + ! is needed, set ntra = 1 (or 0) + PARAMETER (ntrac=nqmx-2) + 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 + REAL em_t(klev) + REAL em_q(klev) + REAL em_qs(klev) + REAL em_u(klev), em_v(klev), em_tra(klev,ntrac) + REAL em_ph(klev+1), em_p(klev) + REAL em_work1(klev), em_work2(klev) + REAL em_precip, em_d_t(klev), em_d_q(klev) + REAL em_d_u(klev), em_d_v(klev), em_d_tra(klev,ntrac) + REAL em_upwd(klev), em_dnwd(klev), em_dnwdbis(klev) + REAL em_dtvpdt1(klev), em_dtvpdq1(klev) + REAL em_dplcldt, em_dplcldr + SAVE em_t,em_q, em_qs, em_ph, em_p, em_work1, em_work2 + SAVE em_u,em_v, em_tra + SAVE em_d_u,em_d_v, em_d_tra + 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 + + 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 + + REAL emmip(klev) !variation de flux ascnon dilue i et i+1 + SAVE emmip + real emMke(klev) + save emMke + real top + real bas + real emMa(klev) + 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" + + 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/trunk/libf/phylmd/conema3.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/conema3.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/conema3.h (revision 524) @@ -0,0 +1,8 @@ +! +! $Header$ +! + real epmax ! 0.993 + logical ok_adj_ema ! F + integer iflag_clw ! 0 + + common/comconema/epmax,ok_adj_ema,iflag_clw Index: /LMDZ4/trunk/libf/phylmd/conemav.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/conemav.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/conemav.F (revision 524) @@ -0,0 +1,150 @@ +! +! $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 + 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" +#include "dimphy.h" +c + integer NTRAC + PARAMETER (NTRAC=nqmx-2) +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,ntrac) + 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,ntrac) + 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 cbmf(klon) + SAVE cbmf + INTEGER ifrst + SAVE ifrst + DATA ifrst /0/ +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +c +c + IF (ifrst .EQ. 0) THEN + ifrst = 1 + 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/trunk/libf/phylmd/conf_phys.F90 =================================================================== --- /LMDZ4/trunk/libf/phylmd/conf_phys.F90 (revision 524) +++ /LMDZ4/trunk/libf/phylmd/conf_phys.F90 (revision 524) @@ -0,0 +1,644 @@ +! +! $Header$ +! +! +! + + subroutine conf_phys(ocean, ok_veget, ok_journe, ok_mensuel, ok_instan, & + & fact_cldcon, facttemps,ok_newmicro,iflag_cldcon, & + & ratqsbas,ratqshaut,if_ebil, & + & ok_ade, ok_aie, & + & bl95_b0, bl95_b1) + + use IOIPSL + implicit none + +#include "conema3.h" +#include "fisrtilp.inc" +#include "nuage.h" +#include "YOMCST.inc" +!IM : on inclut/initialise les taux de CH4, N2O, CFC11 et CFC12 +#include "clesphys.inc" +! +! Configuration de la "physique" de LMDZ a l'aide de la fonction +! GETIN de IOIPSL +! +! LF 05/2001 +! + +! +! ocean: type d'ocean (force, slab, couple) +! ok_veget: type de modele de vegetation +! ok_journe: sorties journalieres +! 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: + character (len = 6) :: ocean + logical :: ok_veget, ok_newmicro + logical :: ok_journe, ok_mensuel, ok_instan + LOGICAL :: ok_ade, ok_aie + REAL :: bl95_b0, bl95_b1 + real :: fact_cldcon, facttemps,ratqsbas,ratqshaut + integer :: iflag_cldcon, if_ebil + +! Local + integer :: numout = 6 + real :: zzz + +! +! +! + + +!Config Key = OCEAN +!Config Desc = Type d'ocean +!Config Def = force +!Config Help = Type d'ocean utilise: force, slab,couple +! + ocean = 'force ' + call getin('OCEAN', ocean) +! +!Config Key = VEGET +!Config Desc = Type de modele de vegetation +!Config Def = .false. +!Config Help = Type de modele de vegetation utilise +! + ok_veget = .false. + call getin('VEGET', ok_veget) +! +!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 = .false. + call getin('OK_journe', ok_journe) +! +!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 = .true. + call getin('OK_mensuel', ok_mensuel) +! +!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 = .false. + call getin('OK_instan', ok_instan) +! +!Config Key = ok_ade +!Config Desc = Aerosol direct effect or not? +!Config Def = .false. +!Config Help = Used in radlwsw.F +! + ok_ade = .false. + call getin('ok_ade', ok_ade) + +! +!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 = .false. + call getin('ok_aie', ok_aie) + +! +!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 = 2. + call getin('bl95_b0', bl95_b0) + +!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 = 0.2 + call getin('bl95_b1', bl95_b1) + +! +! +!Config Key = if_ebil +!Config Desc = Niveau de sortie pour les diags bilan d'energie +!Config Def = 0 +!Config Help = +! +! + if_ebil = 0 + call getin('if_ebil', if_ebil) +!! +!! 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 = 0.016715 + call getin('R_ecc', R_ecc) +!! +!Config Key = R_peri +!Config Desc = Equinoxe +!Config Def = +!Config Help = +! +! +!valeur AMIP II + R_peri = 102.7 + call getin('R_peri', R_peri) +!! +!Config Key = R_incl +!Config Desc = Inclinaison +!Config Def = +!Config Help = +! +! +!valeur AMIP II + R_incl = 23.441 + call getin('R_incl', R_incl) +!! +!Config Key = solaire +!Config Desc = Constante solaire en W/m2 +!Config Def = 1365. +!Config Help = +! +! +!valeur AMIP II + solaire = 1365. + call getin('solaire', solaire) +!! +!Config Key = co2_ppm +!Config Desc = concentration du gaz carbonique en ppmv +!Config Def = 348. +!Config Help = +! +! +!valeur AMIP II + co2_ppm = 348. + call getin('co2_ppm', co2_ppm) +!! +!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 = co2_ppm * 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 = zzz + RCH4 = CH4_ppb * 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 = zzz + RN2O = N2O_ppb * 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 = zzz + RCFC11=CFC11_ppt* 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 = zzz + RCFC12 = CFC12_ppt * 1.0E-12 * 120.9140/28.97 +! RCFC12 = 2.020102726958923E-09 +!OK call getin('RCFC12', RCFC12) +!! +!! Constante solaire & Parametres orbitaux & taux gaz effet de serre END +!! +!! KE +! +!Config Key = epmax +!Config Desc = Efficacite precip +!Config Def = 0.993 +!Config Help = +! + epmax = .993 + call getin('epmax', epmax) +! +!Config Key = ok_adj_ema +!Config Desc = +!Config Def = false +!Config Help = +! + ok_adj_ema = .false. + call getin('ok_adj_ema',ok_adj_ema) +! +!Config Key = iflag_clw +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_clw = 0 + call getin('iflag_clw',iflag_clw) +! +!Config Key = cld_lc_lsc +!Config Desc = +!Config Def = 2.6e-4 +!Config Help = +! + cld_lc_lsc = 2.6e-4 + call getin('cld_lc_lsc',cld_lc_lsc) +! +!Config Key = cld_lc_con +!Config Desc = +!Config Def = 2.6e-4 +!Config Help = +! + cld_lc_con = 2.6e-4 + call getin('cld_lc_con',cld_lc_con) +! +!Config Key = cld_tau_lsc +!Config Desc = +!Config Def = 3600. +!Config Help = +! + cld_tau_lsc = 3600. + call getin('cld_tau_lsc',cld_tau_lsc) +! +!Config Key = cld_tau_con +!Config Desc = +!Config Def = 3600. +!Config Help = +! + cld_tau_con = 3600. + call getin('cld_tau_con',cld_tau_con) +! +!Config Key = ffallv_lsc +!Config Desc = +!Config Def = 1. +!Config Help = +! + ffallv_lsc = 1. + call getin('ffallv_lsc',ffallv_lsc) +! +!Config Key = ffallv_con +!Config Desc = +!Config Def = 1. +!Config Help = +! + ffallv_con = 1. + call getin('ffallv_con',ffallv_con) +! +!Config Key = coef_eva +!Config Desc = +!Config Def = 2.e-5 +!Config Help = +! + coef_eva = 2.e-5 + call getin('coef_eva',coef_eva) +! +!Config Key = reevap_ice +!Config Desc = +!Config Def = .false. +!Config Help = +! + reevap_ice = .false. + call getin('reevap_ice',reevap_ice) +! +!Config Key = iflag_cldcon +!Config Desc = +!Config Def = 1 +!Config Help = +! + iflag_cldcon = 1 + call getin('iflag_cldcon',iflag_cldcon) + +! +!Config Key = iflag_pdf +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_pdf = 0 + call getin('iflag_pdf',iflag_pdf) +! +!Config Key = fact_cldcon +!Config Desc = +!Config Def = 0.375 +!Config Help = +! + fact_cldcon = 0.375 + call getin('fact_cldcon',fact_cldcon) + +! +!Config Key = facttemps +!Config Desc = +!Config Def = 1.e-4 +!Config Help = +! + facttemps = 1.e-4 + call getin('facttemps',facttemps) + +! +!Config Key = ok_newmicro +!Config Desc = +!Config Def = .true. +!Config Help = +! + ok_newmicro = .true. + call getin('ok_newmicro',ok_newmicro) +! +!Config Key = ratqsbas +!Config Desc = +!Config Def = 0.01 +!Config Help = +! + ratqsbas = 0.01 + call getin('ratqsbas',ratqsbas) +! +!Config Key = ratqshaut +!Config Desc = +!Config Def = 0.3 +!Config Help = +! + ratqshaut = 0.3 + call getin('ratqshaut',ratqshaut) + +! +!Config Key = rad_froid +!Config Desc = +!Config Def = 35.0 +!Config Help = +! + rad_froid = 35.0 + call getin('rad_froid',rad_froid) + +! +!Config Key = rad_chau1 +!Config Desc = +!Config Def = 13.0 +!Config Help = +! + rad_chau1 = 13.0 + call getin('rad_chau1',rad_chau1) + +! +!Config Key = rad_chau2 +!Config Desc = +!Config Def = 9.0 +!Config Help = +! + rad_chau2 = 9.0 + call getin('rad_chau2',rad_chau2) + +! +!Config Key = top_height +!Config Desc = +!Config Def = 3 +!Config Help = +! + top_height = 3 + call getin('top_height',top_height) + +! +!Config Key = overlap +!Config Desc = +!Config Def = 3 +!Config Help = +! + overlap = 3 + call getin('overlap',overlap) + + +! +! +!Config Key = cdmmax +!Config Desc = +!Config Def = 1.3E-3 +!Config Help = +! + cdmmax = 1.3E-3 + call getin('cdmmax',cdmmax) + +! +!Config Key = cdhmax +!Config Desc = +!Config Def = 1.1E-3 +!Config Help = +! + cdhmax = 1.1E-3 + call getin('cdhmax',cdhmax) + +!261103 +! +!Config Key = ksta +!Config Desc = +!Config Def = 1.0e-10 +!Config Help = +! + ksta = 1.0e-10 + call getin('ksta',ksta) + +! +!Config Key = ksta_ter +!Config Desc = +!Config Def = 1.0e-10 +!Config Help = +! + ksta_ter = 1.0e-10 + call getin('ksta_ter',ksta_ter) + +! +!Config Key = ok_kzmin +!Config Desc = +!Config Def = .true. +!Config Help = +! + ok_kzmin = .true. + call getin('ok_kzmin',ok_kzmin) + +! +!Config Key = lev_histhf +!Config Desc = +!Config Def = 0 +!Config Help = +! + lev_histhf = 0 + call getin('lev_histhf',lev_histhf) + +! +!Config Key = lev_histday +!Config Desc = +!Config Def = 1 +!Config Help = +! + lev_histday = 1 + call getin('lev_histday',lev_histday) + +! +!Config Key = lev_histmth +!Config Desc = +!Config Def = 2 +!Config Help = +! + lev_histmth = 2 + call getin('lev_histmth',lev_histmth) + +! +! +!Config Key = +!Config Desc = +!Config Def = +!Config Help = +! +! = +! call getin('',) +! +! +! +! + + write(numout,*)' ##############################################' + write(numout,*)' Configuration des parametres de la physique: ' + write(numout,*)' Config ocean = ', ocean + write(numout,*)' Config veget = ', ok_veget + write(numout,*)' Sortie journaliere = ', ok_journe + write(numout,*)' Sortie mensuelle = ', ok_mensuel + write(numout,*)' Sortie instantanee = ', ok_instan + write(numout,*)' Sortie bilan d''energie, if_ebil =', if_ebil + 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,*)' 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,*)' fact_cldcon = ', fact_cldcon + write(numout,*)' facttemps = ', facttemps + write(numout,*)' ok_newmicro = ',ok_newmicro + write(numout,*)' ratqsbas = ',ratqsbas + write(numout,*)' ratqshaut = ',ratqshaut + 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,*)' ok_ade = ',ok_ade + write(numout,*)' ok_aie = ',ok_aie + 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 + + return + + end subroutine conf_phys + +! +!################################################################# +! + + 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 + +! 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 = 360. + call getin('tau_calv',tau_calv) + + write(numout,*)' ##############################################' + WRITE(numout,*)' Configuration de l''interface atm/surfaces : ' + WRITE(numout,*)' tau_calv = ',tau_calv + return + + end subroutine conf_interface Index: /LMDZ4/trunk/libf/phylmd/conflx.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/conflx.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/conflx.F (revision 524) @@ -0,0 +1,1663 @@ +! +! $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 + 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====================================================================== +#include "dimensions.h" +#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) + IMPLICIT none +C ------------------------------------------------------------------ +#include "dimensions.h" +#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--------------------------------------------------------------------- + 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) + 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---------------------------------------------------------------------- +#include "dimensions.h" +#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) + 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---------------------------------------------------------------------- +#include "dimensions.h" +#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) + IMPLICIT none +C---------------------------------------------------------------------- +C THIS ROUTINE DOES THE CALCULATIONS FOR CLOUD ASCENTS +C FOR CUMULUS PARAMETERIZATION +C---------------------------------------------------------------------- +#include "dimensions.h" +#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) + IMPLICIT none +C---------------------------------------------------------------------- +C THIS ROUTINE DOES THE FINAL CALCULATION OF CONVECTIVE +C FLUXES IN THE CLOUD LAYER AND IN THE SUBCLOUD LAYER +C---------------------------------------------------------------------- +#include "dimensions.h" +#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "YOECUMF.h" +C + REAL cevapcu(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 + CEVAPCU(k)=1.93E-6*261.*SQRT(1.E3/(38.3*0.293) + 1 *SQRT(0.5*(paph(1,k)+paph(1,k+1))/paph(1,klev+1)) ) * 0.5/RG + 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(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) + IMPLICIT none +c---------------------------------------------------------------------- +c calculer les tendances T et Q +c---------------------------------------------------------------------- +#include "dimensions.h" +#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) + 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---------------------------------------------------------------------- +#include "dimensions.h" +#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) + 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---------------------------------------------------------------------- +#include "dimensions.h" +#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) + 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 +#include "dimensions.h" +#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/trunk/libf/phylmd/conlmd.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/conlmd.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/conlmd.F (revision 524) @@ -0,0 +1,2308 @@ +! +! $Header$ +! + SUBROUTINE conlmd (dtime, paprs, pplay, t, q, conv_q, + s d_t, d_q, rain, snow, ibas, itop) + 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====================================================================== +#include "dimensions.h" +#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) + 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====================================================================== +#include "dimensions.h" +#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 + REAL frac(nb) ! valeur de la maille fractionnelle + SAVE frac + INTEGER opt_cld(nb) ! option pour le modele nuageux + SAVE opt_cld + LOGICAL appel1er + SAVE 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) + 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====================================================================== +#include "dimensions.h" +#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) + 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====================================================================== +#include "dimensions.h" +#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 +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) + 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====================================================================== +#include "dimensions.h" +#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) + 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 +#include "dimensions.h" +#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) + IMPLICIT NONE +c +c Ajustement humide (Schema de convection de Manabe) +C. +#include "dimensions.h" +#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) + IMPLICIT NONE +c +#include "dimensions.h" +#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/trunk/libf/phylmd/convect1.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/convect1.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/convect1.F (revision 524) @@ -0,0 +1,648 @@ +! +! $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 + implicit none +c +#include "dimensions.h" +#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/trunk/libf/phylmd/convect2.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/convect2.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/convect2.F (revision 524) @@ -0,0 +1,1394 @@ +! +! $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 + implicit none +c +#include "dimensions.h" +#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/trunk/libf/phylmd/convect3.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/convect3.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/convect3.F (revision 524) @@ -0,0 +1,1406 @@ +! +! $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################################################################# +#include "dimensions.h" +#include "dimphy.h" + PARAMETER (NA=60) + + integer NTRAC + PARAMETER (NTRAC=nqmx-2) + REAL DELTAC ! cld + PARAMETER (DELTAC=0.01) ! cld + + INTEGER NENT(NA) + 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,NTRAC),TRATM(NA) + REAL UP(NA),VP(NA),TRAP(NA,NTRAC) + 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)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 + 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 "cvparam3.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 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 "cvparam3.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 cv3_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 "cvparam3.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 + buoy(icb(i),k)=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 + 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 + + return + end + + SUBROUTINE cv3_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 "cvparam3.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 "cvparam3.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 + ment(i,k,j)=0.0 + sij(i,k,j)=0.0 + 385 continue + 390 continue + 400 continue + +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===================================================================== + + call zilch(asum,ncum*nd) + call zilch(bsum,ncum*nd) + call zilch(csum,ncum*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 cv3_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 "cvparam3.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. + + 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)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.3) then + CALL cv3_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.3) then + CALL cv3_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.3) then + CALL cv3_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.3) then + CALL 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 ) + 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,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.3) then + CALL cv3_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.3) then + CALL cv3_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.3) then + CALL cv3_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.3) then + CALL cv3_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,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 + +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! --- UNCOMPRESS THE FIELDS +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + + if (iflag_con.eq.3) then + CALL cv3_uncompress(nloc,len,ncum,nd,ntra,idcum + : ,iflag + : ,precip,sig,w0 + : ,ft,fq,fu,fv,ftra + : ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape + o ,iflag1 + o ,precip1,sig1,w01 + o ,ft1,fq1,fu1,fv1,ftra1 + o ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1 ) + 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 = .FALSE. + + 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 + endif + +c constants consistent with LMDZ: + if (iflag_con.eq.3) then + 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) + grav= 10. ! 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/trunk/libf/phylmd/cv_routines.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/cv_routines.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/cv_routines.F (revision 524) @@ -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/trunk/libf/phylmd/cvflag.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/cvflag.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/cvflag.h (revision 524) @@ -0,0 +1,6 @@ +! +! $Header$ +! + logical cvflag_grav + + COMMON /cvflag/ cvflag_grav Index: /LMDZ4/trunk/libf/phylmd/cvparam.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/cvparam.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/cvparam.h (revision 524) @@ -0,0 +1,28 @@ +! +! $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 + Index: /LMDZ4/trunk/libf/phylmd/cvparam3.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/cvparam3.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/cvparam3.h (revision 524) @@ -0,0 +1,29 @@ +! +! $Header$ +! +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 sigd, spfac +cIM cf. FH : pour compatibilite avec conema3 TEMPORAIRE real pbcrit, ptcrit, epmax + real pbcrit, ptcrit + real omtrain + real dtovsh, dpbase, dttrig + real dtcrit, tau, beta, alpha + real delta + real betad + + COMMON /cvparam3/ noff, minorig, nl, nlp, nlm + : , sigd, spfac +cIM cf. FH : pour compatibilite avec conema3 TEMPORAIRE : ,pbcrit, ptcrit, epmax + : ,pbcrit, ptcrit + : ,omtrain + : ,dtovsh, dpbase, dttrig + : ,dtcrit, tau, beta, alpha, delta, betad + Index: /LMDZ4/trunk/libf/phylmd/cvthermo.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/cvthermo.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/cvthermo.h (revision 524) @@ -0,0 +1,15 @@ +! +! $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 + Index: /LMDZ4/trunk/libf/phylmd/diagphy.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/diagphy.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/diagphy.F (revision 524) @@ -0,0 +1,408 @@ +! +! $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====================================================================== +C + implicit none + +#include "dimensions.h" +#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 + 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====================================================================== + + IMPLICIT NONE +C +#include "dimensions.h" +#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 + 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====================================================================== +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/trunk/libf/phylmd/dimphy.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/dimphy.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/dimphy.h (revision 524) @@ -0,0 +1,13 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- + INTEGER KIDIA, KFDIA, KLON, KLEV + PARAMETER (KIDIA=1,KFDIA=iim*(jjm-1)+2-1/jjm, + . KLON=KFDIA-KIDIA+1,KLEV=llm) +c----------------------------------------------------------------------- + INTEGER nbtr ! nombre de vrais traceurs + PARAMETER (nbtr=nqmx-2+1/(nqmx-1)) +c----------------------------------------------------------------------- + REAL zmasq(KLON) + COMMON/terreoce/zmasq Index: /LMDZ4/trunk/libf/phylmd/dimsoil.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/dimsoil.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/dimsoil.h (revision 524) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER nsoilmx + PARAMETER (nsoilmx=11) Index: /LMDZ4/trunk/libf/phylmd/ecribin.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/ecribin.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/ecribin.F (revision 524) @@ -0,0 +1,102 @@ +! +! $Header$ +! + SUBROUTINE ecribins(unit,pz) + IMPLICIT none +c----------------------------------------------------------------------- +#include "dimensions.h" +#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) + IMPLICIT none +c----------------------------------------------------------------------- +#include "dimensions.h" +#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*8 r8(n) + REAL*4 r4(n) + DO i = 1, n + r4(i) = r8(i) + ENDDO + WRITE(nunit)r4 + RETURN + END +#endif Index: /LMDZ4/trunk/libf/phylmd/ecrireg.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/ecrireg.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/ecrireg.F (revision 524) @@ -0,0 +1,119 @@ +! +! $Header$ +! + SUBROUTINE ecriregs(unit,pz) + IMPLICIT none +c----------------------------------------------------------------------- +#include "dimensions.h" +#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) + IMPLICIT none +c----------------------------------------------------------------------- +#include "dimensions.h" +#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/trunk/libf/phylmd/fisrtilp.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/fisrtilp.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/fisrtilp.F (revision 524) @@ -0,0 +1,537 @@ +! +! $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 + 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====================================================================== +#include "dimensions.h" +#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(klon),zcl(klon) +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 + 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(klon), zrhol(klon) + REAL zchau(klon),zfroi(klon),zfice(klon),zneb(klon) +c + LOGICAL appel1er + SAVE 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 +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 + 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./ + + 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 + 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 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 + 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 +cIM : klevm1 + 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 + DO i = 1, klon +cIM + IF(k.LE.klevm1) THEN + 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) +CC WRITE (6,*) 'cppluie ', zt(i)-(t(i,k+1)+d_t(i,k+1)) + ENDIF + ENDDO +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écip 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échauffement 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 + print*,'ZQ(',i,',',k,')=',zq(i) + 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) 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 (ptconv(i,k)) then + zcl(i)=cld_lc_con + zct(i)=1./cld_tau_con + else + zcl(i)=cld_lc_lsc + zct(i)=1./cld_tau_lsc + endif +c quantité d'eau à élminier. + zchau(i) = zct(i)*dtime/FLOAT(ninter) * zoliq(i) + . *(1.0-EXP(-(zoliq(i)/zneb(i)/zcl(i))**2)) *(1.-zfice(i)) +c meme chose pour la glace. + if (ptconv(i,k)) then + zfroi(i) = dtime/FLOAT(ninter)/zdz(i)*zoliq(i) + . *fallvc(zrhol(i)) * zfice(i) + else + zfroi(i) = dtime/FLOAT(ninter)/zdz(i)*zoliq(i) + . *fallvs(zrhol(i)) * zfice(i) + endif + 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) + 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 + RETURN + END Index: /LMDZ4/trunk/libf/phylmd/fisrtilp.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/fisrtilp.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/fisrtilp.h (revision 524) @@ -0,0 +1,21 @@ +! +! $Header$ +! + 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/ + s cld_lc_lsc ! 2.6e-4 + s ,cld_lc_con ! 2.6e-4 + s ,cld_tau_lsc ! 3600. + s ,cld_tau_con ! 3600. + s ,ffallv_lsc ! 1. + s ,ffallv_con ! 1. + s ,coef_eva ! 2.e-5 + s ,reevap_ice ! F + s ,iflag_pdf ! 0 + Index: /LMDZ4/trunk/libf/phylmd/fisrtilp.inc =================================================================== --- /LMDZ4/trunk/libf/phylmd/fisrtilp.inc (revision 524) +++ /LMDZ4/trunk/libf/phylmd/fisrtilp.inc (revision 524) @@ -0,0 +1,21 @@ +! +! $Header$ +! + 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 + Index: /LMDZ4/trunk/libf/phylmd/fisrtilp_tr.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/fisrtilp_tr.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/fisrtilp_tr.F (revision 524) @@ -0,0 +1,432 @@ +! +! $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 + 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====================================================================== +#include "dimensions.h" +#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 +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 +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/trunk/libf/phylmd/flxtr.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/flxtr.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/flxtr.F (revision 524) @@ -0,0 +1,206 @@ +! +! $Header$ +! + SUBROUTINE flxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d, + . pt,pplay,paprs,kcbot,kctop,kdtop,x,dx) + 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 +#include "dimensions.h" +#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/trunk/libf/phylmd/haut2bas.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/haut2bas.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/haut2bas.F (revision 524) @@ -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/trunk/libf/phylmd/hgardfou.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/hgardfou.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/hgardfou.F (revision 524) @@ -0,0 +1,118 @@ +! +! $Header$ +! + SUBROUTINE hgardfou (t,tsol,text) + IMPLICIT none +c====================================================================== +c Verifier la temperature +c====================================================================== +#include "dimensions.h" +#include "dimphy.h" +#include "YOMCST.h" +#include "indicesol.h" + REAL t(klon,klev), tsol(klon,nbsrf) + CHARACTER*(*) text +C + INTEGER i, k, nsrf + REAL zt(klon) + INTEGER jadrs(klon), jbad + LOGICAL ok +c + LOGICAL firstcall + SAVE firstcall + DATA firstcall /.TRUE./ + IF (firstcall) THEN + PRINT*, 'hgardfou garantit la temperature dans [100,370] K' + firstcall = .FALSE. + 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 =',jadrs(i),k,zt(jadrs(i)) + 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 =',jadrs(i),k,zt(jadrs(i)) + 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 =',jadrs(i),nsrf,zt(jadrs(i)) + 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 =',jadrs(i),nsrf,zt(jadrs(i)) + ENDDO + ENDIF + ENDDO +c + IF (.NOT. ok) THEN + PRINT*, 'hgardfou s arrete ', text + CALL abort + ENDIF + + RETURN + END Index: /LMDZ4/trunk/libf/phylmd/histo_o500_pctau.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/histo_o500_pctau.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/histo_o500_pctau.F (revision 524) @@ -0,0 +1,66 @@ +! +! $Header$ +! + SUBROUTINE histo_o500_pctau(nbreg,pct_ocean,w,histo,histoW,nhisto) + IMPLICIT none + + INTEGER :: ij, k, l, nw + INTEGER :: nreg, nbreg +#include "dimensions.h" +#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/trunk/libf/phylmd/homogene.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/homogene.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/homogene.F (revision 524) @@ -0,0 +1,99 @@ +! +! $Header$ +! + SUBROUTINE homogene(paprs, q, dq, u,v, du, dv) + 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============================================================== +#include "dimensions.h" +#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/trunk/libf/phylmd/hydrol.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/hydrol.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/hydrol.F (revision 524) @@ -0,0 +1,120 @@ +! +! $Header$ +! +c +c + SUBROUTINE hydrol(dtime,pctsrf,rain_fall,snow_fall,evap, + . agesno, tsol,qsol,snow,runoff) + 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 +#include "dimensions.h" +#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/trunk/libf/phylmd/inc_cpl.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/inc_cpl.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/inc_cpl.h (revision 524) @@ -0,0 +1,23 @@ +! +! $Header$ +! +! +! +! -- inc_cpl.h 1998-04 +! ********** +!@ +!@ Contents : variables describing pipe and field names +!@ -------- +!@ +!@ -- cl_write : for fields to write +!@ +!@ -- cl_read : for fields to read +!@ +! ------------------------------------------------------------------- +! + INTEGER jpread, jpwrit + PARAMETER (jpread=0, jpwrit=1) + CHARACTER*8 cl_writ(jpmaxfld), cl_read(jpmaxfld) + CHARACTER*8 cl_f_writ(jpmaxfld), cl_f_read(jpmaxfld) + COMMON / comcpl / cl_writ, cl_read, cl_f_writ, cl_f_read +! ------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/phylmd/inc_sipc.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/inc_sipc.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/inc_sipc.h (revision 524) @@ -0,0 +1,26 @@ +! +! $Header$ +! +C +C -- inc_sipc.h 97-08-11 Version 2.0 Author: S&A +C ********** +C@ +C@ Contents : variables describing pools formed of shared memory segments +C@ -------- +C@ +C@ -- mpoolinit(r/w) : handles associated to model pools for passing initial info +C@ +C@ -- mpoolwrit : handles associated to pools used to pass fields exchanged +C@ from model to coupler (see libsipc/SIPC_Write_Model.f) +C@ +C@ -- mpoolread : handles associated to pools used to pass fields exchanged +C@ from model to coupler (see libsipc/SIPC_Read_Model.f) +C@ +C ------------------------------------------------------------------- +C + INTEGER mpoolinitr + INTEGER mpoolinitw + INTEGER mpoolwrit(jpmaxfld) + INTEGER mpoolread(jpmaxfld) + COMMON / compool / mpoolinitr, mpoolinitw, mpoolwrit, mpoolread +C ------------------------------------------------------------------- Index: /LMDZ4/trunk/libf/phylmd/indicesol.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/indicesol.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/indicesol.h (revision 524) @@ -0,0 +1,20 @@ +! +! $Header$ +! + 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 *3 clnsurf(nbsrf) + DATA clnsurf/'ter', 'lic', 'oce', 'sic'/ Index: /LMDZ4/trunk/libf/phylmd/indicesol.inc =================================================================== --- /LMDZ4/trunk/libf/phylmd/indicesol.inc (revision 524) +++ /LMDZ4/trunk/libf/phylmd/indicesol.inc (revision 524) @@ -0,0 +1,12 @@ +! +! $Header$ +! + INTEGER, parameter :: nbsrf=4 + INTEGER, parameter :: is_oce=3 !ocean + INTEGER, parameter :: is_sic = 4 ! glace de mer + INTEGER, parameter :: is_ter = 1 ! terre + INTEGER, parameter :: is_lic = 2 ! glacier continental + REAL,parameter :: epsfra = 1.0E-05 +! + CHARACTER (len=3),dimension(nbsrf) :: clnsurf(nbsrf) + DATA clnsurf/'ter', 'lic', 'oce', 'sic'/ Index: /LMDZ4/trunk/libf/phylmd/ini_histISCCP.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/ini_histISCCP.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/ini_histISCCP.h (revision 524) @@ -0,0 +1,66 @@ +! +! $Header$ +! + IF (ok_isccp) THEN +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 zsto = frequence de stockage des champs +c zout = frequence d'ecriture des champs + zsto = dtime +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/h (48 fois par jour) +c zout = dtime +c +c ecriture mensuelle + zout = dtime * ecrit_mth +c + print*,'ISCCP zout,zsto=',zout,zsto +c +c PRINT*, 'La frequence de sortie ISCCP est de ', ecrit_isccp +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) + write(*,*)'ISCCP ', itau_phy, zjulian +c +c +c definition coordonnees lon,lat en globale +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 + + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) +c + CALL histbeg("histISCCP.nc", iim,zx_lon(:,1),jjmp1,zx_lat(1,:), + . 1, iim, 1, jjmp1, + . itau_phy, zjulian, dtime, + . nhori, nid_isccp) +c + CALL histvert(nid_isccp, "cldtopres","Cloud Top Pressure","mb", + . lmaxm1, cldtopres, nvert,'down') +c +c variables a ecrire +c + DO k=1, kmaxm1 + CALL histdef(nid_isccp, "cldISCCP_"//taulev(k), + . "LMDZ ISCCP cld", "%", + . iim, jjmp1,nhori,lmaxm1,1,lmaxm1,nvert,32, + . "ave(X)", zsto,zout) + ENDDO +c + CALL histdef(nid_isccp, "nsunlit", + . "Nb of calls with sunlit ", "%", + . iim, jjmp1,nhori,1,1,1,-99,32, + . "ave(X)", zsto,zout) +c + CALL histend(nid_isccp) +c + ENDIF ! ok_isccp Index: /LMDZ4/trunk/libf/phylmd/ini_histREGDYN.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/ini_histREGDYN.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/ini_histREGDYN.h (revision 524) @@ -0,0 +1,120 @@ +! +! $Header$ +! + + IF (ok_regdyn) THEN +c + PRINT*, 'La frequence de sortie REGDYN est de ', ecrit_mth +c PRINT*, 'La frequence de sortie REGDYN est de ', ecrit_regdyn +cIM cf. LF + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) + +cccIM CALL ymds2ju(anne_ini, 1, 1, 0.0, zjulian) +c CALL ymds2ju(annee_ref, 1, 1, 0.0, zjulian) +c zjulian = zjulian + day_ini +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 pour les champs instantannes, il faut mettre la meme valeur pour +c zout et tsto. +c dtime est passe par ailleurs a histbeg + +c zout = dtime * REAL(NINT(86400./dtime*ecrit_regdyn)) +c zsto = zout +c print*,'zout,zsto=',zout,zsto +c ecriture mensuelle +c + zsto = dtime + zout = dtime * ecrit_mth +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)", zsto,zout) + + CALL histdef(nid_regdyn, "nh1", "Nb of pixels Tropics Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zsto,zout) +c + + CALL histdef(nid_regdyn, "nht1","Total Nb pixels Tropics Histo" + & ,"%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zsto,zout) +c +c PAN + CALL histdef(nid_regdyn, "hw2", "North Pacific Histogram", "%", + & kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, + & "ave(X)", zsto,zout) + + CALL histdef(nid_regdyn, "nh2", "Nb of pixels North Pacific", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zsto,zout) +c + + CALL histdef(nid_regdyn, "nht2","Total Nb pixels North Pacific + & Histo" + & ,"%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zsto,zout) +c CAL + CALL histdef(nid_regdyn, "hw3", "California Histogram", "%", + & kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, + & "ave(X)", zsto,zout) + + CALL histdef(nid_regdyn, "nh3", "Nb of pixels California + & Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zsto,zout) +c + + CALL histdef(nid_regdyn, "nht3","Total Nb pixels California + & Histo" + & ,"%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zsto,zout) +c HAW + CALL histdef(nid_regdyn, "hw4", "Hawai Histogram", "%", + & kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, + & "ave(X)", zsto,zout) + + CALL histdef(nid_regdyn, "nh4", "Nb of pixels Hawai Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zsto,zout) +c + + CALL histdef(nid_regdyn, "nht4","Total Nb pixels Hawai Histo" + & ,"%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zsto,zout) +c WAP + CALL histdef(nid_regdyn, "hw5", "Warm Pool Histogram", "%", + & kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, + & "ave(X)", zsto,zout) + + CALL histdef(nid_regdyn, "nh5", "Nb of pixels Warm Pool Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zsto,zout) +c + + CALL histdef(nid_regdyn, "nht5","Total Nb pixels Warm Pool + & Histo" + & ,"%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zsto,zout) +c + CALL histend(nid_regdyn) + + endif ! ok_regdyn Index: /LMDZ4/trunk/libf/phylmd/ini_histday.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/ini_histday.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/ini_histday.h (revision 524) @@ -0,0 +1,462 @@ +! +! $Header$ +! + IF (ok_journe) THEN +c + zsto = dtime + zout = dtime * FLOAT(ecrit_day) + zsto1= dtime * FLOAT(ecrit_day) +c zout = dtime * REAL(ecrit_day) +c zsto1= dtime * REAL(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) + CALL histbeg("histday", iim,zx_lon(:,1), jjmp1,zx_lat(1,:), + . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, + . nhori, nid_day) + write(*,*)'Journee ', itau_phy, zjulian + CALL histvert(nid_day, "presnivs", "Vertical levels", "mb", + . klev, presnivs, nvert) +c + IF(lev_histday.GE.1) THEN +c + CALL histdef(nid_day, "phis", "Surface geop. height", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c + CALL histdef(nid_day, "aire", "Grid area", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c + CALL histdef(nid_day, "contfracATM","% sfce ter+lic ","-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c + CALL histdef(nid_day, "contfracOR","% sfce terre OR", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c +c Champs 2D: +c + CALL histdef(nid_day, "tsol", "Surface Temperature", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "t2m", "Temperature 2m", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c +c Champs retires momentannéement en attendant un hypothetique +c debugage + + CALL histdef(nid_day, "t2m_min", "Temp. 2m min.", + . "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . t2mincels, zsto,zout) +c + CALL histdef(nid_day, "t2m_max", "Temp. 2m max.", + . "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . t2maxcels, zsto,zout) +c + CALL histdef(nid_day, "plul", "Large-scale Precip.", + . "kg/(s*m2)", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "pluc", "Convective Precip.", + . "kg/(s*m2)", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "snowl", "Solid Large-scale Precip.", + . "kg/(s*m2)", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + IF(1.EQ.0) THEN !snowc=0. + CALL histdef(nid_day, "snowc", "Solid Convective Precip.", + . "kg/(s*m2)", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + ENDIF !snowc=0. +c + CALL histdef(nid_day, "flat", "Latent heat flux", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "sicf", "Sea-ice fraction", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto1,zout) +c + CALL histdef(nid_day, "q2m", "Specific humidity", "kg/kg", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "u10m", "Vent zonal 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "v10m", "Vent meridien 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "wind10m","10-m wind speed","m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "wind10max", "10-m wind speed max.", + . "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . t2maxcels, zsto,zout) +c + CALL histdef(nid_day, "psol", "Surface Pressure", "Pa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "precip","Precipitation Totale liq+sol" + . , "kg/(s*m2)", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "snowf", "Snow fall", "kg/(s*m2)", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "snow_mass", "Snow Mass", "kg/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "evap", "Evaporation", "kg/(s*m2)", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "tops", "Solar rad. at TOA", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "topl", "IR rad. at TOA", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "sols", "Net Solar rad. at surf.", + . "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "soll", "Net IR rad. at surface", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "cldl", "Low-level cloudiness", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "cldm", "Mid-level cloudiness", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "cldh", "High-level cloudiness", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "cldt", "Total cloudiness", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "cldq", "Cloud liquid water path", + . "kg/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "prw", "Precipitable water", "kg/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c +c Champs dynamiques sur niveaux de pression + DO k=1, nlevENS +c + CALL histdef(nid_day, "u"//clev(k), + . "Zonal wind"//clev(k)//"mb","m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "v"//clev(k), + . "Meridional wind"//clev(k)//"mb","m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + ENDDO !nlevENS +c + CALL histdef(nid_day, "w500", "Verical wind 500mb", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day,"phi500", "Geopotentiel a 500mb","m2/s2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "slp", "Sea Level Pressure", "Pa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "cape_max", "CAPE max.", + . "J/kg", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . capemaxcels, zsto,zout) +c + CALL histdef(nid_day, "solldown", "Down. IR rad. at surface", + . "W/m2", iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "sens", "Sensible heat flux", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "SWdnSFC", "SWdn at surface","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto,zout) +c + ENDIF !lev_histday.GE.1 +c + IF (lev_histday.GE.2) THEN +c + CALL histdef(nid_day, "bils", "Surf. total heat flux", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "fder", "Heat flux derivation", "W/m2/K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + ENDIF !lev_histday.GE.2 +c================================================================= + IF(lev_histday.GE.3) THEN +c================================================================= +c INITIALISATION DES CHAMPS 3D +c================================================================= +c================================================================= +c================================================================= +c Champs 3D: +c + CALL histdef(nid_day, "temp", "Air temperature", "K", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "ovap", "Specific humidity", "kg/kg", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "geop", "Geopotential height", "m", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "vitu", "Zonal wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "vitv", "Meridional wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "vitw", "Vertical wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "pres", "Air pressure", "Pa", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c +c================================================================= +c FIN INITIALISATION DES CHAMPS 3D +c================================================================= + ENDIF ! lev_histday.GE.3 +c + IF (lev_histday.GE.4) THEN +c================================================================= +c +c INITIALISATION DES CHAMPS SUR LES SOUS SURFACES +c +c================================================================= +c + CALL histdef(nid_day, "SWupTOA", "SWup at TOA","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "SWupSFC", "SWup at surface","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "SWdnTOA", "SWdn at TOA","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "SWupTOAclr", + . "SWup clear sky at TOA","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto,zout) + + CALL histdef(nid_day, "SWupSFCclr", + . "SWup clear sky at surface","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto,zout) + + CALL histdef(nid_day, "SWdnTOAclr", + . "SWdn clear sky at TOA","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto,zout) + + CALL histdef(nid_day, "SWdnSFCclr", + . "SWdn clear sky at surface","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto,zout) +c +c================================================================= +c================================================================= +c================================================================= +c INITIALISATION DES CHAMPS SUR LES SOUS SURFACES +c================================================================= +c + CALL histdef(nid_day, "tter", "Surface Temperature", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "tlic", "Surface Temperature", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "toce", "Surface Temperature", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "tsic", "Surface Temperature", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "t2mter", "Temp.terre 2m", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "t2mlic", "Temp.lic 2m", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "t2moce", "Temp.oce 2m", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "t2msic", "Temp.sic 2m", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "t2mter_min", "Temp.terre 2m min.", + . "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . t2mincels, zsto,zout) +c + CALL histdef(nid_day, "t2mter_max", "Temp.terre 2m max.", + . "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . t2maxcels, zsto,zout) +c + CALL histdef(nid_day, "u10mter", "Vent zonal ter 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "u10mlic", "Vent zonal lic 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "u10moce", "Vent zonal oce 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "u10msic", "Vent zonal sic 10m", + . "m/s",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "v10mter", "Vent meridien ter 10m", + . "m/s", iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "v10mlic", "Vent meridien lic 10m", + . "m/s",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "v10moce", "Vent meridien oce 10m", + . "m/s",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "v10msic", "Vent meridien sic 10m", + . "m/s",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + DO nsrf = 1, nbsrf +C + call histdef(nid_day, "pourc_"//clnsurf(nsrf), + $ "Fraction"//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +C + call histdef(nid_day, "tsol_"//clnsurf(nsrf), + $ "Fraction"//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +C + call histdef(nid_day, "sens_"//clnsurf(nsrf), + $ "Sensible heat flux "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +c + call histdef(nid_day, "lat_"//clnsurf(nsrf), + $ "Latent heat flux "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +C + call histdef(nid_day, "taux_"//clnsurf(nsrf), + $ "Zonal wind stress"//clnsurf(nsrf),"Pa", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) + + call histdef(nid_day, "tauy_"//clnsurf(nsrf), + $ "Meridional xind stress "//clnsurf(nsrf), "Pa", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +C + call histdef(nid_day, "albe_"//clnsurf(nsrf), + $ "Albedo surf. "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +C + call histdef(nid_day, "rugs_"//clnsurf(nsrf), + $ "Latent heat flux "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +C + END DO +C +c================================================================= +c +c FIN INITIALISATION DES CHAMPS SUR LES SOUS SURFACES +c +c================================================================= + ENDIF !lev_histday.GE.4 +c================================================================= +c + CALL histend(nid_day) +c + ndex2d = 0 + ndex3d = 0 +c +c================================================================= + ENDIF ! fin de test sur ok_journe Index: /LMDZ4/trunk/libf/phylmd/ini_histhf.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/ini_histhf.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/ini_histhf.h (revision 524) @@ -0,0 +1,194 @@ +! +! $Header$ +! + + IF (ok_hf) THEN +c + zout = dtime * REAL(NINT(86400./dtime*ecrit_hf)) + zsto = zout + zsto1 = dtime + PRINT*, 'La frequence de sortie instant. est de ', ecrit_hf +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 + + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) + +cccIM CALL histbeg("histhf", iim,zx_lon, jjmp1,zx_lat, + CALL histbeg("histhf", iim,zx_lon(:,1), jjmp1,zx_lat(1,:), + . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, + . nhori, nid_hf) + + CALL histvert(nid_hf, "presnivs", "Vertical levels", "mb", + . klev, presnivs, nvert) +c + + IF(lev_histhf.GE.1) THEN +c +c CALL histdef(nid_hf, "phis", "Surface geop. height", "-", +c . iim,jjmp1,nhori, 1,1,1, -99, 32, +c . "once", zsto,zout) +c +c CALL histdef(nid_hf, "aire", "Grid area", "-", +c . iim,jjmp1,nhori, 1,1,1, -99, 32, +c . "once", zsto,zout) +c + CALL histdef(nid_hf, "aireTER","Grid area CONT","-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c + CALL histdef(nid_hf, "contfracATM","% sfce ter+lic ","-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c + CALL histdef(nid_hf, "contfracOR","% sfce terre OR", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c +c Champs 2D: +c + CALL histdef(nid_hf, "t2m", "Temperature 2m", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_hf, "q2m", "Specific humidity", "kg/kg", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_hf, "psol", "Surface Pressure", "Pa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + print*,'ATTENTION METTRE AVE(X) POUR LES PRECIPS' + + CALL histdef(nid_hf, "rain", "Precipitation", "kg/m^2s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto1,zout) +c +cIM ENSEMBLES BEG +c + CALL histdef(nid_hf, "tsol", "Surface Temperature", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_hf, "slp", "Sea Level Pressure", "Pa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c +c + CALL histdef(nid_hf, "u10m", "Vent zonal 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_hf, "v10m", "Vent meridien 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_hf, "wind10m","10-m wind speed","m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + DO k=1, nlevENS + IF(clev(k).EQ."500") THEN + CALL histdef(nid_hf, "phi"//clev(k), + . "Geopotential"//clev(k)//"mb", "m2/s2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + ENDIF !clev(k).EQ."500" + ENDDO !k=1, nlevENS +c + ENDIF !lev_histhf.GE.1 +c + IF(lev_histhf.GE.2) THEN +c + CALL histdef(nid_hf, "cldt", "Total cloudiness", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto1,zout) +c +c + CALL histdef(nid_hf, "SWdownOR", + . "Sfce incident SW radiation OR", "W/m^2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto1,zout) +c + CALL histdef(nid_hf, "LWdownOR", + . "Sfce incident LW radiation OR", "W/m^2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto1,zout) + ENDIF !lev_histhf.GE.2 +c +cIM ENSEMBLES END +c + IF(lev_histhf.GE.3) THEN +c + DO k=1, nlevENS +c + CALL histdef(nid_hf, "t"//clev(k), + . "Temperature"//clev(k)//"mb","K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + IF(clev(k).NE."500") THEN + CALL histdef(nid_hf, "phi"//clev(k), + . "Geopotential"//clev(k)//"mb", "m2/s2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + ENDIF +c + CALL histdef(nid_hf, "q"//clev(k), + . "Specific humidity"//clev(k)//"mb","kg/kg", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + IF(1.EQ.0) THEN + CALL histdef(nid_hf, "rh"//clev(k), + . "Relative humidity"//clev(k)//"mb", "%", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + ENDIF +c + CALL histdef(nid_hf, "u"//clev(k), + . "Zonal wind"//clev(k)//"mb","m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_hf, "v"//clev(k), + . "Meridional wind"//clev(k)//"mb","m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + ENDDO !nlevENS + IF(1.EQ.0) THEN + CALL histdef(nid_hf, "cdrm", " Momentum drag coef.", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_hf, "cdrh", "Heat drag coef.", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + ENDIF !(1.EQ.0) THEN +c + ENDIF !lev_histhf.GE.3 +c + IF(lev_histhf.GE.4) THEN +#define histhf3d +#ifdef histhf3d +#include "ini_histhf3d.h" +#endif + ENDIF !lev_histhf.GE.4 +c +c#define histhf3d +c#ifdef histhf3d +c#include "ini_histhf3d.h" +c#endif +c + CALL histend(nid_hf) +c + endif ! ok_hf Index: /LMDZ4/trunk/libf/phylmd/ini_histhf3d.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/ini_histhf3d.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/ini_histhf3d.h (revision 524) @@ -0,0 +1,63 @@ +! +! $Header$ +! + +c IF (ok_hf) THEN +c + zout = dtime * REAL(NINT(86400./dtime*ecrit_hf)) + zsto = zout + zsto1 = dtime + PRINT*, 'La frequence de sortie instant. est de ', ecrit_hf +c +cIM cf LF + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) + +cccIM CALL ymds2ju(anne_ini, 1, 1, 0.0, zjulian) +c CALL ymds2ju(annee_ref, 1, 1, 0.0, zjulian) +c zjulian = zjulian + day_ini +cIM cf LF + +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 + + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) + +cccIM CALL histbeg("histhf", iim,zx_lon, jjmp1,zx_lat, + CALL histbeg("histhf3d", iim,zx_lon(:,1), jjmp1,zx_lat(1,:), + . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, + . nhori, nid_hf3d) + + CALL histvert(nid_hf3d, "presnivs", "Vertical levels", "mb", + . klev, presnivs, nvert) +c + +c IF(lev_histhf.GE.4) THEN +c +c Champs 3D: +c + CALL histdef(nid_hf3d, "temp", "Air temperature", "K", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_hf3d, "ovap", "Specific humidity", "kg/kg", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_hf3d, "vitu", "Zonal wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_hf3d, "vitv", "Meridional wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c +c ENDIF +c + CALL histend(nid_hf3d) +c +c endif ! ok_hf Index: /LMDZ4/trunk/libf/phylmd/ini_histins.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/ini_histins.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/ini_histins.h (revision 524) @@ -0,0 +1,234 @@ +! +! $Header$ +! + IF (ok_instan) THEN +c + zsto = dtime * ecrit_ins + zout = dtime * ecrit_ins +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) + CALL histbeg("histins", iim,zx_lon(:,1), jjmp1,zx_lat(1,:), + . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, + . nhori, nid_ins) + write(*,*)'Inst ', itau_phy, zjulian + CALL histvert(nid_ins, "presnivs", "Vertical levels", "mb", + . klev, presnivs, nvert) +c call histvert(nid_ins, 'sig_s', 'Niveaux sigma','-', +c . klev, znivsig, nvert) +c +c + CALL histdef(nid_ins, "phis", "Surface geop. height", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c + CALL histdef(nid_ins, "aire", "Grid area", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c +c Champs 2D: +c + CALL histdef(nid_ins, "tsol", "Surface Temperature", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "t2m", "Temperature 2m", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "q2m", "Specific humidity 2m", "Kg/Kg", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "u10m", "Vent zonal 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "v10m", "Vent meridien 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "psol", "Surface Pressure", "Pa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "plul", "Large-scale Precip.", "mm/day", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "pluc", "Convective Precip.", "mm/day", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "cdrm", "Momentum drag coef.", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "cdrh", "Heat drag coef.", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "precip", "Precipitation Totale liq+sol", + . "kg/(s*m2)", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "snow", "Snow fall", "kg/(s*m2)", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "snow_mass", "Snow Mass", "kg/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "topl", "OLR", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "evap", "Evaporation", "kg/(s*m2)", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "sols", "Solar rad. at surf.", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "soll", "IR rad. at surface", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "solldown", "Down. IR rad. at surface", + . "W/m2", iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "bils", "Surf. total heat flux", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "sens", "Sensible heat flux", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "fder", "Heat flux derivation", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "dtsvdfo", "Boundary-layer dTs(o)", "K/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "dtsvdft", "Boundary-layer dTs(t)", "K/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "dtsvdfg", "Boundary-layer dTs(g)", "K/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "dtsvdfi", "Boundary-layer dTs(g)", "K/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + + DO nsrf = 1, nbsrf +C + call histdef(nid_ins, "pourc_"//clnsurf(nsrf), + $ "Fraction"//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "inst(X)", zsto,zout) + + call histdef(nid_ins, "sens_"//clnsurf(nsrf), + $ "Sensible heat flux "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "inst(X)", zsto,zout) +c + call histdef(nid_ins, "tsol_"//clnsurf(nsrf), + $ "Surface Temperature"//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "inst(X)", zsto,zout) +c + call histdef(nid_ins, "lat_"//clnsurf(nsrf), + $ "Latent heat flux "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "inst(X)", zsto,zout) +C + call histdef(nid_ins, "taux_"//clnsurf(nsrf), + $ "Zonal wind stress"//clnsurf(nsrf),"Pa", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "inst(X)", zsto,zout) + + call histdef(nid_ins, "tauy_"//clnsurf(nsrf), + $ "Meridional xind stress "//clnsurf(nsrf), "Pa", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "inst(X)", zsto,zout) +c + call histdef(nid_ins, "albe_"//clnsurf(nsrf), + $ "Albedo "//clnsurf(nsrf), "-", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "inst(X)", zsto,zout) +c + call histdef(nid_ins, "rugs_"//clnsurf(nsrf), + $ "rugosite "//clnsurf(nsrf), "-", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "inst(X)", zsto,zout) +CXXX + END DO + CALL histdef(nid_ins, "rugs", "rugosity", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + +c + CALL histdef(nid_ins, "albs", "Surface albedo", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + CALL histdef(nid_ins, "albslw", "Surface albedo LW", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c +c +c Champs 3D: +c + CALL histdef(nid_ins, "temp", "Temperature", "K", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "vitu", "Zonal wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "vitv", "Merid wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "geop", "Geopotential height", "m", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "pres", "Air pressure", "Pa", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "dtvdf", "Boundary-layer dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "dqvdf", "Boundary-layer dQ", "Kg/Kg/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) +c + + CALL histend(nid_ins) +c + ndex2d = 0 + ndex3d = 0 +c + ENDIF Index: /LMDZ4/trunk/libf/phylmd/ini_histmth.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/ini_histmth.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/ini_histmth.h (revision 524) @@ -0,0 +1,766 @@ +! +! $Header$ +! + IF (ok_mensuel) THEN +c + zsto = dtime + zout = dtime * ecrit_mth +c +c zsto1: pour des valeurs "instantannees" mensuelles + zsto1 = dtime * ecrit_mth +c zsto2: pour des flux radiatifs calcules tous les 2 heures + zsto2 = dtime * radpas + PRINT*,' zsto,zsto1,zsto2,zout=',zsto, zsto1, zsto2,zout +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) + CALL histbeg("histmth.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:), + . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, + . nhori, nid_mth) + write(*,*)'Mensuel ', itau_phy, zjulian + CALL histvert(nid_mth, "presnivs", "Vertical levels", "mb", + . klev, presnivs, nvert) +c call histvert(nid_mth, 'sig_s', 'Niveaux sigma','-', +c . klev, znivsig, nvert) +c +c + IF(lev_histmth.GE.1) THEN + CALL histdef(nid_mth, "phis", "Surface geop. height", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c + CALL histdef(nid_mth, "aire", "Grid area", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c + call histdef(nid_mth, "pourc_"//clnsurf(is_ter), + $ "Fraction "//clnsurf(is_ter), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "once", zsto,zout) +c +c Champs 2D: +c + CALL histdef(nid_mth, "slp", "Sea Level Pressure", "Pa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "tsol", "Surface Temperature", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "t2m", "Temperature 2m", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c ENSEMBLES BEG + CALL histdef(nid_mth, "t2m_min", "Temp. 2m min.", + . "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . t2mincels, zsto,zout) +c + CALL histdef(nid_mth, "t2m_max", "Temp. 2m max.", + . "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . t2maxcels, zsto,zout) +c +c CALL histdef(nid_mth, "tsoil", "Sfce soil Temperature", +c . "K", +c . iim,jjmp1,nhori, 1,1,1, -99, 32, +c . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "wind10m","10-m wind speed","m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "sicf", "Sea-ice fraction", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + +c +c ENSEMBLES END + CALL histdef(nid_mth, "q2m", "Specific humidity 2m", "kg/kg", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "u10m", "Vent zonal 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "v10m", "Vent meridien 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "psol", "Surface Pressure", "Pa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "qsurf", "Surface Air humidity", "kg/kg", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + if (.not. ok_veget) then + CALL histdef(nid_mth, "qsol", "Soil watter content", "mm", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + endif +c + CALL histdef(nid_mth, "ndayrain", + . "Number of day with rain (liq+sol)", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto1,zout) +c + CALL histdef(nid_mth, "precip", "Precipitation Totale liq+sol", + . "kg/(s*m2)", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "plul", "Large-scale Precip.", + . "kg/(s*m2)", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "pluc", "Convective Precip.", + . "kg/(s*m2)", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "snow", "Snow fall", "kg/(s*m2)", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "snow_mass", "Snow Mass", "kg/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "evap", "Evaporation", "kg/(s*m2)", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "tops", "Solar rad. at TOA", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "tops0", "Solar rad. at TOA", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "topl", "IR rad. at TOA", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "topl0", "IR rad. at TOA", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "SWupTOA", "SWup at TOA","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth, "SWupTOAclr", + . "SWup clear sky at TOA","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth, "SWdnTOA", "SWdn at TOA","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth, "SWdnTOAclr", + . "SWdn clear sky at TOA","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth, "SWup200", "SWup at 200hPa","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth, "SWup200clr", + . "SWup clear sky at 200hPa","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth, "SWdn200", "SWdn at 200hPa","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth, "SWdn200clr", + . "SWdn clear sky at 200hPa","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth, "LWup200", "LWup at 200hPa","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth, "LWup200clr", + . "LWup clear sky at 200hPa","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth, "LWdn200", "LWdn at 200hPa","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth, "LWdn200clr", + . "LWdn clear sky at 200hPa","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth, "sols", "Solar rad. at surf.", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "sols0", "Solar rad. at surf.", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "soll", "IR rad. at surface", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "soll0", "IR rad. at surface", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "SWupSFC", "SWup at surface","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth, "SWupSFCclr", + . "SWup clear sky at surface","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth, "SWdnSFC", "SWdn at surface","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth, "SWdnSFCclr", + . "SWdn clear sky at surface","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth,"LWupSFC","Upwd. IR rad. at surface", + . "W/m2", iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth,"LWdnSFC","Down. IR rad. at surface", + . "W/m2", iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth,"LWupSFCclr", + . "CS Upwd. IR rad. at surface", + . "W/m2", iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth,"LWdnSFCclr", + . "Down. CS IR rad. at surface", + . "W/m2", iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto2,zout) +c + CALL histdef(nid_mth, "bils", "Surf. total heat flux", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "sens", "Sensible heat flux", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "fder", "Heat flux derivation", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c +c Effets des aerosols +c +c IF (ok_ade.OR.ok_aie) THEN + CALL histdef(nid_mth, "topsad", "ADE at TOA", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "solsad", "ADE at sfc", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "topsai", "AIE at TOA", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "solsai", "AIE at sfc", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c endif +c + +c +c CALL histdef(nid_mth, "frtu", "Zonal wind stress", "Pa", +c . iim,jjmp1,nhori, 1,1,1, -99, 32, +c . "ave(X)", zsto,zout) +c +c CALL histdef(nid_mth, "frtv", "Meridional wind stress", "Pa", +c . iim,jjmp1,nhori, 1,1,1, -99, 32, +c . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "ffonte","Thermal flux for snow melting", + . "W/m2",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "fqcalving","Ice Calving", + . "kg/m2/s",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +cIM: 171003 + DO nsrf = 1, nbsrf + call histdef(nid_mth, "taux_"//clnsurf(nsrf), + $ "Zonal wind stress"//clnsurf(nsrf), "Pa", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) + + call histdef(nid_mth, "tauy_"//clnsurf(nsrf), + $ "Meridional xind stress "//clnsurf(nsrf), "Pa", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) + ENDDO +cIM: 171003 +c + DO nsrf = 1, nbsrf +C + IF(nsrf.GT.1) THEN + call histdef(nid_mth, "pourc_"//clnsurf(nsrf), + $ "Fraction "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) + ENDIF !nsrf.GT.1 +C + call histdef(nid_mth, "tsol_"//clnsurf(nsrf), + $ "Fraction "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +C + call histdef(nid_mth, "sens_"//clnsurf(nsrf), + $ "Sensible heat flux "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +c + call histdef(nid_mth, "lat_"//clnsurf(nsrf), + $ "Latent heat flux "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +C + call histdef(nid_mth, "flw_"//clnsurf(nsrf), + $ "LW "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto2,zout) +c + call histdef(nid_mth, "fsw_"//clnsurf(nsrf), + $ "SW "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto2,zout) +C + call histdef(nid_mth, "wbils_"//clnsurf(nsrf), + $ "Bilan sol "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +C + END DO +c + CALL histdef(nid_mth, "cdrm", "Momentum drag coef.", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "cdrh", "Heat drag coef.", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "cldl", "Low-level cloudiness", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "cldm", "Mid-level cloudiness", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "cldh", "High-level cloudiness", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "cldt", "Total cloudiness", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth,"cldq","Cloud liquid water path","kg/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +cIM: 071003 + CALL histdef(nid_mth,"lwp","Cloud water path","kg/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth,"iwp","Cloud ice water path","kg/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +cIM: 071003 +c + CALL histdef(nid_mth, "ue", "Zonal energy transport", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "ve", "Merid energy transport", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "uq", "Zonal humidity transport", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "vq", "Merid humidity transport", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +cKE43 + IF(iflag_con.GE.3) THEN ! sb +c + CALL histdef(nid_mth, "cape", "Conv avlbl pot ener", "J/kg", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "pbase", "Cld base pressure", "hPa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "ptop", "Cld top pressure", "hPa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "fbase", "Cld base mass flux", "kg/m2/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "prw", "Precipitable water", "kg/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + ENDIF !iflag_con .GE. 3 +c34EK +c +c Champs interpolles sur des niveaux de pression + DO k=1, nlevENS + CALL histdef(nid_mth, "u"//clev(k), + . "Zonal wind"//clev(k)//"mb","m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "v"//clev(k), + . "Meridional wind"//clev(k)//"mb","m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "w"//clev(k), + . "Vertical wind"//clev(k)//"mb","m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "phi"//clev(k), + . "Geopotential"//clev(k)//"mb","m2/s2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + ENDDO + ENDIF !lev_histmth.GE.1 +c + IF(lev_histmth.GE.2) THEN +c +c Champs 3D: +c +c + CALL histdef(nid_mth,"lwcon","Cloud water content","kg/kg", + . iim,jjmp1,nhori, klev,1,klev, nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth,"iwcon","Cloud ice water content","kg/kg", + . iim,jjmp1,nhori, klev,1,klev, nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "temp", "Air temperature", "K", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "ovap", "Specific humidity", "kg/kg", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c +c CALL histdef(nid_mth,"wvap","Water vapor mixing ratio","kg/kg", +c . iim,jjmp1,nhori, klev,1,klev,nvert, 32, +c . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "geop", "Geopotential height", "m", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "vitu", "Zonal wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "vitv", "Meridional wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "vitw", "Vertical wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "pres", "Air pressure", "Pa", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "rneb", "Cloud fraction", "-", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "rnebcon", "Convective Cloud Fraction" + . , "-", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "rhum", "Relative humidity", "-", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "ozone", "Ozone concentration", "-", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "upwd", "saturated updraft", "kg/m2/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtphy", "Physics dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dqphy", "Physics dQ", "kg/kg/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c +c#define histmthNMC +c#ifdef histmthNMC +c#include "ini_histmthNMC.h" +c#endif +c + ENDIF !lev_histmth.GE.2 +c + IF(lev_histmth.GE.3) THEN +c + DO nsrf=1, nbsrf +c + call histdef(nid_mth, "albe_"//clnsurf(nsrf), + $ "Albedo surf. "//clnsurf(nsrf), "-", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +c + call histdef(nid_mth, "rugs_"//clnsurf(nsrf), + $ "Latent heat flux "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "ages_"//clnsurf(nsrf), "Snow age","day", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + ENDDO !nsrf=1, nbsrf +c + CALL histdef(nid_mth, "albs", "Surface albedo", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_mth, "albslw", "Surface albedo LW", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + ENDIF !lev_histmth.GE.3 +c + IF(lev_histmth.GE.4) THEN +c + CALL histdef(nid_mth, "clwcon", + . "Convective Cloud Liquid water content" + . , "kg/kg", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth,"Ma","undilute adiab updraft","kg/m2/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dnwd", "saturated downdraft","kg/m2/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dnwd0", "unsat. downdraft", "kg/m2/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtdyn", "Dynamics dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dqdyn", "Dynamics dQ", "kg/kg/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtcon", "Convection dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c +c CALL histdef(nid_mth, "ducon", "Convection du", "m/s2", +c . iim,jjmp1,nhori, klev,1,klev,nvert, 32, +c . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dqcon", "Convection dQ", "kg/kg/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtlsc", "Condensation dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +cIM: 071003 + CALL histdef(nid_mth, "dtlschr", + $ "Large-scale condensational heating rate", "K/s",iim,jjmp1 + $ ,nhori, klev,1,klev,nvert, 32,"ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dqlsc", "Condensation dQ", "kg/kg/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtvdf", "Boundary-layer dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dqvdf", "Boundary-layer dQ", "kg/kg/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dteva", "Reevaporation dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dqeva", "Reevaporation dQ", "kg/kg/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "ptconv", "POINTS CONVECTIFS"," ", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "ratqs", "RATQS"," ", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + +c + CALL histdef(nid_mth, "dtajs", "Dry adjust. dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "dqajs", "Dry adjust. dQ", "kg/kg/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtswr", "SW radiation dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtsw0", "CS SW radiation dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtlwr", "LW radiation dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth,"dtlw0","CS LW radiation dT","K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtec", "Cinetic dissip dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "duvdf", "Boundary-layer dU", "m/s2", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dvvdf", "Boundary-layer dV", "m/s2", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + IF (ok_orodr) THEN + CALL histdef(nid_mth, "duoro", "Orography dU", "m/s2", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dvoro", "Orography dV", "m/s2", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + ENDIF +C + IF (ok_orolf) THEN + CALL histdef(nid_mth, "dulif", "Orography dU", "m/s2", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dvlif", "Orography dV", "m/s2", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + ENDIF +c +c Effets des aerosols +c +c IF (ok_ade.OR.ok_aie) THEN + CALL histdef(nid_mth, "re", "CDR", "um", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "redenom", "CDR denominator", "-", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "tau", "cloud opt thickness", "-", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "taupi", "cloud opt thickn. (pi)", "-", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c endif +c + CALL histdef(nid_mth, "ozone", "Ozone concentration", "-", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + if (nqmax.GE.3) THEN + DO iq=1,nqmax-2 + IF (iq.LE.99) THEN + WRITE(str2,'(i2.2)') iq + CALL histdef(nid_mth, "trac"//str2, "Tracer No."//str2, "-", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + ELSE + PRINT*, "Trop de traceurs" + CALL abort + ENDIF + ENDDO + ENDIF +c + ENDIF !lev_histmth.GE.4 +c + CALL histend(nid_mth) +c + ndex2d = 0 + ndex3d = 0 +c + ENDIF ! fin de test sur ok_mensuel Index: /LMDZ4/trunk/libf/phylmd/ini_histmthNMC.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/ini_histmthNMC.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/ini_histmthNMC.h (revision 524) @@ -0,0 +1,82 @@ +! +! $Header$ +! + IF (ok_mensuel) THEN +c + zsto = dtime + zout = dtime * ecrit_mth +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) + CALL histbeg("histNMC.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:), + . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, + . nhori, nid_nmc) + write(*,*)'Mensuel NMC ', itau_phy, zjulian + CALL histvert(nid_nmc, "presnivs", "Vertical levels", "mb", + . klev, presnivs, nvert) +c call histvert(nid_nmc, 'sig_s', 'Niveaux sigma','-', +c . klev, znivsig, nvert) +c +c Champs 2D: + +c Champs interpolles sur des niveaux de pression du NMC +c IMIMIM 110304 BEG +c + DO k=1, nlevSTD +c + bb=clevSTD(k) +c + IF(k.GE.2) THEN + aa=clevSTD(k) + bb=aa(1:lnblnk1(aa)) + ENDIF +c + CALL histdef(nid_nmc, "t"//bb, + . "Temperature"//bb//"mb","K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_nmc, "phi"//bb, + . "Geopotential"//bb//"mb", "m2/s2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_nmc, "q"//bb, + . "Specific humidity"//bb//"mb","kg/kg", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_nmc, "rh"//bb, + . "Relative humidity"//bb//"mb", "%", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_nmc, "u"//bb, + . "Zonal wind"//bb//"mb","K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_nmc, "v"//bb, + . "Meridional wind"//bb//"mb","K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + ENDDO !nlevSTD +c IMIMIM 110304 END + + CALL histend(nid_nmc) +c +c ndex2d = 0 +c + ENDIF ! fin de test sur ok_mensuel + Index: /LMDZ4/trunk/libf/phylmd/ini_histrac.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/ini_histrac.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/ini_histrac.h (revision 524) @@ -0,0 +1,330 @@ +! +! $Header$ +! + CALL ymds2ju(annee_ref, 1, day_ref, 0.0, zjulian) +c + CALL gr_fi_ecrit(1,klon,iim,jjm+1,xlon,zx_lon) + DO i = 1, iim + zx_lon(i,1) = xlon(i+1) + zx_lon(i,jjm+1) = xlon(i+1) + ENDDO + CALL gr_fi_ecrit(1,klon,iim,jjm+1,xlat,zx_lat) + CALL histbeg("histrac", iim,zx_lon(:,1), jjm+1,zx_lat(1,:), + . 1,iim,1,jjm+1, itau_phy, zjulian, pdtphys, + . nhori, nid_tra) + CALL histvert(nid_tra, "presnivs", "Vertical levels", "mb", + . klev, presnivs, nvert) + +#ifdef INCA_AER + CALL histbeg("histrac_aer", iim,zx_lon, jjm+1,zx_lat, + . 1,iim,1,jjm+1, itau_phy, zjulian, pdtphys, + . nhori, nid_tra2) + + CALL histbeg("histrac_inst", iim,zx_lon, jjm+1,zx_lat, + . 1,iim,1,jjm+1, itau_phy, zjulian, pdtphys, + . nhori, nid_tra3) + + call histvert(nid_tra2, "presnivs", "presnivs", "mb", + . klev, presnivs, nvert) + call histvert(nid_tra3, "presnivs", "presnivs", "mb", + . klev, presnivs, nvert) +#endif + +#ifdef INCA +! call histvert(nid_tra, "ap", "Hybrid A parameter", "-", +! . klev+1, ap, nverta) +! call histvert(nid_tra, "bp", "Hybrid B parameter", "-", +! . klev+1, bp, nvertb) +#endif + + zsto = pdtphys + zout = pdtphys * FLOAT(ecrit_tra) +c + CALL histdef(nid_tra, "phis", "Surface geop. height", "-", + . iim,jjm+1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c + CALL histdef(nid_tra, "aire", "Grid area", "-", + . iim,jjm+1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +#ifdef INCA + CALL histdef(nid_tra, "ps", "Surface pressure", "Pa", + . iim,jjm+1,nhori, 1,1,1,-99, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_tra, "ptrop", "Tropopause pressure", "Pa", + . iim,jjm+1,nhori, 1,1,1,-99, 32, + . "ave(X)", zsto,zout) + +C 3d FIELDS + CALL histdef(nid_tra, "temp", "Air temperature", "K", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_tra, "u", "zonal wind component", "m/s", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_tra, "v", "zonal wind component", "m/s", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_tra, "h2o", "Specific Humidity", "MMR", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_tra, "pmid", "Pressure", "Pa", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_tra, "pdel", "Delta Pressure", "Pa", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + +! MS info + CALL histdef(nid_tra, "airm", "Air mass", "kg", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + +#ifdef INCA_CH4 +#ifdef INCAINFO + DO it=1, phtcnt + WRITE(str2,'(i2.2)') it + CALL histdef(nid_tra, "j"//str2,"j"//str2, "CM-3 S-1", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + ENDDO + DO it=1, hetcnt + WRITE(str2,'(i2.2)') it + CALL histdef(nid_tra, "w"//str2,"w"//str2, "S-1", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + ENDDO + + DO it=1, extcnt + WRITE(str2,'(i2.2)') it + CALL histdef(nid_tra, "ext"//str2,"ext"//str2, "CM-3 S-1", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + ENDDO + + DO it=1, nfs + WRITE(str2,'(i2.2)') it + CALL histdef(nid_tra, "INV"//str2, "INV"//str2, "CM-3", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + ENDDO + +#else + CALL histdef(nid_tra, "jO3","jO3", "CM-3 S-1", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "jNO2","jNO2", "CM-3 S-1", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "jH2O2","jH2O2", "CM-3 S-1", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "wHNO3","wHNO3", "S-1", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "kN2O5", "kN2O5","CM-3 S-1", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "LghtNO","LghtNO", "CM-3 S-1", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +#endif + + DO it=1, grpcnt + CALL histdef(nid_tra, grpsym(it), grpsym(it), "VMR", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + ENDDO +#endif + +#ifdef INCA_AER + + CALL histdef(nid_tra2, "scavcoef_st","scavcoef_st", "S-1", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra2, "scavcoef_cv","scavcoef_cv", "S-1", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra2, "AngstroemComp","AngstroemComp", + . "angs comp", iim,jjm+1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + +#endif +#endif + DO it=1,nqmax +C champ 2D +#ifdef INCA + IF ( prt_flag_ts(it) == 0 ) CYCLE + + CALL histdef(nid_tra, "Emi_"//solsym(it), "Emi_"//solsym(it), + . "kg/m2/s", iim,jjm+1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "Dep_"//solsym(it), "Dep_"//solsym(it), + . "cm/s", iim,jjm+1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +#ifdef INCA_AER + IF ((it .ge. trmx) .and. (it .le. trnx)) then + CALL histdef(nid_tra2, "Sed_"//solsym(it), "Sed_"//solsym(it), + . "kg/m2/s", iim,jjm+1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra2, "Dry_"//solsym(it), "Dry_"//solsym(it), + . "kg/m2/s", iim,jjm+1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra2, "Wet_"//solsym(it), "Wet_"//solsym(it), + . "kg/m2/s", iim,jjm+1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra2, "WetST_"//solsym(it), "WetST_"//solsym(it), + . "kg/m2/s", iim,jjm+1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra2, "WetCV_"//solsym(it), "WetCV_"//solsym(it), + . "kg/m2/s", iim,jjm+1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra2, "Emi_alt_"//solsym(it), "Emi_alt_"//solsym(it), + . "kg/m2/s", iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra2, "Load_"//solsym(it), "Load_"//solsym(it), + . "kg/m2", iim,jjm+1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra2, "SConc_"//solsym(it), "SConc_"//solsym(it), + . "kg/m3", iim,jjm+1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + do la=1,las + CALL histdef(nid_tra2, "OD_"//cla(la)//solsym(it), + . "OD_"//cla(la)//solsym(it), + . "opt. depth", iim,jjm+1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + enddo + CALL histdef(nid_tra2, "MD_"//solsym(it), "MD_"//solsym(it), + . "median diameter", iim,jjm+1,nhori, klev,1,klev, nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra3, "Inst_Load_"//solsym(it), + . "Inst_Load_"//solsym(it), + . "kg/m2", iim,jjm+1,nhori, 1,1,1, -99, 32, + . "inst(X)", zout,zout) + endif +#endif + CALL histdef(nid_tra, solsym(it), solsym(it), "VMR", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +#else + iq=it+2 + iiq=niadv(iq) + CALL histdef(nid_tra, tnom(iq), ttext(iiq), "U/kga", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + if (lessivage) THEN + CALL histdef(nid_tra, "fl"//tnom(iq),"Flux "//ttext(iiq), + . "U/m2/s",iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + endif +#endif + ENDDO +#ifdef INCA +#ifdef INCA_CH4 + CALL histdef(nid_tra, "O3_column", "O3_column", + . "DU", iim,jjm+1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "CO_column", "CO_column", + . "10^18 CM-2", iim,jjm+1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "CH4_column", "CH4_column", + . "10^18 CM-2", iim,jjm+1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "NO2_column", "NO2_column", + . "10^15 CM-2", iim,jjm+1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "O3_ste", "O3_ste", + . "CM-2 S-1", iim,jjm+1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "O3_prod", "O3_prod", "CM-3 S-1", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "O3_loss", "O3_loss", "CM-3 S-1", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + +! Special variables for daytime averaging +! CALL histdef(nid_tra, "day_cnt", "day_cnt", "-", +! . iim,jjm+1,nhori, klev,1,klev,nvert, 32, +! . "t_sum(X)", zsto,zout) +! CALL histdef(nid_tra, "NO_day", "NO_day", "VMR", +! . iim,jjm+1,nhori, klev,1,klev,nvert, 32, +! . "t_sum(X)", zsto,zout) + +#endif +#else + CALL histdef(nid_tra, "pyu1", "Vent niv 1", "-", + . iim,jjm+1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_tra, "pyv1", "Vent niv 1", "-", + . iim,jjm+1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + CALL histdef(nid_tra, "psrf1", "nature sol", "-", + . iim,jjm+1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + CALL histdef(nid_tra, "psrf2", "nature sol", "-", + . iim,jjm+1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + CALL histdef(nid_tra, "psrf3", "nature sol", "-", + . iim,jjm+1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + CALL histdef(nid_tra, "psrf4", "nature sol", "-", + . iim,jjm+1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + CALL histdef(nid_tra, "ftsol1", "temper sol", "-", + . iim,jjm+1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + CALL histdef(nid_tra, "ftsol2", "temper sol", "-", + . iim,jjm+1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + CALL histdef(nid_tra, "ftsol3", "temper sol", "-", + . iim,jjm+1,nhori, 1,1,1, -99, 32, + . "inst", zsto,zout) + CALL histdef(nid_tra, "ftsol4", "temper sol", "-", + . iim,jjm+1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + CALL histdef(nid_tra, "pplay", "flux u mont","-", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) + CALL histdef(nid_tra, "t", "flux u mont","-", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) + CALL histdef(nid_tra, "mfu", "flux u mont","-", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "mfd", "flux u decen","-", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "en_u", "flux u mont","-", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "en_d", "flux u mont","-", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "de_d", "flux u mont","-", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "de_u", "flux u decen","-", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_tra, "coefh", "turbulent coef","-", + . iim,jjm+1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + +#endif +c + CALL histend(nid_tra) +#ifdef INCA_AER + CALL histend(nid_tra2) + CALL histend(nid_tra3) +#endif + ndex2d = 0 + ndex3d = 0 + ndex = 0 Index: /LMDZ4/trunk/libf/phylmd/inifis.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/inifis.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/inifis.F (revision 524) @@ -0,0 +1,72 @@ +! +! $Header$ +! + SUBROUTINE inifis(ngrid,nlayer, + $ punjours, + $ pdayref,ptimestep, + $ plat,plon,parea, + $ prad,pg,pr,pcpp) + 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 ------------- + +#include "dimensions.h" +#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/trunk/libf/phylmd/iniphysiq.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/iniphysiq.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/iniphysiq.F (revision 524) @@ -0,0 +1,86 @@ +! +! $Header$ +! +c +c + SUBROUTINE iniphysiq(ngrid,nlayer, + $ punjours, + $ pdayref,ptimestep, + $ plat,plon,parea,pcu,pcv, + $ prad,pg,pr,pcpp) + 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 ------------- + +#include "dimensions.h" +#include "dimphy.h" +#include "comgeomphy.h" + + REAL prad,pg,pr,pcpp,punjours + + INTEGER ngrid,nlayer + REAL plat(ngrid),plon(ngrid),parea(klon),pcu(klon),pcv(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 + + airephy=parea + cuphy=pcu + cvphy=pcv + rlond = plon + rlatd = plat + + call suphec + 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/trunk/libf/phylmd/initphysto.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/initphysto.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/initphysto.F (revision 524) @@ -0,0 +1,290 @@ +! +! $Header$ +! +C +C + subroutine initphysto + . (infile, + . rlon, rlat, tstep,t_ops,t_wrt,nq,fileid) + + USE IOIPSL + + 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" +#include "dimphy.h" + +C Arguments + character*(*) infile + integer*4 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 + + 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(infile, iim, zx_lon(:,1), jjm+1, zx_lat(1,:), + . 1, iim, 1, jjm+1, + . tau0, zjulian, tstep, nhoriid, fileid) + +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,jjm+1,nhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) +c + write(*,*) 'apres phis ds initphysto' + + CALL histdef(fileid, "aire", "Grid area", "-", + . iim,jjm+1,nhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + write(*,*) 'apres aire ds initphysto' + + 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, jjm+1, 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, jjm+1, 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, jjm+1, 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, jjm+1, 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, jjm+1, 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, jjm+1, 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, jjm+1, nhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +c coefh frac_impa,frac_nucl + + call histdef(fileid, 'coefh', ' ', ' ', + . iim, jjm+1, nhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + + write(*,*) 'apres coefh ds initphysto' + + call histdef(fileid, 'frac_impa', ' ', ' ', + . iim, jjm+1, nhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + + call histdef(fileid, 'frac_nucl', ' ', ' ', + . iim, jjm+1, nhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +c +c pyu1 +c + CALL histdef(fileid, "pyu1", " ", " ", + . iim,jjm+1,nhoriid, 1,1,1, -99, 32, + . "inst(X)", t_ops, t_wrt) + +c +c pyv1 +c + CALL histdef(fileid, "pyv1", " ", " ", + . iim,jjm+1,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, jjm+1, nhoriid, 1, 1,1, -99,32, + . "inst(X)", t_ops, t_wrt) + +c +c ftsol2 +c + call histdef(fileid, "ftsol2", " ", " ", + . iim, jjm+1, nhoriid, 1, 1,1, -99,32, + . "inst(X)", t_ops, t_wrt) + +c +c ftsol3 +c + call histdef(fileid, "ftsol3", " ", " ", + . iim, jjm+1, nhoriid, 1, 1,1, -99, + . 32, "inst(X)", t_ops, t_wrt) + +c +c ftsol4 +c + call histdef(fileid, "ftsol4", " ", " ", + . iim, jjm+1, nhoriid, 1, 1,1, -99, + . 32, "inst(X)", t_ops, t_wrt) + +c +c rain +c + call histdef(fileid, "rain", " ", " ", + . iim, jjm+1, nhoriid, 1, 1,1, -99, + . 32, "inst(X)", t_ops, t_wrt) + +c +c psrf1 +c + call histdef(fileid, "psrf1", " ", " ", + . iim, jjm+1, nhoriid, 1, 1, 1, -99, + . 32, "inst(X)", t_ops, t_wrt) + +c +c psrf2 +c + call histdef(fileid, "psrf2", " ", " ", + . iim, jjm+1, nhoriid, 1, 1, 1, -99, + . 32, "inst(X)", t_ops, t_wrt) + +c +c psrf3 +c + call histdef(fileid, "psrf3", " ", " ", + . iim, jjm+1, nhoriid, 1, 1, 1, -99, + . 32, "inst(X)", t_ops, t_wrt) + +c +c psrf4 +c + call histdef(fileid, "psrf4", " ", " ", + . iim, jjm+1, nhoriid, 1, 1, 1, -99, + . 32, "inst(X)", t_ops, t_wrt) + + write(*,*) 'avant histend ds initphysto' + + call histend(fileid) + if (ok_sync) call histsync(fileid) + + + + return + end Index: /LMDZ4/trunk/libf/phylmd/initrrnpb.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/initrrnpb.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/initrrnpb.F (revision 524) @@ -0,0 +1,125 @@ +! +! $Header$ +! + SUBROUTINE initrrnpb(ftsol,pctsrf,masktr,fshtr,hsoltr,tautr + . ,vdeptr,scavtr) + IMPLICIT none +c====================================================================== +c Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94 +c Objet: initialisation des constantes des traceurs +CAA Revison pour le controle avec la temperature du sol +cAA +CAA it = 1 radon ss controle de ts +cAA it = 2 plomb ss controle de ts +c====================================================================== +c Arguments: +c nbtr------input-I- nombre de vrais traceurs (sans l'eau) +c ftsol-------input-R- Temperature du sol (Kelvin) +c pctsrf-----input-R- Nature de sol (pourcentage de sol) +c masktr---output-R- Masque reservoir de sol traceur (1 = reservoir) +c fshtr----output-R- Flux surfacique de production dans le sol +c hsoltr---output-R- Epaisseur du reservoir de sol +c tautr----output-R- Constante de decroissance du traceur +c vdeptr---output-R- Vitesse de depot sec dans la couche Brownienne +c scavtr---output-R- Coefficient de lessivage +c====================================================================== +#include "dimensions.h" +#include "dimphy.h" +#include "indicesol.h" +c====================================================================== +C + INTEGER i, it + REAL pctsrf(klon,nbsrf) !Pourcentage de sol (f(nature du sol)) + REAL ftsol(klon,nbsrf) ! Temperature du sol pour le controle Rn +c ! le cas echeant + REAL masktr(klon,nbtr) ! Masque de l'echange avec la surface +c (possible => 1 ) + REAL fshtr(klon,nbtr) ! Flux surfacique dans le reservoir de sol + REAL hsoltr(nbtr) ! Epaisseur equivalente du reservoir de sol + REAL tautr(nbtr) ! Constante de decroissance radioactive + REAL vdeptr(nbtr) ! Vitesse de depot sec dans la couche Brownienne + REAL scavtr(nbtr) ! Coefficient de lessivage + REAL s +C + WRITE(*,'(''PASSAGE initrrnpb ...'',$)') + print*,'nbtr= ',nbtr + print*,'nbsrf= ',nbsrf + print*,'klon= ',klon +C +C Puis les initialisation specifiques a chaque traceur (pour le moment, Rn222) +C +C +C Radon it = 1 +c + IF ( nbtr .LE. 0 ) STOP 'initrrnpb pas glop pas glop' + it = 1 + s = 1.E4 ! Source: atome par m2 + hsoltr(it) = 0.1 ! Hauteur equivalente du reservoir : +c 1 m * porosite 0.1 + tautr(it) = 4.765E5 ! Decroissance du radon, secondes +cAA +c tautr(it) = 4.765E55 ! Decroissance du radon,infinie +cAA + vdeptr(it) = 0. ! Pas de depot sec pour le radon + scavtr(it) = 0. ! Pas de lessivage pour le radon + + print*, '-------------- SOURCE DU RADON ------------------------ ' + print*,'it = ',it + print*,'Source : ', s + print*,'Hauteur equivalente du reservoir de sol: ',hsoltr(it) + print*,'Decroissance (s): ', tautr(it) + print*,'Vitesse de depot sec: ',vdeptr(it) + print*,'Facteur de lessivage: ',scavtr(it) + + DO i = 1,klon + masktr(i,it) = 0. +c IF ( NINT(pctsrf(i,3)) .EQ. 1 ) masktr(i,it) = 1. +c fshtr(i,it) = s * masktr(i,it) * pctsrf(i,3) + IF ( NINT(pctsrf(i,1)) .EQ. 1 ) masktr(i,it) = 1. + fshtr(i,it) = s * masktr(i,it) + +cAA +cAA quelques tests +cAA POur l'instant le pctsrf(i,3) = 1.0 +cAA lorsqu'il ya de la terre mias ne prend aucune autre valeur +cAA il n'est donc pas necessaire de multiplier fshtr par pctsrf +cAA +c print*, '------------------------------------------ ' +c print*, 'masktr(',i,it,')= ',masktr(i,it) +c print*, 'fshtr(',i,it,')= ',fshtr(i,it) +c print*, 'pctsrf(',i,',1)= ',pctsrf(i,1) +c print*, 'pctsrf(',i,',2)= ',pctsrf(i,2) +c print*, 'pctsrf(',i,',3)= ',pctsrf(i,3) +c print*, 'pctsrf(',i,',4)= ',pctsrf(i,4) +c print*, 's = ',s +c print*, '------------------------------------------ ' + + END DO +C +C 210Pb it = 2 +C + IF ( nbtr .LE. 1 ) STOP 'initrrnpb pas glop pas glop' + it = 2 + s = 0. ! Pas de source !!! + hsoltr(it) = 10. ! Hauteur equivalente du reservoir +c a partir duquel le +c 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 + print*, '-------------- SOURCE DU PLOMB ------------------------ ' + print*,'it = ',it + print*,'Source : ', s + print*,'Hauteur equivalente du reservoir : ',hsoltr(it) + print*,'Decroissance (s): ', tautr(it) + print*,'Vitesse de depot sec: ',vdeptr(it) + print*,'Facteur de lessivage: ',scavtr(it) +c + WRITE(*,*) 'initialisation rnpb ok' +c + RETURN + END Index: /LMDZ4/trunk/libf/phylmd/interface_surf.F90 =================================================================== --- /LMDZ4/trunk/libf/phylmd/interface_surf.F90 (revision 524) +++ /LMDZ4/trunk/libf/phylmd/interface_surf.F90 (revision 524) @@ -0,0 +1,2762 @@ +! +! $Header$ +! + + MODULE interface_surf + +! Ce module regroupe toutes les routines gerant l'interface entre le modele +! atmospherique et les modeles de surface (sols continentaux, oceans, glaces) +! Les routines sont les suivantes: +! +! interfsurf_*: routines d'aiguillage vers les interfaces avec les +! differents modeles de surface +! interfsol\ +! > routines d'interface proprement dite +! interfoce/ +! +! interfstart: routine d'initialisation et de lecture de l'etat initial +! "interface" +! interffin : routine d'ecriture de l'etat de redemmarage de l'interface +! +! +! L. Fairhead, LMD, 02/2000 + + USE ioipsl + + IMPLICIT none + + PRIVATE + PUBLIC :: interfsurf,interfsurf_hq, gath2cpl + + INTERFACE interfsurf + module procedure interfsurf_hq, interfsurf_vent + END INTERFACE + + INTERFACE interfoce + module procedure interfoce_cpl, interfoce_slab, interfoce_lim + END INTERFACE + +#include "YOMCST.inc" +#include "indicesol.inc" + + +! run_off ruissellement total + REAL, ALLOCATABLE, DIMENSION(:),SAVE :: run_off, run_off_lic + real, allocatable, dimension(:),save :: coastalflow, riverflow +!!$PB + REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: tmp_rriv, tmp_rcoa,tmp_rlic +!! pour simuler la fonte des glaciers antarctiques + REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: coeff_iceberg + real, save :: surf_maille + real, save :: cte_flux_iceberg = 6.3e7 + integer, save :: num_antarctic = 1 + REAL, save :: tau_calv +!!$ + CONTAINS +! +!############################################################################ +! + SUBROUTINE interfsurf_hq(itime, dtime, date0, jour, rmu0, & + & klon, iim, jjm, nisurf, knon, knindex, pctsrf, & + & rlon, rlat, cufi, cvfi,& + & debut, lafin, ok_veget, soil_model, nsoilmx, tsoil, qsol,& + & zlev, u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & + & tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, & + & precip_rain, precip_snow, sollw, sollwdown, swnet, swdown, & + & fder, taux, tauy, rugos, rugoro, & + & albedo, snow, qsurf, & + & tsurf, p1lay, ps, radsol, & + & ocean, npas, nexca, zmasq, & + & evap, fluxsens, fluxlat, dflux_l, dflux_s, & + & tsol_rad, tsurf_new, alb_new, alblw, emis_new, & + & z0_new, pctsrf_new, agesno,fqcalving,ffonte, run_off_lic_0) + + +! Cette routine sert d'aiguillage entre l'atmosphere et la surface en general +! (sols continentaux, oceans, glaces) pour les fluxs de chaleur et d'humidite. +! En pratique l'interface se fait entre la couche limite du modele +! atmospherique (clmain.F) et les routines de surface (sechiba, oasis, ...) +! +! +! L.Fairhead 02/2000 +! +! input: +! itime numero du pas de temps +! klon nombre total de points de grille +! iim, jjm nbres de pts de grille +! dtime pas de temps de la physique (en s) +! date0 jour initial +! jour jour dans l'annee en cours, +! rmu0 cosinus de l'angle solaire zenithal +! nexca pas de temps couplage +! 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 +! pctsrf tableau des pourcentages de surface de chaque maille +! rlon longitudes +! rlat latitudes +! cufi,cvfi resolution des mailles en x et y (m) +! debut logical: 1er appel a la physique +! lafin logical: dernier appel a la physique +! ok_veget logical: appel ou non au schema de surface continental +! (si false calcul simplifie des fluxs sur les continents) +! zlev hauteur de la premiere couche +! 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 potentielle de l'air +! ccanopy concentration CO2 canopee +! 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 +! sollw flux IR net a la surface +! sollwdown flux IR descendant a la surface +! swnet flux solaire net +! swdown flux solaire entrant a la surface +! albedo albedo de la surface +! tsurf temperature de surface +! p1lay pression 1er niveau (milieu de couche) +! ps pression au sol +! radsol rayonnement net aus sol (LW + SW) +! ocean type d'ocean utilise (force, slab, couple) +! fder derivee des flux (pour le couplage) +! taux, tauy tension de vents +! rugos rugosite +! zmasq masque terre/ocean +! rugoro rugosite orographique +! run_off_lic_0 runoff glacier du pas de temps precedent +! +! output: +! evap evaporation totale +! fluxsens flux de chaleur sensible +! fluxlat flux de chaleur latente +! tsol_rad +! tsurf_new temperature au sol +! alb_new albedo +! emis_new emissivite +! z0_new surface roughness +! pctsrf_new nouvelle repartition des surfaces + +#include "iniprint.h" + + +! Parametres d'entree + integer, intent(IN) :: itime + integer, intent(IN) :: iim, jjm + integer, intent(IN) :: klon + real, intent(IN) :: dtime + real, intent(IN) :: date0 + integer, intent(IN) :: jour + real, intent(IN) :: rmu0(klon) + integer, intent(IN) :: nisurf + integer, intent(IN) :: knon + integer, dimension(klon), intent(in) :: knindex + real, dimension(klon,nbsrf), intent(IN) :: pctsrf + logical, intent(IN) :: debut, lafin, ok_veget + real, dimension(klon), intent(IN) :: rlon, rlat + real, dimension(klon), intent(IN) :: cufi, cvfi + real, dimension(klon), intent(INOUT) :: tq_cdrag + real, dimension(klon), intent(IN) :: zlev + 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) :: petAcoef, peqAcoef + real, dimension(klon), intent(IN) :: petBcoef, peqBcoef + real, dimension(klon), intent(IN) :: precip_rain, precip_snow + real, dimension(klon), intent(IN) :: sollw, sollwdown, swnet, swdown + real, dimension(klon), intent(IN) :: ps, albedo + real, dimension(klon), intent(IN) :: tsurf, p1lay + REAL, DIMENSION(klon), INTENT(INOUT) :: radsol,fder + real, dimension(klon), intent(IN) :: zmasq + real, dimension(klon), intent(IN) :: taux, tauy, rugos, rugoro + character (len = 6) :: ocean + integer :: npas, nexca ! nombre et pas de temps couplage + real, dimension(klon), intent(INOUT) :: evap, snow, qsurf +!! PB ajout pour soil + logical :: soil_model + integer :: nsoilmx + REAL, DIMENSION(klon, nsoilmx) :: tsoil + REAL, dimension(klon), intent(INOUT) :: qsol + REAL, dimension(klon) :: soilcap + REAL, dimension(klon) :: soilflux +! Parametres de sortie + real, dimension(klon), intent(OUT):: fluxsens, fluxlat + real, dimension(klon), intent(OUT):: tsol_rad, tsurf_new, alb_new + real, dimension(klon), intent(OUT):: alblw + real, dimension(klon), intent(OUT):: emis_new, z0_new + real, dimension(klon), intent(OUT):: dflux_l, dflux_s + real, dimension(klon,nbsrf), intent(OUT) :: pctsrf_new + real, dimension(klon), intent(INOUT):: agesno + real, dimension(klon), intent(INOUT):: run_off_lic_0 + +! Flux thermique utiliser pour fondre la neige +!jld a rajouter real, dimension(klon), intent(INOUT):: ffonte + real, dimension(klon), intent(INOUT):: ffonte +! Flux d'eau "perdue" par la surface et nécessaire pour que limiter la +! hauteur de neige, en kg/m2/s +!jld a rajouter real, dimension(klon), intent(INOUT):: fqcalving + real, dimension(klon), intent(INOUT):: fqcalving + +! Local + character (len = 20),save :: modname = 'interfsurf_hq' + character (len = 80) :: abort_message + logical, save :: first_call = .true. + integer, save :: error + integer :: ii, index + logical,save :: check = .false. + real, dimension(klon):: cal, beta, dif_grnd, capsol +!!$PB real, parameter :: calice=1.0/(5.1444e+06*0.15), tau_gl=86400.*5. + real, parameter :: calice=1.0/(5.1444e+06*0.15), tau_gl=86400.*5. + real, parameter :: calsno=1./(2.3867e+06*.15) + real, dimension(klon):: alb_ice + real, dimension(klon):: tsurf_temp + real, dimension(klon):: qsurf_new +!! real, allocatable, dimension(:), save :: alb_neig_grid + real, dimension(klon):: alb_neig, alb_eau + real, DIMENSION(klon):: zfra + logical :: cumul = .false. + INTEGER,dimension(1) :: iloc + INTEGER :: isize + real, dimension(klon):: fder_prev + REAL, dimension(klon) :: bidule + + if (check) write(*,*) 'Entree ', modname +! +! On doit commencer par appeler les schemas de surfaces continentales +! car l'ocean a besoin du ruissellement qui est y calcule +! + if (first_call) then + call conf_interface(tau_calv) + if (nisurf /= is_ter .and. klon > 1) then + write(*,*)' *** Warning ***' + write(*,*)' nisurf = ',nisurf,' /= is_ter = ',is_ter + write(*,*)'or on doit commencer par les surfaces continentales' + abort_message='voir ci-dessus' + call abort_gcm(modname,abort_message,1) + endif + if (ocean /= 'slab ' .and. ocean /= 'force ' .and. ocean /= 'couple') then + write(*,*)' *** Warning ***' + write(*,*)'Option couplage pour l''ocean = ', ocean + abort_message='option pour l''ocean non valable' + call abort_gcm(modname,abort_message,1) + endif + if ( is_oce > is_sic ) then + write(*,*)' *** Warning ***' + write(*,*)' Pour des raisons de sequencement dans le code' + write(*,*)' l''ocean doit etre traite avant la banquise' + write(*,*)' or is_oce = ',is_oce, '> is_sic = ',is_sic + abort_message='voir ci-dessus' + call abort_gcm(modname,abort_message,1) + endif +! allocate(alb_neig_grid(klon), stat = error) +! if (error /= 0) then +! abort_message='Pb allocation alb_neig_grid' +! call abort_gcm(modname,abort_message,1) +! endif + endif + first_call = .false. + +! Initialisations diverses +! +!!$ cal=0.; beta=1.; dif_grnd=0.; capsol=0. +!!$ alb_new = 0.; z0_new = 0.; alb_neig = 0.0 +!!$! PB +!!$ tsurf_new = 0. + +!IM cf JLD + ffonte(1:knon)=0. + fqcalving(1:knon)=0. + + cal = 999999. ; beta = 999999. ; dif_grnd = 999999. ; capsol = 999999. + alb_new = 999999. ; z0_new = 999999. ; alb_neig = 999999. + tsurf_new = 999999. + alblw = 999999. +! Aiguillage vers les differents schemas de surface + + if (nisurf == is_ter) then +! +! Surface "terre" appel a l'interface avec les sols continentaux +! +! allocation du run-off + if (.not. allocated(coastalflow)) then + allocate(coastalflow(knon), stat = error) + if (error /= 0) then + abort_message='Pb allocation coastalflow' + call abort_gcm(modname,abort_message,1) + endif + allocate(riverflow(knon), stat = error) + if (error /= 0) then + abort_message='Pb allocation riverflow' + call abort_gcm(modname,abort_message,1) + endif + allocate(run_off(knon), stat = error) + if (error /= 0) then + abort_message='Pb allocation run_off' + call abort_gcm(modname,abort_message,1) + endif +!!$PB + ALLOCATE (tmp_rriv(iim,jjm+1), stat=error) + if (error /= 0) then + abort_message='Pb allocation tmp_rriv' + call abort_gcm(modname,abort_message,1) + endif + ALLOCATE (tmp_rcoa(iim,jjm+1), stat=error) + if (error /= 0) then + abort_message='Pb allocation tmp_rcoa' + call abort_gcm(modname,abort_message,1) + endif + ALLOCATE (tmp_rlic(iim,jjm+1), stat=error) + if (error /= 0) then + abort_message='Pb allocation tmp_rlic' + call abort_gcm(modname,abort_message,1) + endif + +!!$ + else if (size(coastalflow) /= knon) then + write(*,*)'Bizarre, le nombre de points continentaux' + write(*,*)'a change entre deux appels. J''arrete ...' + abort_message='voir ci-dessus' + call abort_gcm(modname,abort_message,1) + endif + coastalflow = 0. + riverflow = 0. +! +! Calcul age de la neige +! +!!$ PB ATTENTION changement ordre des appels +!!$ CALL albsno(klon,agesno,alb_neig_grid) + + if (.not. ok_veget) then +! +! calcul albedo: lecture albedo fichier CL puis ajout albedo neige +! + call interfsur_lim(itime, dtime, jour, & + & klon, nisurf, knon, knindex, debut, & + & alb_new, z0_new) +! +! calcul snow et qsurf, hydrol adapté +! + CALL calbeta(dtime, nisurf, knon, snow, qsol, beta, capsol, dif_grnd) + + IF (soil_model) THEN + CALL soil(dtime, nisurf, 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 * capsol +!!$ cal = capsol + ENDIF + CALL calcul_fluxs( klon, knon, nisurf, dtime, & + & tsurf, p1lay, cal, beta, tq_cdrag, ps, & + & 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) + + CALL fonte_neige( klon, knon, nisurf, dtime, & + & tsurf, p1lay, cal, beta, tq_cdrag, ps, & + & precip_rain, precip_snow, snow, qsol, & + & radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, & + & petAcoef, peqAcoef, petBcoef, peqBcoef, & + & tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, & + & fqcalving,ffonte, run_off_lic_0) + + + 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))) + alb_new(1 : knon) = alb_neig(1 : knon) *zfra(1:knon) + & + & alb_new(1 : knon)*(1.0-zfra(1:knon)) + z0_new = sqrt(z0_new**2+rugoro**2) + alblw(1 : knon) = alb_new(1 : knon) + + else +!! CALL albsno(klon,agesno,alb_neig_grid) +! +! appel a sechiba +! +#ifdef CPP_VEGET + call interfsol(itime, klon, dtime, date0, nisurf, knon, & + & knindex, rlon, rlat, cufi, cvfi, iim, jjm, pctsrf, & + & debut, lafin, ok_veget, & + & zlev, u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & + & tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, & + & precip_rain, precip_snow, sollwdown, swnet, swdown, & + & tsurf, p1lay/100., ps/100., radsol, & + & evap, fluxsens, fluxlat, & + & tsol_rad, tsurf_new, alb_new, alblw, & + & emis_new, z0_new, dflux_l, dflux_s, qsurf_new) + +! +! ajout de la contribution du relief +! + z0_new = SQRT(z0_new**2+rugoro**2) +! +! mise a jour de l'humidite saturante calculee par ORCHIDEE + qsurf(1:knon) = qsurf_new(1:knon) +#endif + + endif +! +! Remplissage des pourcentages de surface +! + pctsrf_new(:,nisurf) = pctsrf(:,nisurf) + + else if (nisurf == is_oce) then + + if (check) write(*,*)'ocean, nisurf = ',nisurf + + +! +! Surface "ocean" appel a l'interface avec l'ocean +! + if (ocean == 'couple') then + if (nexca == 0) then + abort_message='nexca = 0 dans interfoce_cpl' + call abort_gcm(modname,abort_message,1) + endif + + cumul = .false. + + iloc = maxloc(fder(1:klon)) + if (check) then + if (fder(iloc(1))> 0.) then + WRITE(*,*)'**** Debug fder ****' + WRITE(*,*)'max fder(',iloc(1),') = ',fder(iloc(1)) + endif + endif +!!$ +!!$ where(fder.gt.0.) +!!$ fder = 0. +!!$ endwhere + + call interfoce(itime, dtime, cumul, & + & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, & + & ocean, npas, nexca, debut, lafin, & + & swdown, sollw, precip_rain, precip_snow, evap, tsurf, & + & fluxlat, fluxsens, fder, albedo, taux, tauy, zmasq, & + & tsurf_new, alb_new, pctsrf_new) + +! else if (ocean == 'slab ') then +! call interfoce(nisurf) + else ! lecture conditions limites + call interfoce(itime, dtime, jour, & + & klon, nisurf, knon, knindex, & + & debut, & + & tsurf_new, pctsrf_new) + + endif + + tsurf_temp = tsurf_new + cal = 0. + beta = 1. + dif_grnd = 0. + alb_neig(:) = 0. + agesno(:) = 0. + + call calcul_fluxs( klon, knon, nisurf, dtime, & + & tsurf_temp, p1lay, cal, beta, tq_cdrag, ps, & + & 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) + + fder_prev = fder + fder = fder_prev + dflux_s + dflux_l + + iloc = maxloc(fder(1:klon)) + if (check.and.fder(iloc(1))> 0.) then + WRITE(*,*)'**** Debug fder****' + WRITE(*,*)'max fder(',iloc(1),') = ',fder(iloc(1)) + WRITE(*,*)'fder_prev, dflux_s, dflux_l',fder_prev(iloc(1)), & + & dflux_s(iloc(1)), dflux_l(iloc(1)) + endif +!!$ +!!$ where(fder.gt.0.) +!!$ fder = 0. +!!$ endwhere + +! +! 2eme appel a interfoce pour le cumul des champs (en particulier +! fluxsens et fluxlat calcules dans calcul_fluxs) +! + if (ocean == 'couple') then + + cumul = .true. + + call interfoce(itime, dtime, cumul, & + & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, & + & ocean, npas, nexca, debut, lafin, & + & swdown, sollw, precip_rain, precip_snow, evap, tsurf, & + & fluxlat, fluxsens, fder, albedo, taux, tauy, zmasq, & + & tsurf_new, alb_new, pctsrf_new) + +! else if (ocean == 'slab ') then +! call interfoce(nisurf) + + endif + +! +! calcul albedo +! + + if ( minval(rmu0) == maxval(rmu0) .and. minval(rmu0) == -999.999 ) then + CALL alboc(FLOAT(jour),rlat,alb_eau) + else ! cycle diurne + CALL alboc_cd(rmu0,alb_eau) + endif + DO ii =1, knon + alb_new(ii) = alb_eau(knindex(ii)) + enddo + + z0_new = sqrt(rugos**2 + rugoro**2) + alblw(1:knon) = alb_new(1:knon) + +! + else if (nisurf == is_sic) then + + if (check) write(*,*)'sea ice, nisurf = ',nisurf + +! +! Surface "glace de mer" appel a l'interface avec l'ocean +! +! + if (ocean == 'couple') then + + cumul =.false. + + iloc = maxloc(fder(1:klon)) + if (check.and.fder(iloc(1))> 0.) then + WRITE(*,*)'**** Debug fder ****' + WRITE(*,*)'max fder(',iloc(1),') = ',fder(iloc(1)) + endif +!!$ +!!$ where(fder.gt.0.) +!!$ fder = 0. +!!$ endwhere + + call interfoce(itime, dtime, cumul, & + & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, & + & ocean, npas, nexca, debut, lafin, & + & swdown, sollw, precip_rain, precip_snow, evap, tsurf, & + & fluxlat, fluxsens, fder, albedo, taux, tauy, zmasq, & + & tsurf_new, alb_new, pctsrf_new) + + tsurf_temp = tsurf_new + cal = 0. + dif_grnd = 0. + beta = 1.0 + +! else if (ocean == 'slab ') then +! call interfoce(nisurf) + ELSE +! ! lecture conditions limites + CALL interfoce(itime, dtime, jour, & + & klon, nisurf, knon, knindex, & + & debut, & + & tsurf_new, pctsrf_new) + +!IM cf LF + DO ii = 1, knon + IF (pctsrf_new(ii,nisurf) < EPSFRA) then + snow(ii) = 0.0 +!IM cf LF/JLD tsurf(ii) = RTT - 1.8 + tsurf_new(ii) = RTT - 1.8 + IF (soil_model) tsoil(ii,:) = RTT -1.8 + endif + enddo + + CALL calbeta(dtime, nisurf, knon, snow, qsol, beta, capsol, dif_grnd) + + IF (soil_model) THEN +!IM cf LF/JLD CALL soil(dtime, nisurf, knon,snow, tsurf, tsoil,soilcap, soilflux) + CALL soil(dtime, nisurf, knon,snow, tsurf_new, tsoil,soilcap, soilflux) + cal(1:knon) = RCPD / soilcap(1:knon) + radsol(1:knon) = radsol(1:knon) + soilflux(1:knon) + dif_grnd = 0. + ELSE + dif_grnd = 1.0 / tau_gl + cal = RCPD * calice + WHERE (snow > 0.0) cal = RCPD * calsno + ENDIF + tsurf_temp = tsurf + beta = 1.0 + ENDIF + + CALL calcul_fluxs( klon, knon, nisurf, dtime, & + & tsurf_temp, p1lay, cal, beta, tq_cdrag, ps, & + & 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) + + IF (ocean /= 'couple') THEN + CALL fonte_neige( klon, knon, nisurf, dtime, & + & tsurf_temp, p1lay, cal, beta, tq_cdrag, ps, & + & precip_rain, precip_snow, snow, qsol, & + & radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, & + & petAcoef, peqAcoef, petBcoef, peqBcoef, & + & tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, & + & fqcalving,ffonte, run_off_lic_0) + +! calcul 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))) + alb_new(1 : knon) = alb_neig(1 : knon) *zfra(1:knon) + & + & 0.6 * (1.0-zfra(1:knon)) +!! alb_new(1 : knon) = 0.6 + ENDIF + + fder_prev = fder + fder = fder_prev + dflux_s + dflux_l + + iloc = maxloc(fder(1:klon)) + if (check.and.fder(iloc(1))> 0.) then + WRITE(*,*)'**** Debug fder ****' + WRITE(*,*)'max fder(',iloc(1),') = ',fder(iloc(1)) + WRITE(*,*)'fder_prev, dflux_s, dflux_l',fder_prev(iloc(1)), & + & dflux_s(iloc(1)), dflux_l(iloc(1)) + endif +!!$ where(fder.gt.0.) +!!$ fder = 0. +!!$ endwhere + +! +! 2eme appel a interfoce pour le cumul et le passage des flux a l'ocean +! + if (ocean == 'couple') then + + cumul =.true. + + call interfoce(itime, dtime, cumul, & + & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, & + & ocean, npas, nexca, debut, lafin, & + & swdown, sollw, precip_rain, precip_snow, evap, tsurf, & + & fluxlat, fluxsens, fder, albedo, taux, tauy, zmasq, & + & tsurf_new, alb_new, pctsrf_new) + +! else if (ocean == 'slab ') then +! call interfoce(nisurf) + + endif + + + z0_new = 0.002 + z0_new = SQRT(z0_new**2+rugoro**2) + alblw(1:knon) = alb_new(1:knon) + + else if (nisurf == is_lic) then + + if (check) write(*,*)'glacier, nisurf = ',nisurf + + if (.not. allocated(run_off_lic)) then + allocate(run_off_lic(knon), 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. + endif +! +! Surface "glacier continentaux" appel a l'interface avec le sol +! +! call interfsol(nisurf) + IF (soil_model) THEN + CALL soil(dtime, nisurf, 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 + beta = 1.0 + dif_grnd = 0.0 + + call calcul_fluxs( klon, knon, nisurf, dtime, & + & tsurf, p1lay, cal, beta, tq_cdrag, ps, & + & 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) + + call fonte_neige( klon, knon, nisurf, dtime, & + & tsurf, p1lay, cal, beta, tq_cdrag, ps, & + & precip_rain, precip_snow, snow, qsol, & + & radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, & + & petAcoef, peqAcoef, petBcoef, peqBcoef, & + & tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, & + & fqcalving,ffonte, run_off_lic_0) + +! passage du run-off des glaciers calcule dans fonte_neige au coupleur + bidule=0. + bidule(1:knon)= run_off_lic(1:knon) + call gath2cpl(bidule, tmp_rlic, klon, knon,iim,jjm,knindex) +! +! calcul 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))) + alb_new(1 : knon) = alb_neig(1 : knon)*zfra(1:knon) + & + & 0.6 * (1.0-zfra(1:knon)) +!IM cf FH/GK alb_new(1 : knon) = 0.6 +! alb_new(1 : knon) = 0.82 +!IM cf JLD/ GK +!IM: 211003 Ksta0.77 alb_new(1 : knon) = 0.77 +!IM: KstaTER0.8 & LMD_ARMIP5 alb_new(1 : knon) = 0.8 +!IM: KstaTER0.77 & LMD_ARMIP6 + alb_new(1 : knon) = 0.77 + +! +! Rugosite +! + z0_new = rugoro +! +! Remplissage des pourcentages de surface +! + pctsrf_new(:,nisurf) = pctsrf(:,nisurf) + + alblw(1:knon) = alb_new(1:knon) + else + write(*,*)'Index surface = ',nisurf + abort_message = 'Index surface non valable' + call abort_gcm(modname,abort_message,1) + endif + + END SUBROUTINE interfsurf_hq + +! +!######################################################################### +! + SUBROUTINE interfsurf_vent(nisurf, knon & + & ) +! +! Cette routine sert d'aiguillage entre l'atmosphere et la surface en general +! (sols continentaux, oceans, glaces) pour les tensions de vents. +! En pratique l'interface se fait entre la couche limite du modele +! atmospherique (clmain.F) et les routines de surface (sechiba, oasis, ...) +! +! +! L.Fairhead 02/2000 +! +! input: +! nisurf index de la surface a traiter (1 = sol continental) +! knon nombre de points de la surface a traiter + +! Parametres d'entree + integer, intent(IN) :: nisurf + integer, intent(IN) :: knon + + + return + END SUBROUTINE interfsurf_vent +! +!######################################################################### +! +#ifdef CPP_VEGET + SUBROUTINE interfsol(itime, klon, dtime, date0, nisurf, knon, & + & knindex, rlon, rlat, cufi, cvfi, iim, jjm, pctsrf, & + & debut, lafin, ok_veget, & + & plev, u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & + & tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, & + & precip_rain, precip_snow, lwdown, swnet, swdown, & + & tsurf, p1lay, ps, radsol, & + & evap, fluxsens, fluxlat, & + & tsol_rad, tsurf_new, alb_new, alblw, & + & emis_new, z0_new, dflux_l, dflux_s, qsurf) + + USE intersurf + +! 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 +! klon nombre total de points de grille +! 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) +! ok_veget logical: appel ou non au schema de surface continental +! (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 +! 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 +! tsurf temperature de surface +! p1lay pression 1er niveau (milieu de couche) +! ps pression au sol +! radsol rayonnement net aus sol (LW + SW) +! +! +! input/output +! run_off ruissellement total +! +! output: +! evap evaporation totale +! fluxsens flux de chaleur sensible +! fluxlat flux de chaleur latente +! tsol_rad +! tsurf_new temperature au sol +! alb_new albedo +! emis_new emissivite +! z0_new surface roughness +! qsurf air moisture at surface + +! Parametres d'entree + integer, intent(IN) :: itime + integer, intent(IN) :: klon + real, intent(IN) :: dtime + real, intent(IN) :: date0 + integer, intent(IN) :: nisurf + integer, intent(IN) :: knon + integer, intent(IN) :: iim, jjm + integer, dimension(klon), intent(IN) :: knindex + logical, intent(IN) :: debut, lafin, ok_veget + real, dimension(klon,nbsrf), intent(IN) :: pctsrf + real, dimension(klon), intent(IN) :: rlon, rlat + real, dimension(klon), intent(IN) :: cufi, cvfi + 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(INOUT) :: 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 +!IM cf. JP +++ + real, dimension(klon) :: swdown_vrai +!IM cf. JP --- + real, dimension(klon), intent(IN) :: tsurf, p1lay + real, dimension(klon), intent(IN) :: radsol +! Parametres de sortie + real, dimension(klon), intent(OUT):: evap, fluxsens, fluxlat, qsurf + real, dimension(klon), intent(OUT):: tsol_rad, tsurf_new, alb_new, alblw + real, dimension(klon), intent(OUT):: emis_new, z0_new + real, dimension(klon), intent(OUT):: dflux_s, dflux_l + +! Local +! + integer :: ii, ij, jj, igrid, ireal, i, index, iglob + integer :: error + character (len = 20) :: modname = 'interfsol' + character (len = 80) :: abort_message + logical,save :: check = .FALSE. + real, dimension(klon) :: cal, beta, dif_grnd, capsol +! type de couplage dans sechiba +! character (len=10) :: coupling = 'implicit' +! drapeaux controlant les appels dans SECHIBA +! type(control_type), save :: control_in +! Preserved albedo +!IM cf. JP +++ + real, allocatable, dimension(:), save :: albedo_keep, zlev +!IM cf. JP --- +! coordonnees geographiques + real, allocatable, dimension(:,:), save :: lalo +! pts voisins + integer,allocatable, dimension(:,:), save :: neighbours +! fractions continents + real,allocatable, dimension(:), save :: contfrac +! resolution de la grille + real, allocatable, dimension (:,:), save :: resolution +! correspondance point n -> indices (i,j) + integer, allocatable, dimension(:,:), save :: correspond +! offset pour calculer les point voisins + integer, dimension(8,3), save :: off_ini + integer, dimension(8), save :: offset +! Identifieurs des fichiers restart et histoire + integer, save :: rest_id, hist_id + integer, save :: rest_id_stom, hist_id_stom +! + real, allocatable, dimension (:,:), save :: lon_scat, lat_scat + + logical, save :: lrestart_read = .true. , lrestart_write = .false. + + real, dimension(klon):: snow + 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 + integer :: indi, indj + integer, dimension(klon) :: ktindex + REAL, dimension(klon) :: bidule +! Essai cdrag + real, dimension(klon) :: cdrag + +#include "temps.inc" +#include "YOMCST.inc" +#include "iniprint.h" + + if (check) write(lunout,*)'Entree ', modname + if (check) write(lunout,*)'ok_veget = ',ok_veget + + ktindex(:) = knindex(:) + iim - 1 + +! initialisation + if (debut) then + + IF ( .NOT. allocated(albedo_keep)) THEN + ALLOCATE(albedo_keep(klon)) + ALLOCATE(zlev(klon)) + 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 +! +! 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 +! +! Initialisation des correspondances point -> indices i,j +! + if (( .not. allocated(correspond))) then + allocate(correspond(iim,jjm+1), stat = error) + if (error /= 0) then + abort_message='Pb allocation correspond' + call abort_gcm(modname,abort_message,1) + endif + endif +! +! Attention aux poles +! + do igrid = 1, knon + index = ktindex(igrid) + jj = int((index - 1)/iim) + 1 + ij = index - (jj - 1) * iim + correspond(ij,jj) = igrid + enddo + +! Allouer et initialiser le tableau de coordonnees du sol +! + 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) + ij = index - int((index-1)/iim)*iim - 1 + jj = 2 + int((index-1)/iim) + if (mod(index,iim) == 1 ) then + jj = 1 + int((index-1)/iim) + ij = iim + endif +! lon_scat(ij,jj) = rlon(index) +! lat_scat(ij,jj) = rlat(index) + enddo + index = 1 + do jj = 2, jjm + do ij = 1, iim + index = index + 1 + lon_scat(ij,jj) = rlon(index) + lat_scat(ij,jj) = rlat(index) + enddo + enddo + lon_scat(:,1) = lon_scat(:,2) + lat_scat(:,1) = rlat(1) + lon_scat(:,jjm+1) = lon_scat(:,2) + lat_scat(:,jjm+1) = rlat(klon) +! Pb de correspondances de grilles! +! do igrid = 1, knon +! index = ktindex(igrid) +! ij = ig(index) +! jj = jg(index) +! lon_scat(ij,jj) = rlon(index) +! lat_scat(ij,jj) = rlat(index) +! enddo + +! +! 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 + + do igrid = 1, knon + iglob = ktindex(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)) + if (pctsrf(ireal, is_ter) > EPSFRA) then + jj = int((index - 1)/iim) + 1 + ij = index - (jj - 1) * iim + neighbours(igrid, i) = correspond(ij, jj) + endif + enddo + enddo + +! +! 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) = cufi(ij) + resolution(igrid,2) = cvfi(ij) + enddo + + endif ! (fin debut) + +! +! Appel a la routine sols continentaux +! + if (lafin) lrestart_write = .true. + if (check) write(lunout,*)'lafin ',lafin,lrestart_write + + petA_orc = petBcoef * dtime + petB_orc = petAcoef + peqA_orc = peqBcoef * dtime + peqB_orc = peqAcoef + + cdrag = 0. + cdrag(1:knon) = tq_cdrag(1:knon) + +!IM cf. JP +++ +! 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) +!IM cf. JP --- + + +! PF et PASB +! where(cdrag > 0.01) +! cdrag = 0.01 +! endwhere +! write(*,*)'Cdrag = ',minval(cdrag),maxval(cdrag) + +! +! Init Orchidee +! + if (debut) then + 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) + +!IM cf. JP +++ + albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2. +!IM cf. JP --- + + endif + +!IM cf. JP +++ + swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon)) +!IM cf. JP --- + + 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) + +!IM cf. JP +++ + albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2. +!IM cf. JP --- + + bidule=0. + bidule(1:knon)=riverflow(1:knon) + call gath2cpl(bidule, tmp_rriv, klon, knon,iim,jjm,knindex) + bidule=0. + bidule(1:knon)=coastalflow(1:knon) + call gath2cpl(bidule, tmp_rcoa, klon, knon,iim,jjm,knindex) + alb_new(1:knon) = albedo_out(1:knon,1) + alblw(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. + + END SUBROUTINE interfsol +#endif +! +!######################################################################### +! + SUBROUTINE interfoce_cpl(itime, dtime, cumul, & + & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, & + & ocean, npas, nexca, debut, lafin, & + & swdown, lwdown, precip_rain, precip_snow, evap, tsurf, & + & fluxlat, fluxsens, fder, albsol, taux, tauy, zmasq, & + & tsurf_new, alb_new, pctsrf_new) + +! Cette routine sert d'interface entre le modele atmospherique et un +! coupleur avec un modele d'ocean 'complet' derriere +! +! Le modele de glace qu'il est prevu d'utiliser etant couple directement a +! l'ocean presentement, on va passer deux fois dans cette routine par pas de +! temps physique, une fois avec les points oceans et l'autre avec les points +! glace. A chaque pas de temps de couplage, la lecture des champs provenant +! du coupleur se fera "dans" l'ocean et l'ecriture des champs a envoyer +! au coupleur "dans" la glace. Il faut donc des tableaux de travail "tampons" +! dimensionnes sur toute la grille qui remplissent les champs sur les +! domaines ocean/glace quand il le faut. Il est aussi necessaire que l'index +! ocean soit traiter avant l'index glace (sinon tout intervertir) +! +! +! L. Fairhead 02/2000 +! +! input: +! itime numero du pas de temps +! iim, jjm nbres de pts de grille +! dtime pas de temps de la physique +! klon nombre total de points de grille +! nisurf index de la surface a traiter (1 = sol continental) +! pctsrf tableau des fractions de surface de chaque maille +! knon nombre de points de la surface a traiter +! knindex index des points de la surface a traiter +! rlon longitudes +! rlat latitudes +! debut logical: 1er appel a la physique +! lafin logical: dernier appel a la physique +! ocean type d'ocean +! nexca frequence de couplage +! swdown flux solaire entrant a la surface +! lwdown flux IR net a la surface +! precip_rain precipitation liquide +! precip_snow precipitation solide +! evap evaporation +! tsurf temperature de surface +! fder derivee dF/dT +! albsol albedo du sol (coherent avec swdown) +! taux tension de vent en x +! tauy tension de vent en y +! nexca frequence de couplage +! zmasq masque terre/ocean +! +! +! output: +! tsurf_new temperature au sol +! alb_new albedo +! pctsrf_new nouvelle repartition des surfaces +! alb_ice albedo de la glace +! + + +! Parametres d'entree + integer, intent(IN) :: itime + integer, intent(IN) :: iim, jjm + real, intent(IN) :: dtime + integer, intent(IN) :: klon + integer, intent(IN) :: nisurf + integer, intent(IN) :: knon + real, dimension(klon,nbsrf), intent(IN) :: pctsrf + integer, dimension(klon), intent(in) :: knindex + logical, intent(IN) :: debut, lafin + real, dimension(klon), intent(IN) :: rlon, rlat + character (len = 6) :: ocean + real, dimension(klon), intent(IN) :: lwdown, swdown + real, dimension(klon), intent(IN) :: precip_rain, precip_snow + real, dimension(klon), intent(IN) :: tsurf, fder, albsol, taux, tauy + INTEGER :: nexca, npas, kstep + real, dimension(klon), intent(IN) :: zmasq + real, dimension(klon), intent(IN) :: fluxlat, fluxsens + logical, intent(IN) :: cumul + real, dimension(klon), intent(INOUT) :: evap + +! Parametres de sortie + real, dimension(klon), intent(OUT):: tsurf_new, alb_new + real, dimension(klon,nbsrf), intent(OUT) :: pctsrf_new + +! Variables locales + integer :: j, error, sum_error, ig, cpl_index,i + character (len = 20) :: modname = 'interfoce_cpl' + character (len = 80) :: abort_message + logical,save :: check = .FALSE. +! variables pour moyenner les variables de couplage + real, allocatable, dimension(:,:),save :: cpl_sols, cpl_nsol, cpl_rain + real, allocatable, dimension(:,:),save :: cpl_snow, cpl_evap, cpl_tsol + real, allocatable, dimension(:,:),save :: cpl_fder, cpl_albe, cpl_taux + real, allocatable, dimension(:,:),save :: cpl_tauy + REAL, ALLOCATABLE, DIMENSION(:,:),SAVE :: cpl_rriv, cpl_rcoa, cpl_rlic +!!$ +! variables tampons avant le passage au coupleur + real, allocatable, dimension(:,:,:),save :: tmp_sols, tmp_nsol, tmp_rain + real, allocatable, dimension(:,:,:),save :: tmp_snow, tmp_evap, tmp_tsol + real, allocatable, dimension(:,:,:),save :: tmp_fder, tmp_albe, tmp_taux +!!$ real, allocatable, dimension(:,:,:),save :: tmp_tauy, tmp_rriv, tmp_rcoa + REAL, ALLOCATABLE, DIMENSION(:,:,:),SAVE :: tmp_tauy +! variables a passer au coupleur + real, dimension(iim, jjm+1) :: wri_sol_ice, wri_sol_sea, wri_nsol_ice + real, dimension(iim, jjm+1) :: wri_nsol_sea, wri_fder_ice, wri_evap_ice + REAL, DIMENSION(iim, jjm+1) :: wri_evap_sea, wri_rcoa, wri_rriv + REAL, DIMENSION(iim, jjm+1) :: wri_rain, wri_snow, wri_taux, wri_tauy + REAL, DIMENSION(iim, jjm+1) :: wri_calv + REAL, DIMENSION(iim, jjm+1) :: wri_tauxx, wri_tauyy, wri_tauzz + REAL, DIMENSION(iim, jjm+1) :: tmp_lon, tmp_lat +! variables relues par le coupleur +! read_sic = fraction de glace +! read_sit = temperature de glace + real, allocatable, dimension(:,:),save :: read_sst, read_sic, read_sit + real, allocatable, dimension(:,:),save :: read_alb_sic +! variable tampon + real, dimension(klon) :: tamp_sic +! sauvegarde des fractions de surface d'un pas de temps a l'autre apres +! l'avoir lu + real, allocatable,dimension(:,:),save :: pctsrf_sav + real, dimension(iim, jjm+1, 2) :: tamp_srf + integer, allocatable, dimension(:), save :: tamp_ind + real, allocatable, dimension(:,:),save :: tamp_zmasq + real, dimension(iim, jjm+1) :: deno + integer :: idtime + integer, allocatable,dimension(:),save :: unity +! + logical, save :: first_appel = .true. + logical,save :: print +!maf +! variables pour avoir une sortie IOIPSL des champs echanges + CHARACTER*80,SAVE :: clintocplnam, clfromcplnam + INTEGER, SAVE :: jf,nhoridct,nidct + INTEGER, SAVE :: nhoridcs,nidcs + INTEGER :: ndexct(iim*(jjm+1)),ndexcs(iim*(jjm+1)) + REAL :: zx_lon(iim,jjm+1), zx_lat(iim,jjm+1), zjulian + integer :: idayref, itau_w +#include "param_cou.h" +#include "inc_cpl.h" +#include "temps.inc" +! +! Initialisation +! + if (check) write(*,*)'Entree ',modname,'nisurf = ',nisurf + + if (first_appel) then + error = 0 + allocate(unity(klon), stat = error) + if ( error /=0) then + abort_message='Pb allocation variable unity' + call abort_gcm(modname,abort_message,1) + endif + allocate(pctsrf_sav(klon,nbsrf), stat = error) + if ( error /=0) then + abort_message='Pb allocation variable pctsrf_sav' + call abort_gcm(modname,abort_message,1) + endif + pctsrf_sav = 0. + + do ig = 1, klon + unity(ig) = ig + enddo + sum_error = 0 + allocate(cpl_sols(klon,2), stat = error); sum_error = sum_error + error + allocate(cpl_nsol(klon,2), stat = error); sum_error = sum_error + error + allocate(cpl_rain(klon,2), stat = error); sum_error = sum_error + error + allocate(cpl_snow(klon,2), stat = error); sum_error = sum_error + error + allocate(cpl_evap(klon,2), stat = error); sum_error = sum_error + error + allocate(cpl_tsol(klon,2), stat = error); sum_error = sum_error + error + allocate(cpl_fder(klon,2), stat = error); sum_error = sum_error + error + allocate(cpl_albe(klon,2), stat = error); sum_error = sum_error + error + allocate(cpl_taux(klon,2), stat = error); sum_error = sum_error + error + allocate(cpl_tauy(klon,2), stat = error); sum_error = sum_error + error + ALLOCATE(cpl_rriv(iim,jjm+1), stat=error); sum_error = sum_error + error + ALLOCATE(cpl_rcoa(iim,jjm+1), stat=error); sum_error = sum_error + error + ALLOCATE(cpl_rlic(iim,jjm+1), stat=error); sum_error = sum_error + error +!! + allocate(read_sst(iim, jjm+1), stat = error); sum_error = sum_error + error + allocate(read_sic(iim, jjm+1), stat = error); sum_error = sum_error + error + allocate(read_sit(iim, jjm+1), stat = error); sum_error = sum_error + error + allocate(read_alb_sic(iim, jjm+1), stat = error); sum_error = sum_error + error + + if (sum_error /= 0) then + abort_message='Pb allocation variables couplees' + call abort_gcm(modname,abort_message,1) + endif + cpl_sols = 0.; cpl_nsol = 0.; cpl_rain = 0.; cpl_snow = 0. + cpl_evap = 0.; cpl_tsol = 0.; cpl_fder = 0.; cpl_albe = 0. + cpl_taux = 0.; cpl_tauy = 0.; cpl_rriv = 0.; cpl_rcoa = 0.; cpl_rlic = 0. + + sum_error = 0 + allocate(tamp_ind(klon), stat = error); sum_error = sum_error + error + allocate(tamp_zmasq(iim, jjm+1), stat = error); sum_error = sum_error + error + do ig = 1, klon + tamp_ind(ig) = ig + enddo + call gath2cpl(zmasq, tamp_zmasq, klon, klon, iim, jjm, tamp_ind) +! +! initialisation couplage +! + idtime = int(dtime) + call inicma(npas , nexca, idtime,(jjm+1)*iim) + +! +! initialisation sorties netcdf +! + 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) + clintocplnam="cpl_atm_tauflx" + CALL histbeg(clintocplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),1,iim,1,jjm+1, & + & itau_phy,zjulian,dtime,nhoridct,nidct) +! no vertical axis + CALL histdef(nidct, 'tauxe','tauxe', & + & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime) + CALL histdef(nidct, 'tauyn','tauyn', & + & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime) + CALL histdef(nidct, 'tmp_lon','tmp_lon', & + & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime) + CALL histdef(nidct, 'tmp_lat','tmp_lat', & + & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime) + DO jf=1,jpflda2o1 + jpflda2o2 + CALL histdef(nidct, cl_writ(jf),cl_writ(jf), & + & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime) + END DO + CALL histend(nidct) + CALL histsync(nidct) + + clfromcplnam="cpl_atm_sst" + CALL histbeg(clfromcplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),1,iim,1,jjm+1, & + & 0,zjulian,dtime,nhoridcs,nidcs) +! no vertical axis + DO jf=1,jpfldo2a + CALL histdef(nidcs, cl_read(jf),cl_read(jf), & + & "-",iim, jjm+1, nhoridcs, 1, 1, 1, -99, 32, "inst", dtime,dtime) + END DO + CALL histend(nidcs) + CALL histsync(nidcs) + +! pour simuler la fonte des glaciers antarctiques +! + surf_maille = (4. * rpi * ra**2) / (iim * (jjm +1)) + ALLOCATE(coeff_iceberg(iim,jjm+1), stat=error) + if (error /= 0) then + abort_message='Pb allocation variable coeff_iceberg' + call abort_gcm(modname,abort_message,1) + endif + open (12,file='flux_iceberg',form='formatted',status='old') + read (12,*) coeff_iceberg + close (12) + num_antarctic = max(1, count(coeff_iceberg > 0)) + + first_appel = .false. + endif ! fin if (first_appel) + +! Initialisations + +! calcul des fluxs a passer + + cpl_index = 1 + if (nisurf == is_sic) cpl_index = 2 + if (cumul) then + if (check) write(*,*) modname, 'cumul des champs' + 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) + enddo + IF (cpl_index .EQ. 1) THEN + cpl_rriv(:,:) = cpl_rriv(:,:) + tmp_rriv(:,:) / FLOAT(nexca) + cpl_rcoa(:,:) = cpl_rcoa(:,:) + tmp_rcoa(:,:) / FLOAT(nexca) + cpl_rlic(:,:) = cpl_rlic(:,:) + tmp_rlic(:,:) / FLOAT(nexca) + ENDIF + endif + + if (mod(itime, nexca) == 1) then +! +! Demande des champs au coupleur +! +! Si le domaine considere est l'ocean, on lit les champs venant du coupleur +! + if (nisurf == is_oce .and. .not. cumul) then + if (check) write(*,*)'rentree fromcpl, itime-1 = ',itime-1 + call fromcpl(itime-1,(jjm+1)*iim, & + & read_sst, read_sic, read_sit, read_alb_sic) +! +! sorties NETCDF des champs recus +! + ndexcs(:)=0 + itau_w = itau_phy + itime + CALL histwrite(nidcs,cl_read(1),itau_w,read_sst,iim*(jjm+1),ndexcs) + CALL histwrite(nidcs,cl_read(2),itau_w,read_sic,iim*(jjm+1),ndexcs) + CALL histwrite(nidcs,cl_read(3),itau_w,read_alb_sic,iim*(jjm+1),ndexcs) + CALL histwrite(nidcs,cl_read(4),itau_w,read_sit,iim*(jjm+1),ndexcs) + CALL histsync(nidcs) +! pas utile IF (npas-itime.LT.nexca )CALL histclo(nidcs) + + do j = 1, jjm + 1 + do ig = 1, iim + if (abs(1. - read_sic(ig,j)) < 0.00001) then + read_sst(ig,j) = RTT - 1.8 + read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j) + read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j) + else if (abs(read_sic(ig,j)) < 0.00001) then + read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j)) + read_sit(ig,j) = read_sst(ig,j) + read_alb_sic(ig,j) = 0.6 + else + read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j)) + read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j) + read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j) + endif + enddo + enddo +! +! transformer read_sic en pctsrf_sav +! + call cpl2gath(read_sic, tamp_sic , klon, klon,iim,jjm, unity) + do ig = 1, klon + IF (pctsrf(ig,is_oce) > epsfra .OR. & + & pctsrf(ig,is_sic) > epsfra) THEN + pctsrf_sav(ig,is_sic) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) & + & * tamp_sic(ig) + pctsrf_sav(ig,is_oce) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) & + & - pctsrf_sav(ig,is_sic) + endif + enddo +! +! Pour rattraper des erreurs d'arrondis +! + where (abs(pctsrf_sav(:,is_sic)) .le. 2.*epsilon(pctsrf_sav(1,is_sic))) + pctsrf_sav(:,is_sic) = 0. + pctsrf_sav(:,is_oce) = pctsrf(:,is_oce) + pctsrf(:,is_sic) + endwhere + where (abs(pctsrf_sav(:,is_oce)) .le. 2.*epsilon(pctsrf_sav(1,is_oce))) + pctsrf_sav(:,is_sic) = pctsrf(:,is_oce) + pctsrf(:,is_sic) + pctsrf_sav(:,is_oce) = 0. + endwhere + if (minval(pctsrf_sav(:,is_oce)) < 0.) then + write(*,*)'Pb fraction ocean inferieure a 0' + write(*,*)'au point ',minloc(pctsrf_sav(:,is_oce)) + write(*,*)'valeur = ',minval(pctsrf_sav(:,is_oce)) + abort_message = 'voir ci-dessus' + call abort_gcm(modname,abort_message,1) + endif + if (minval(pctsrf_sav(:,is_sic)) < 0.) then + write(*,*)'Pb fraction glace inferieure a 0' + write(*,*)'au point ',minloc(pctsrf_sav(:,is_sic)) + write(*,*)'valeur = ',minval(pctsrf_sav(:,is_sic)) + abort_message = 'voir ci-dessus' + call abort_gcm(modname,abort_message,1) + endif + endif + endif ! fin mod(itime, nexca) == 1 + + if (mod(itime, nexca) == 0) then +! +! allocation memoire + if (nisurf == is_oce .and. (.not. cumul) ) then + sum_error = 0 + allocate(tmp_sols(iim,jjm+1,2), stat=error); sum_error = sum_error + error + allocate(tmp_nsol(iim,jjm+1,2), stat=error); sum_error = sum_error + error + allocate(tmp_rain(iim,jjm+1,2), stat=error); sum_error = sum_error + error + allocate(tmp_snow(iim,jjm+1,2), stat=error); sum_error = sum_error + error + allocate(tmp_evap(iim,jjm+1,2), stat=error); sum_error = sum_error + error + allocate(tmp_tsol(iim,jjm+1,2), stat=error); sum_error = sum_error + error + allocate(tmp_fder(iim,jjm+1,2), stat=error); sum_error = sum_error + error + allocate(tmp_albe(iim,jjm+1,2), stat=error); sum_error = sum_error + error + allocate(tmp_taux(iim,jjm+1,2), stat=error); sum_error = sum_error + error + allocate(tmp_tauy(iim,jjm+1,2), stat=error); sum_error = sum_error + error +!!$ allocate(tmp_rriv(iim,jjm+1,2), stat=error); sum_error = sum_error + error +!!$ allocate(tmp_rcoa(iim,jjm+1,2), stat=error); sum_error = sum_error + error + if (sum_error /= 0) then + abort_message='Pb allocation variables couplees pour l''ecriture' + call abort_gcm(modname,abort_message,1) + endif + endif + +! +! Mise sur la bonne grille des champs a passer au coupleur +! + cpl_index = 1 + if (nisurf == is_sic) cpl_index = 2 + call gath2cpl(cpl_sols(1,cpl_index), tmp_sols(1,1,cpl_index), klon, knon,iim,jjm, knindex) + call gath2cpl(cpl_nsol(1,cpl_index), tmp_nsol(1,1,cpl_index), klon, knon,iim,jjm, knindex) + call gath2cpl(cpl_rain(1,cpl_index), tmp_rain(1,1,cpl_index), klon, knon,iim,jjm, knindex) + call gath2cpl(cpl_snow(1,cpl_index), tmp_snow(1,1,cpl_index), klon, knon,iim,jjm, knindex) + call gath2cpl(cpl_evap(1,cpl_index), tmp_evap(1,1,cpl_index), klon, knon,iim,jjm, knindex) + call gath2cpl(cpl_tsol(1,cpl_index), tmp_tsol(1,1,cpl_index), klon, knon,iim,jjm, knindex) + call gath2cpl(cpl_fder(1,cpl_index), tmp_fder(1,1,cpl_index), klon, knon,iim,jjm, knindex) + call gath2cpl(cpl_albe(1,cpl_index), tmp_albe(1,1,cpl_index), klon, knon,iim,jjm, knindex) + call gath2cpl(cpl_taux(1,cpl_index), tmp_taux(1,1,cpl_index), klon, knon,iim,jjm, knindex) + call gath2cpl(cpl_tauy(1,cpl_index), tmp_tauy(1,1,cpl_index), klon, knon,iim,jjm, knindex) + +! +! Si le domaine considere est la banquise, on envoie les champs au coupleur +! + if (nisurf == is_sic .and. cumul) then + wri_rain = 0.; wri_snow = 0.; wri_rcoa = 0.; wri_rriv = 0. + wri_taux = 0.; wri_tauy = 0. + call gath2cpl(pctsrf(1,is_oce), tamp_srf(1,1,1), klon, klon, iim, jjm, tamp_ind) + call gath2cpl(pctsrf(1,is_sic), tamp_srf(1,1,2), klon, klon, iim, jjm, tamp_ind) + + wri_sol_ice = tmp_sols(:,:,2) + wri_sol_sea = tmp_sols(:,:,1) + wri_nsol_ice = tmp_nsol(:,:,2) + wri_nsol_sea = tmp_nsol(:,:,1) + wri_fder_ice = tmp_fder(:,:,2) + wri_evap_ice = tmp_evap(:,:,2) + wri_evap_sea = tmp_evap(:,:,1) +!!$PB + wri_rriv = cpl_rriv(:,:) + wri_rcoa = cpl_rcoa(:,:) + DO j = 1, jjm + 1 + wri_calv(:,j) = sum(cpl_rlic(:,j)) / iim + enddo + + where (tamp_zmasq /= 1.) + deno = tamp_srf(:,:,1) + tamp_srf(:,:,2) + wri_rain = tmp_rain(:,:,1) * tamp_srf(:,:,1) / deno + & + & tmp_rain(:,:,2) * tamp_srf(:,:,2) / deno + wri_snow = tmp_snow(:,:,1) * tamp_srf(:,:,1) / deno + & + & tmp_snow(:,:,2) * tamp_srf(:,:,2) / deno + wri_taux = tmp_taux(:,:,1) * tamp_srf(:,:,1) / deno + & + & tmp_taux(:,:,2) * tamp_srf(:,:,2) / deno + wri_tauy = tmp_tauy(:,:,1) * tamp_srf(:,:,1) / deno + & + & tmp_tauy(:,:,2) * tamp_srf(:,:,2) / deno + endwhere +! +! pour simuler la fonte des glaciers antarctiques +! +!$$$ wri_rain = wri_rain & +!$$$ & + coeff_iceberg * cte_flux_iceberg / (num_antarctic * surf_maille) +! wri_calv = coeff_iceberg * cte_flux_iceberg / (num_antarctic * surf_maille) +! +! on passe les coordonnées de la grille +! + + CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,tmp_lon) + CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,tmp_lat) + + DO i = 1, iim + tmp_lon(i,1) = rlon(i+1) + tmp_lon(i,jjm + 1) = rlon(i+1) + ENDDO +! +! sortie netcdf des champs pour le changement de repere +! + ndexct(:)=0 + CALL histwrite(nidct,'tauxe',itau_w,wri_taux,iim*(jjm+1),ndexct) + CALL histwrite(nidct,'tauyn',itau_w,wri_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) + +! +! calcul 3 coordonnées du vent +! + CALL atm2geo (iim , jjm + 1, wri_taux, wri_tauy, tmp_lon, tmp_lat, & + & wri_tauxx, wri_tauyy, wri_tauzz ) +! +! sortie netcdf des champs apres changement de repere et juste avant +! envoi au coupleur +! + CALL histwrite(nidct,cl_writ(1),itau_w,wri_sol_ice,iim*(jjm+1),ndexct) + CALL histwrite(nidct,cl_writ(2),itau_w,wri_sol_sea,iim*(jjm+1),ndexct) + CALL histwrite(nidct,cl_writ(3),itau_w,wri_nsol_ice,iim*(jjm+1),ndexct) + CALL histwrite(nidct,cl_writ(4),itau_w,wri_nsol_sea,iim*(jjm+1),ndexct) + CALL histwrite(nidct,cl_writ(5),itau_w,wri_fder_ice,iim*(jjm+1),ndexct) + CALL histwrite(nidct,cl_writ(6),itau_w,wri_evap_ice,iim*(jjm+1),ndexct) + CALL histwrite(nidct,cl_writ(7),itau_w,wri_evap_sea,iim*(jjm+1),ndexct) + CALL histwrite(nidct,cl_writ(8),itau_w,wri_rain,iim*(jjm+1),ndexct) + CALL histwrite(nidct,cl_writ(9),itau_w,wri_snow,iim*(jjm+1),ndexct) + CALL histwrite(nidct,cl_writ(10),itau_w,wri_rcoa,iim*(jjm+1),ndexct) + CALL histwrite(nidct,cl_writ(11),itau_w,wri_rriv,iim*(jjm+1),ndexct) + CALL histwrite(nidct,cl_writ(12),itau_w,wri_calv,iim*(jjm+1),ndexct) + CALL histwrite(nidct,cl_writ(13),itau_w,wri_tauxx,iim*(jjm+1),ndexct) + CALL histwrite(nidct,cl_writ(14),itau_w,wri_tauyy,iim*(jjm+1),ndexct) + CALL histwrite(nidct,cl_writ(15),itau_w,wri_tauzz,iim*(jjm+1),ndexct) + CALL histwrite(nidct,cl_writ(16),itau_w,wri_tauxx,iim*(jjm+1),ndexct) + CALL histwrite(nidct,cl_writ(17),itau_w,wri_tauyy,iim*(jjm+1),ndexct) + CALL histwrite(nidct,cl_writ(18),itau_w,wri_tauzz,iim*(jjm+1),ndexct) + CALL histsync(nidct) +! pas utile IF (lafin) CALL histclo(nidct) + call intocpl(itime, (jjm+1)*iim, wri_sol_ice, wri_sol_sea, wri_nsol_ice,& + & wri_nsol_sea, wri_fder_ice, wri_evap_ice, wri_evap_sea, wri_rain, & + & wri_snow, wri_rcoa, wri_rriv, wri_calv, wri_tauxx, wri_tauyy, & + & wri_tauzz, wri_tauxx, wri_tauyy, wri_tauzz,lafin ) +! + cpl_sols = 0.; cpl_nsol = 0.; cpl_rain = 0.; cpl_snow = 0. + cpl_evap = 0.; cpl_tsol = 0.; cpl_fder = 0.; cpl_albe = 0. + cpl_taux = 0.; cpl_tauy = 0.; cpl_rriv = 0.; cpl_rcoa = 0.; cpl_rlic = 0. +! +! deallocation memoire variables temporaires +! + sum_error = 0 + deallocate(tmp_sols, stat=error); sum_error = sum_error + error + deallocate(tmp_nsol, stat=error); sum_error = sum_error + error + deallocate(tmp_rain, stat=error); sum_error = sum_error + error + deallocate(tmp_snow, stat=error); sum_error = sum_error + error + deallocate(tmp_evap, stat=error); sum_error = sum_error + error + deallocate(tmp_fder, stat=error); sum_error = sum_error + error + deallocate(tmp_tsol, stat=error); sum_error = sum_error + error + deallocate(tmp_albe, stat=error); sum_error = sum_error + error + deallocate(tmp_taux, stat=error); sum_error = sum_error + error + deallocate(tmp_tauy, stat=error); sum_error = sum_error + error +!!$PB +!!$ deallocate(tmp_rriv, stat=error); sum_error = sum_error + error +!!$ deallocate(tmp_rcoa, stat=error); sum_error = sum_error + error + if (sum_error /= 0) then + abort_message='Pb deallocation variables couplees' + call abort_gcm(modname,abort_message,1) + endif + + endif + + endif ! fin (mod(itime, nexca) == 0) +! +! on range les variables lues/sauvegardees dans les bonnes variables de sortie +! + if (nisurf == is_oce) then + call cpl2gath(read_sst, tsurf_new, klon, knon,iim,jjm, knindex) + else if (nisurf == is_sic) then + call cpl2gath(read_sit, tsurf_new, klon, knon,iim,jjm, knindex) + call cpl2gath(read_alb_sic, alb_new, klon, knon,iim,jjm, knindex) + endif + pctsrf_new(:,nisurf) = pctsrf_sav(:,nisurf) + +! if (lafin) call quitcpl + + END SUBROUTINE interfoce_cpl +! +!######################################################################### +! + + SUBROUTINE interfoce_slab(nisurf) + +! Cette routine sert d'interface entre le modele atmospherique et un +! modele de 'slab' ocean +! +! L. Fairhead 02/2000 +! +! input: +! nisurf index de la surface a traiter (1 = sol continental) +! +! output: +! + +! Parametres d'entree + integer, intent(IN) :: nisurf + + END SUBROUTINE interfoce_slab +! +!######################################################################### +! + SUBROUTINE interfoce_lim(itime, dtime, jour, & + & klon, nisurf, knon, knindex, & + & debut, & + & lmt_sst, pctsrf_new) + +! 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 SST lues dans le fichier de CL +! pctsrf_new sous-maille fractionnelle +! + + +! Parametres d'entree + integer, intent(IN) :: itime + real , intent(IN) :: dtime + integer, intent(IN) :: jour + integer, intent(IN) :: nisurf + integer, intent(IN) :: knon + integer, intent(IN) :: klon + integer, dimension(klon), intent(in) :: knindex + logical, intent(IN) :: debut + +! Parametres de sortie + real, intent(out), dimension(klon) :: lmt_sst + real, intent(out), dimension(klon,nbsrf) :: pctsrf_new + +! Variables locales + integer :: ii + INTEGER,save :: lmt_pas ! frequence de lecture des conditions limites + ! (en pas de physique) + logical,save :: deja_lu ! pour indiquer que le jour a lire a deja + ! lu pour une surface precedente + integer,save :: jour_lu + integer :: ierr + character (len = 20) :: modname = 'interfoce_lim' + character (len = 80) :: abort_message + character (len = 20),save :: fich ='limit.nc' + logical, save :: newlmt = .TRUE. + logical, save :: check = .FALSE. +! Champs lus dans le fichier de CL + real, allocatable , save, dimension(:) :: sst_lu, rug_lu, nat_lu + real, allocatable , save, dimension(:,:) :: pct_tmp +! +! quelques variables pour netcdf +! +#include "netcdf.inc" + integer :: nid, nvarid + integer, dimension(2) :: start, epais +! +! Fin déclaration +! + + if (debut .and. .not. allocated(sst_lu)) then + lmt_pas = nint(86400./dtime * 1.0) ! pour une lecture une fois par jour + jour_lu = jour - 1 + allocate(sst_lu(klon)) + allocate(nat_lu(klon)) + allocate(pct_tmp(klon,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 + +! Tester d'abord si c'est le moment de lire le fichier + if (mod(itime-1, lmt_pas) == 0 .and. .not. deja_lu) then +! +! Ouverture du fichier +! + 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 + 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 + 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 +! + ierr = NF_CLOSE(nid) + deja_lu = .true. + jour_lu = jour + endif +! +! Recopie des variables dans les champs de sortie +! + lmt_sst = 999999999. + do ii = 1, knon + lmt_sst(ii) = sst_lu(knindex(ii)) + enddo + + pctsrf_new(:,is_oce) = pct_tmp(:,is_oce) + pctsrf_new(:,is_sic) = pct_tmp(:,is_sic) + + END SUBROUTINE interfoce_lim + +! +!######################################################################### +! + SUBROUTINE interfsur_lim(itime, dtime, jour, & + & klon, nisurf, knon, knindex, & + & debut, & + & lmt_alb, lmt_rug) + +! 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 SST lues dans le fichier de CL +! lmt_alb Albedo lu +! lmt_rug longueur de rugosité lue +! pctsrf_new sous-maille fractionnelle +! + + +! Parametres d'entree + integer, intent(IN) :: itime + real , intent(IN) :: dtime + integer, intent(IN) :: jour + integer, intent(IN) :: nisurf + integer, intent(IN) :: knon + integer, intent(IN) :: klon + integer, dimension(klon), intent(in) :: knindex + logical, intent(IN) :: debut + +! Parametres de sortie + real, intent(out), dimension(klon) :: lmt_alb + real, intent(out), dimension(klon) :: lmt_rug + +! Variables locales + integer :: ii + integer,save :: lmt_pas ! frequence de lecture des conditions limites + ! (en pas de physique) + logical,save :: deja_lu_sur! pour indiquer que le jour a lire a deja + ! lu pour une surface precedente + integer,save :: jour_lu_sur + integer :: ierr + character (len = 20) :: modname = 'interfsur_lim' + character (len = 80) :: abort_message + character (len = 20),save :: fich ='limit.nc' + logical,save :: newlmt = .false. + logical,save :: check = .false. +! Champs lus dans le fichier de CL + real, allocatable , save, dimension(:) :: alb_lu, rug_lu +! +! quelques variables pour netcdf +! +#include "netcdf.inc" + integer ,save :: nid, nvarid + integer, dimension(2),save :: start, epais +! +! Fin déclaration +! + + if (debut) then + lmt_pas = nint(86400./dtime * 1.0) ! pour une lecture une fois par jour + jour_lu_sur = jour - 1 + allocate(alb_lu(klon)) + allocate(rug_lu(klon)) + endif + + if ((jour - jour_lu_sur) /= 0) deja_lu_sur = .false. + + if (check) write(*,*)modname,':: jour_lu_sur, deja_lu_sur', jour_lu_sur, deja_lu_sur + if (check) write(*,*)modname,':: itime, lmt_pas', itime, lmt_pas + if (check) call flush(6) + +! Tester d'abord si c'est le moment de lire le fichier + if (mod(itime-1, lmt_pas) == 0 .and. .not. deja_lu_sur) then +! +! Ouverture du fichier +! + fich = trim(fich) + IF (check) WRITE(*,*)modname,' ouverture fichier ',fich + if (check) CALL flush(6) + 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 + epais(2) = 1 +! +! Lecture Albedo +! + ierr = NF_INQ_VARID(nid, 'ALB', 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, alb_lu) +#else + ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, alb_lu) +#endif + if (ierr /= NF_NOERR) then + abort_message = 'Lecture echouee pour ' + call abort_gcm(modname,abort_message,1) + endif +! +! Lecture rugosité +! + ierr = NF_INQ_VARID(nid, 'RUG', 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, rug_lu) +#else + ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, rug_lu) +#endif + if (ierr /= NF_NOERR) then + abort_message = 'Lecture echouee pour ' + call abort_gcm(modname,abort_message,1) + endif + +! +! Fin de lecture +! + ierr = NF_CLOSE(nid) + deja_lu_sur = .true. + jour_lu_sur = jour + endif +! +! Recopie des variables dans les champs de sortie +! +!!$ lmt_alb(:) = 0.0 +!!$ lmt_rug(:) = 0.0 + lmt_alb(:) = 999999. + lmt_rug(:) = 999999. + DO ii = 1, knon + lmt_alb(ii) = alb_lu(knindex(ii)) + lmt_rug(ii) = rug_lu(knindex(ii)) + enddo + + END SUBROUTINE interfsur_lim + +! +!######################################################################### +! + + SUBROUTINE calcul_fluxs( klon, 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) + +! 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.inc" +#include "FCTTRE.inc" +#include "indicesol.inc" + +! Parametres d'entree + integer, intent(IN) :: knon, nisurf, klon + 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 + real, dimension(klon), intent(IN) :: radsol, dif_grnd + real, dimension(klon), intent(IN) :: t1lay, u1lay, v1lay + real, dimension(klon), intent(INOUT) :: snow, qsurf + +! Parametres sorties + 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) :: zx_q_0 , d_ts + real :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh + real :: bilan_f, fq_fonte + REAL :: subli, fsno + REAL :: qsat_new, q1_new + real, parameter :: t_grnd = 271.35, t_coup = 273.15 +!! PB temporaire en attendant mieux pour le modele de neige + REAL, parameter :: chasno = 3.334E+05/(2.3867E+06*0.15) +! + logical, save :: check = .false. + character (len = 20) :: modname = 'calcul_fluxs' + logical, save :: fonte_neige = .false. + real, save :: max_eau_sol = 150.0 + character (len = 80) :: abort_message + logical,save :: first = .true.,second=.false. + + if (check) write(*,*)'Entree ', modname,' surface = ',nisurf + + IF (check) THEN + WRITE(*,*)' radsol (min, max)' & + & , MINVAL(radsol(1:knon)), MAXVAL(radsol(1:knon)) + CALL flush(6) + ENDIF + + if (size(coastalflow) /= knon .AND. nisurf == is_ter) then + write(*,*)'Bizarre, le nombre de points continentaux' + write(*,*)'a change entre deux appels. J''arrete ...' + abort_message='Pb run_off' + call abort_gcm(modname,abort_message,1) + 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 gath2cpl(champ_in, champ_out, klon, knon, iim, jjm, knindex) + +! 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 +! klon taille de la grille +! iim,jjm dimension de la grille 2D +! +! output: +! champ_out champ sur la grille 2D +! +! input + integer :: klon, knon, iim, jjm + real, dimension(klon) :: champ_in + integer, dimension(klon) :: knindex +! output + real, dimension(iim,jjm+1) :: champ_out +! local + integer :: i, ig, j + real, dimension(klon) :: tamp + + tamp = 0. + do i = 1, knon + ig = knindex(i) + tamp(ig) = champ_in(i) + enddo + ig = 1 + champ_out(:,1) = tamp(ig) + do j = 2, jjm + do i = 1, iim + ig = ig + 1 + champ_out(i,j) = tamp(ig) + enddo + enddo + ig = ig + 1 + champ_out(:,jjm+1) = tamp(ig) + + END SUBROUTINE gath2cpl +! +!######################################################################### +! + SUBROUTINE cpl2gath(champ_in, champ_out, klon, knon, iim, jjm, knindex) + +! 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 +! klon taille de la grille +! iim,jjm dimension de la grille 2D +! +! output: +! champ_out champ sur la grille 2D +! +! input + integer :: klon, knon, iim, jjm + real, dimension(iim,jjm+1) :: champ_in + integer, dimension(klon) :: knindex +! output + real, dimension(klon) :: champ_out +! local + integer :: i, ig, j + real, dimension(klon) :: tamp + logical ,save :: check = .false. + + ig = 1 + tamp(ig) = champ_in(1,1) + do j = 2, jjm + do i = 1, iim + ig = ig + 1 + tamp(ig) = champ_in(i,j) + enddo + enddo + ig = ig + 1 + tamp(ig) = champ_in(1,jjm+1) + + do i = 1, knon + ig = knindex(i) + champ_out(i) = tamp(ig) + enddo + + END SUBROUTINE cpl2gath +! +!######################################################################### +! + SUBROUTINE albsno(klon, knon,dtime,agesno,alb_neig_grid, precip_snow) + IMPLICIT none + + INTEGER :: klon, knon + INTEGER, PARAMETER :: nvm = 8 + REAL :: dtime + REAL, dimension(klon,nvm) :: veget + REAL, DIMENSION(klon) :: alb_neig_grid, agesno, precip_snow + + INTEGER :: i, nv + + REAL, DIMENSION(nvm),SAVE :: init, decay + REAL :: as + 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 +! +!######################################################################### +! + + SUBROUTINE fonte_neige( klon, knon, nisurf, dtime, & + & tsurf, p1lay, cal, beta, coef1lay, ps, & + & precip_rain, precip_snow, snow, qsol, & + & radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, & + & petAcoef, peqAcoef, petBcoef, peqBcoef, & + & tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, & + & fqcalving,ffonte,run_off_lic_0) + +! Routine de traitement de la fonte de la neige dans le cas du traitement +! de sol simplifié +! +! LF 03/2001 +! 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 +! qsol hauteur d'eau contenu dans le sol +! 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 +! 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 +! in/out: +! run_off_lic_0 run off glacier du pas de temps précedent +! + +#include "YOETHF.inc" +#include "FCTTRE.inc" +#include "indicesol.inc" +!IM cf JLD +#include "YOMCST.inc" + +! Parametres d'entree + integer, intent(IN) :: knon, nisurf, klon + 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 + real, dimension(klon), intent(IN) :: radsol, dif_grnd + real, dimension(klon), intent(IN) :: t1lay, u1lay, v1lay + real, dimension(klon), intent(INOUT) :: snow, qsol + +! Parametres sorties + real, dimension(klon), intent(INOUT):: tsurf_new, evap, fluxsens, fluxlat + real, dimension(klon), intent(INOUT):: dflux_s, dflux_l +! Flux thermique utiliser pour fondre la neige + real, dimension(klon), intent(INOUT):: ffonte +! Flux d'eau "perdue" par la surface et necessaire pour que limiter la +! hauteur de neige, en kg/m2/s + real, dimension(klon), intent(INOUT):: fqcalving + real, dimension(klon), intent(INOUT):: run_off_lic_0 +! Variables locales +! Masse maximum de neige (kg/m2). Au dessus de ce seuil, la neige +! en exces "s'ecoule" (calving) +! real, parameter :: snow_max=1. +!IM cf JLD/GK + real, parameter :: snow_max=3000. + 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) :: zx_q_0 , d_ts + real :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh + real :: bilan_f, fq_fonte + REAL :: subli, fsno + REAL, DIMENSION(klon) :: bil_eau_s, snow_evap + real, parameter :: t_grnd = 271.35, t_coup = 273.15 +!! 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 +! + logical, save :: check = .FALSE. + character (len = 20) :: modname = 'fonte_neige' + logical, save :: neige_fond = .false. + real, save :: max_eau_sol = 150.0 + character (len = 80) :: abort_message + logical,save :: first = .true.,second=.false. + real :: coeff_rel + + + if (check) write(*,*)'Entree ', modname,' surface = ',nisurf + +! Initialisations + coeff_rel = dtime/(tau_calv * rday) + bil_eau_s(:) = 0. + 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) + enddo + + + WHERE (precip_snow > 0.) snow = snow + (precip_snow * dtime) + 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 = bil_eau_s + (precip_rain * dtime) - (evap - snow_evap) * dtime + bil_eau_s = (precip_rain * dtime) - (evap - snow_evap) * dtime + +! +! Y'a-t-il fonte de neige? +! + ffonte=0. + do i = 1, knon + 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 + 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 + bil_eau_s(i) = bil_eau_s(i) + fq_fonte + 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) +! + IF (nisurf == is_ter) then + qsol(i) = qsol(i) + bil_eau_s(i) + run_off(i) = run_off(i) + MAX(qsol(i) - max_eau_sol, 0.0) + qsol(i) = MIN(qsol(i), max_eau_sol) + else if (nisurf == is_lic) then + run_off_lic(i) = (coeff_rel * fqcalving(i)) + & + & (1. - coeff_rel) * run_off_lic_0(i) + run_off_lic_0(i) = run_off_lic(i) + run_off_lic(i) = run_off_lic(i) + bil_eau_s(i)/dtime + endif + enddo + + END SUBROUTINE fonte_neige +! +!######################################################################### +! + END MODULE interface_surf Index: /LMDZ4/trunk/libf/phylmd/isccp_cloud_types.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/isccp_cloud_types.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/isccp_cloud_types.F (revision 524) @@ -0,0 +1,1669 @@ +! +! $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 + &) + +!$Id$ + +! 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 ibox=1,ncol + do ilev=1,nlev + 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/trunk/libf/phylmd/lnblnk1.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/lnblnk1.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/lnblnk1.F (revision 524) @@ -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/trunk/libf/phylmd/minmaxqfi.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/minmaxqfi.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/minmaxqfi.F (revision 524) @@ -0,0 +1,33 @@ +! +! $Header$ +! + SUBROUTINE minmaxqfi(zq,qmin,qmax,comment) + IMPLICIT none + +#include "dimensions.h" +#include "dimphy.h" + + CHARACTER*(*) comment + real qmin,qmax + real zq(klon,klev) + + INTEGER jadrs(klon), jbad, k, i + + 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 + PRINT*, comment + DO i = 1, jbad + PRINT*, "i,k,q=", jadrs(i),k,zq(jadrs(i),k) + ENDDO + ENDIF + ENDDO + + return + end Index: /LMDZ4/trunk/libf/phylmd/mpiclim.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/mpiclim.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/mpiclim.h (revision 524) @@ -0,0 +1,24 @@ +! +! $Header$ +! +C +C -- mpiclim.h 26-10-99 Version 2.4 Author: Jean Latour (F.S.E.) +C ********* +C@ +C@ Contents : variables related to MPI-2 message passing +C@ -------- +C@ +C@ -- mpi_totproc: number of processors on which to launch each model +C@ +C@ -- mpi_nproc: number of processors involved in the coupling for +C@ each model +C@ -- cmpi_modnam: models name +C ----------------------------------------------------------------- +C + INTEGER*4 mpi_totproc(1:CLIM_MaxMod-1),mpi_nproc(0:CLIM_MaxMod-1) +C + CHARACTER*6 cmpi_modnam(1:CLIM_MaxMod-1) +C + common/CLIM_mpiclim/mpi_totproc, mpi_nproc, cmpi_modnam +C +C ----------------------------------------------------------------- Index: /LMDZ4/trunk/libf/phylmd/newmicro.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/newmicro.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/newmicro.F (revision 524) @@ -0,0 +1,320 @@ +! +! $Header$ +! + 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 sulfate, sulfate_pi, + e bl95_b0, bl95_b1, + s cldtaupi, re, fl) + 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 sulfate-input-R-sulfate aerosol mass concentration [um/m^3] +c sulfate_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 +#include "dimensions.h" +#include "dimphy.h" +#include "nuage.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 sulfate(klon, klev) ! sulfate aerosol mass concentration [ug m-3] + REAL cdnc(klon, klev) ! cloud droplet number concentration [m-3] + REAL re(klon, klev) ! cloud droplet effective radius [um] + REAL sulfate_pi(klon, klev) ! sulfate aerosol mass concentration [ug m-3] (pre-industrial value) + 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 +c +c Calculer l'epaisseur optique et l'emmissivite des nuages +c +cIM inversion des DO + DO i = 1, klon + xflwp(i)=0. + xfiwp(i)=0. + DO k = 1, klev +c + xflwc(i,k)=0. + xfiwc(i,k)=0. +c + rad_chaud = rad_chau1 + IF (k.LE.3) rad_chaud = rad_chau2 + pclc(i,k) = MAX(pclc(i,k), seuil_neb) + zflwp(i) = 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 + radius = rad_chaud * (1.-zfice) + rad_froid * zfice + coef = coef_chau * (1.-zfice) + coef_froi * zfice + pcltau(i,k) = 3.0/2.0 * zflwp(i) / radius + pclemi(i,k) = 1.0 - EXP( - coef * zflwp(i)) + + if (ok_newmicro) then + +c -- liquid/ice cloud water paths: + + zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace) + zfice = MIN(MAX(zfice,0.0),1.0) + + zflwp(i) = 1000.*(1.-zfice)*pqlwp(i,k)/pclc(i,k) + : *(paprs(i,k)-paprs(i,k+1))/RG + zfiwp(i) = 1000.*zfice*pqlwp(i,k)/pclc(i,k) + : *(paprs(i,k)-paprs(i,k+1))/RG + + xflwp(i) = xflwp(i)+ (1.-zfice)*pqlwp(i,k) + : *(paprs(i,k)-paprs(i,k+1))/RG + xfiwp(i) = xfiwp(i)+ zfice*pqlwp(i,k) + : *(paprs(i,k)-paprs(i,k+1))/RG + +cIM Total Liquid/Ice water content + xflwc(i,k) = xflwc(i,k)+(1.-zfice)*pqlwp(i,k) + xfiwc(i,k) = xfiwc(i,k)+zfice*pqlwp(i,k) +cIM 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) + +c -- effective cloud droplet radius (microns): + +c for liquid water clouds: + IF (ok_aie) THEN + ! Formula "D" of Boucher and Lohmann, Tellus, 1995 + ! + cdnc(i,k) = 10.**(bl95_b0+bl95_b1* + . log(MAX(sulfate(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(sulfate_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. + ! +c rad_chaud = MAX(rad_chaud*1.e6, 3.) + rad_chaud = MAX(rad_chaud*1.e6, 5.) + + ! 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 = + . 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*1.e6, 3.) + + tc = t(i,k)-273.15 + rei = 0.71*tc + 61.29 + if (tc.le.-81.4) rei = 3.5 + if (zflwp(i).eq.0.) radius = 1. + if (zfiwp(i).eq.0. .or. rei.le.0.) rei = 1. + cldtaupi(i,k) = 3.0/2.0 * zflwp(i) / radius + . + zfiwp(i) * (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.-zfice) + re(i,k) = rad_chaud*fl(i,k) + +c-jq end + + rel = rad_chaud +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(i).eq.0.) rel = 1. + if (zfiwp(i).eq.0. .or. rei.le.0.) rei = 1. + pcltau(i,k) = 3.0/2.0 * ( zflwp(i)/rel ) + . + zfiwp(i) * (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(i) - DF*k_ice*zfiwp(i) ) + + endif ! ok_newmicro + + 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 (lo) cldtaupi(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 Index: /LMDZ4/trunk/libf/phylmd/nflxtr.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/nflxtr.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/nflxtr.F (revision 524) @@ -0,0 +1,165 @@ +! +! $Header$ +! + SUBROUTINE nflxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d, + . pplay,paprs,x,dx) + 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 +c mais pas pour les entrees x, pplay, paprs !!!! +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 +#include "dimensions.h" +#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 + + REAL pplay(klon,klev) ! pression aux couches (bas en haut) + REAL paprs(klon,klev+1) ! pression aux 1/2 couches (bas en haut) + REAL x(klon,klev) ! q de traceur (bas en haut) + REAL dx(klon,klev) ! tendance de traceur (bas en haut) +c +c--flux convectifs mais en variables locales + REAL zmfu(klon,klev+1) + REAL zmfd(klon,klev+1) + REAL zen_u(klon,klev) + REAL zde_u(klon,klev) + REAL zen_d(klon,klev) + REAL zde_d(klon,klev) + real zmfe +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 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 +c +c Extension des flux UP et DN sur klev+1 niveaux +c ========================================= + 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 + +c--modif pour diagnostiquer les detrainements +c ========================================= +c 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 +c +c--calcul des flux dans le panache montant +c ========================================= +c +c Dans la premiere couche, on prend q comme valeur de qu +c + do i=1, klon + zmfux(i,1)=0.0 + enddo +c +c 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)) + s /(zmfu(i,k+1)+zde_u(i,k)) + endif + zmfux(i,k+1)=zmfu(i,k+1)*xu(i,k) + enddo + enddo +c +c--calcul des flux dans le panache descendant +c ========================================= +c + do i=1, klon + zmfdx(i,klev+1)=0.0 + enddo +c + 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 +c +c--introduction du flux de retour dans l'environnement +c ========================================= +c + 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 +c +c--calcul final des tendances +c + 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 +c + return + end Index: /LMDZ4/trunk/libf/phylmd/nuage.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/nuage.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/nuage.F (revision 524) @@ -0,0 +1,406 @@ +! +! $Header$ +! + SUBROUTINE nuage (paprs, pplay, + . t, pqlwp, pclc, pcltau, pclemi, + . pch, pcl, pcm, pct, pctlwp, + e ok_aie, + e sulfate, sulfate_pi, + e bl95_b0, bl95_b1, + s cldtaupi, re, fl) + 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 sulfate-input-R-sulfate aerosol mass concentration [um/m^3] +c sulfate_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 +#include "dimensions.h" +#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 sulfate(klon, klev) ! sulfate aerosol mass concentration [ug m-3] + REAL cdnc(klon, klev) ! cloud droplet number concentration [m-3] + REAL re(klon, klev) ! cloud droplet effective radius [um] + REAL sulfate_pi(klon, klev) ! sulfate aerosol mass concentration [ug m-3] (pre-industrial value) + 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(sulfate(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(sulfate_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) + 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 +#include "dimensions.h" +#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) + IMPLICIT none +c +#include "dimensions.h" +#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/trunk/libf/phylmd/nuage.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/nuage.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/nuage.h (revision 524) @@ -0,0 +1,6 @@ +! +! $Header$ +! + REAL rad_froid, rad_chau1, rad_chau2 + + common /nuagecom/ rad_froid,rad_chau1, rad_chau2 Index: /LMDZ4/trunk/libf/phylmd/o3cm.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/o3cm.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/o3cm.F (revision 524) @@ -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/trunk/libf/phylmd/oasis.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/oasis.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/oasis.F (revision 524) @@ -0,0 +1,602 @@ +! +! $Header$ +! +C $Id$ +C**** +C +C**** *INICMA* - Initialize coupled mode communication for atmosphere +C and exchange some initial information with Oasis +C +C Input: +C ----- +C KASTP : total number of timesteps in atmospheric model +C KEXCH : frequency of exchange (in time steps) +C KSTEP : length of timestep (in seconds) +C +C ----------------------------------------------------------- +C + SUBROUTINE inicma(kastp,kexch,kstep,imjm) +c +c INCLUDE "param.h" +c + INTEGER kastp, kexch, kstep,imjm + INTEGER iparal(3) + INTEGER ifcpl, idt, info, imxtag, istep, jf +c +#include "param_cou.h" +#include "inc_cpl.h" + CHARACTER*3 cljobnam ! experiment name + CHARACTER*6 clmodnam ! model name +c EM: not used by Oasis2.4 +CEM CHARACTER*6 clbid(2) ! for CLIM_Init call (not used) +CEM ! must be dimensioned by the number of models +CEM INTEGER nbid(2) ! for CLIM_Init call (not used) +CEM ! must be dimensioned by the number of models + CHARACTER*5 cloasis ! coupler name (Oasis) + INTEGER imess(4) + INTEGER getpid ! system functions + INTEGER nuout +CEM LOGICAL llmodel + PARAMETER (nuout = 6) +c +#include "clim.h" +#include "mpiclim.h" +c +#include "oasis.h" ! contains the name of communication technique. Here + ! cchan=CLIM only is possible. +c ! ctype=MPI2 +c +C ----------------------------------------------------------- +C +C* 1. Initializations +C --------------- +C + WRITE(nuout,*) ' ' + WRITE(nuout,*) ' ' + WRITE(nuout,*) ' ROUTINE INICMA' + WRITE(nuout,*) ' **************' + WRITE(nuout,*) ' ' + WRITE(nuout,*) ' ' +c +c Define the model name +c + clmodnam = 'lmdz.x' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp +c +c Define the coupler name +c + cloasis = 'Oasis' ! always 'Oasis' as in the coupler +c +c +c Define symbolic name for fields exchanged from atmos to coupler, +c must be the same as (1) of the field definition in namcouple: +c + cl_writ(1)='COSHFICE' + cl_writ(2)='COSHFOCE' + cl_writ(3)='CONSFICE' + cl_writ(4)='CONSFOCE' + cl_writ(5)='CODFLXDT' +c cl_writ(6)='COICTEMP' + cl_writ(6)='COTFSICE' + cl_writ(7)='COTFSOCE' + cl_writ(8)='COTOLPSU' + cl_writ(9)='COTOSPSU' + cl_writ(10)='CORUNCOA' + cl_writ(11)='CORIVFLU' + cl_writ(12)='COCALVIN' +c$$$ cl_writ(13)='COZOTAUX' +c$$$ cl_writ(14)='COZOTAUV' +c$$$ cl_writ(15)='COMETAUY' +c$$$ cl_writ(16)='COMETAUU' + cl_writ(13)='COTAUXXU' + cl_writ(14)='COTAUYYU' + cl_writ(15)='COTAUZZU' + cl_writ(16)='COTAUXXV' + cl_writ(17)='COTAUYYV' + cl_writ(18)='COTAUZZV' +c +c Define files name for fields exchanged from atmos to coupler, +c must be the same as (6) of the field definition in namcouple: +c + cl_f_writ(1)='flxatmos' + cl_f_writ(2)='flxatmos' + cl_f_writ(3)='flxatmos' + cl_f_writ(4)='flxatmos' + cl_f_writ(5)='flxatmos' + cl_f_writ(6)='flxatmos' + cl_f_writ(7)='flxatmos' + cl_f_writ(8)='flxatmos' + cl_f_writ(9)='flxatmos' + cl_f_writ(10)='flxatmos' + cl_f_writ(11)='flxatmos' + cl_f_writ(12)='flxatmos' + cl_f_writ(13)='flxatmos' + cl_f_writ(14)='flxatmos' + cl_f_writ(15)='flxatmos' + cl_f_writ(16)='flxatmos' + cl_f_writ(17)='flxatmos' + cl_f_writ(18)='flxatmos' + +c +c +c Define symbolic name for fields exchanged from coupler to atmosphere, +c must be the same as (2) of the field definition in namcouple: +c + cl_read(1)='SISUTESW' + cl_read(2)='SIICECOV' + cl_read(3)='SIICEALW' + cl_read(4)='SIICTEMW' +c +c Define files names for fields exchanged from coupler to atmosphere, +c must be the same as (7) of the field definition in namcouple: +c + cl_f_read(1)='sstatmos' + cl_f_read(2)='sstatmos' + cl_f_read(3)='sstatmos' + cl_f_read(4)='sstatmos' +c +c +c Define the number of processors involved in the coupling for +c Oasis (=1) and each model (as last two INTEGER on $CHATYPE line +c in the namcouple); they will be stored in a COMMON in mpiclim.h +c (used for CLIM/MPI2 only) + mpi_nproc(0)=1 + mpi_nproc(1)=1 + mpi_nproc(2)=1 +c +c Define infos to be sent initially to oasis +c + imess(1) = kastp ! total number of timesteps in atmospheric model + imess(2) = kexch ! period of exchange (in time steps) + imess(3) = kstep ! length of atmospheric timestep (in seconds) + imess(4) = getpid() ! PID of atmospheric model +c +c Initialization and exchange of initial info in the CLIM technique +c + IF (cchan.eq.'CLIM') THEN +c +c Define the experiment name : +c + cljobnam = 'CLI' ! as $JOBNAM in namcouple +c +c Start the coupling +c (see lib/clim/src/CLIM_Init for the definition of input parameters) +c +cEM clbid(1)=' ' +cEM clbid(2)=' ' +cEM nbid(1)=0 +cEM nbid(2)=0 +CEM llmodel=.true. +c +c Define the number of processors used by each model as in +c $CHATYPE line of namcouple (used for CLIM/MPI2 only) + mpi_totproc(1)=1 + mpi_totproc(2)=1 +c +c Define names of each model as in $NBMODEL line of namcouple +c (used for CLIM/MPI2 only) + cmpi_modnam(1)='lmdz.x' + cmpi_modnam(2)='opa.xx' +c Start the coupling +c + CALL CLIM_Init ( cljobnam, clmodnam, 3, 7, + * kastp, kexch, kstep, + * 5, 3600, 3600, info ) +c + IF (info.ne.CLIM_Ok) THEN + WRITE ( nuout, *) ' inicma : pb init clim ' + WRITE ( nuout, *) ' error code is = ', info + CALL halte('STOP in inicma') + ELSE + WRITE(nuout,*) 'inicma : init clim ok ' + ENDIF +c +c For each coupling field, association of a port to its symbolic name +c +c -Define the parallel decomposition associated to the port of each +c field; here no decomposition for all ports. + iparal ( clim_strategy ) = clim_serial + iparal ( clim_length ) = imjm + iparal ( clim_offset ) = 0 +c +c -Loop on total number of coupler-to-atmosphere fields +c (see lib/clim/src/CLIM_Define for the definition of input parameters) + DO jf=1, jpfldo2a + CALL CLIM_Define (cl_read(jf), clim_in , clim_double, iparal + $ , info ) + WRITE(nuout,*) 'inicma : clim define done for ',jf + $ ,cl_read(jf) + END DO +c +c -Loop on total number of atmosphere-to-coupler fields +c (see lib/clim/src/CLIM_Define for the definition of input parameters) + DO jf=1, jpflda2o1+jpflda2o2 + CALL CLIM_Define (cl_writ(jf), clim_out , clim_double, + $ iparal, info ) + WRITE(nuout,*) 'inicma : clim define done for ',jf + $ ,cl_writ(jf) + END DO +c + WRITE(nuout,*) 'inicma : clim_define ok ' +c +c -Join a pvm group, wait for other programs and broadcast usefull +c informations to Oasis and to the ocean (see lib/clim/src/CLIM_Start) + CALL CLIM_Start ( imxtag, info ) + IF (info.ne.clim_ok) THEN + WRITE ( nuout, *) 'inicma : pb start clim ' + WRITE ( nuout, *) ' error code is = ', info + CALL halte('stop in inicma') + ELSE + WRITE ( nuout, *) 'inicma : start clim ok ' + ENDIF +c +c -Get initial information from Oasis +c (see lib/clim/src/CLIM_Stepi) + CALL CLIM_Stepi (cloasis, istep, ifcpl, idt, info) + IF (info .NE. clim_ok) THEN + WRITE ( UNIT = nuout, FMT = *) + $ ' warning : problem in getting step info ', + $ 'from oasis ' + WRITE (UNIT = nuout, FMT = *) + $ ' ======= error code number = ', info + ELSE + WRITE (UNIT = nuout, FMT = *) + $ ' got step information from oasis ' + ENDIF + WRITE ( nuout, *) ' number of tstep in oasis ', istep + WRITE ( nuout, *) ' exchange frequency in oasis ', ifcpl + WRITE ( nuout, *) ' length of tstep in oasis ', idt + ENDIF + + RETURN + END + +c $Id$ + SUBROUTINE fromcpl(kt, imjm, sst, gla, tice, albedo) +c ====================================================================== +c S. Valcke (02/99) adapted From L.Z.X Li: this subroutine reads the SST +c and Sea-Ice provided by the coupler with the CLIM (PVM exchange messages) +c technique. +c====================================================================== + IMPLICIT none + INTEGER imjm, kt + REAL sst(imjm) ! sea-surface-temperature + REAL gla(imjm) ! sea-ice + REAL tice(imjm) ! temp glace + REAL albedo(imjm) ! albedo glace +c + INTEGER nuout ! listing output unit + PARAMETER (nuout=6) +c + INTEGER nuread, ios, iflag, icpliter + INTEGER info, jf +c +#include "clim.h" +c +#include "oasis.h" +#include "param_cou.h" +c +#include "inc_cpl.h" +c +c + WRITE (nuout,*) ' ' + WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, kt=',kt + WRITE (nuout,*) ' ' + CALL flush (nuout) + + + IF (cchan.eq.'CLIM') THEN + +c +c -Get interpolated oceanic fields from Oasis +c + DO jf=1,jpfldo2a + IF (jf.eq.1) CALL CLIM_Import (cl_read(jf) , kt, sst, info) + IF (jf.eq.2) CALL CLIM_Import (cl_read(jf) , kt, gla, info) + IF (jf.eq.3) CALL CLIM_Import (cl_read(jf), kt,albedo, info) + IF (jf.eq.4) CALL CLIM_Import (cl_read(jf) , kt, tice, info) + IF ( info .NE. CLIM_Ok) THEN + WRITE(nuout,*)'Pb in reading ', cl_read(jf), jf + WRITE(nuout,*)'Couplage kt is = ',kt + WRITE(nuout,*)'CLIM error code is = ', info + CALL halte('STOP in fromcpl.F') + ENDIF + END DO + + ENDIF +c + RETURN + END + +c $Id$ + SUBROUTINE intocpl(kt, imjm, fsolice, fsolwat, fnsolice, fnsolwat, + $ fnsicedt, evice, evwat, lpre, spre, dirunoff, rivrunoff, + $ calving, tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v + $ , last) +c ====================================================================== +c S. Valcke (02/99) adapted From L.Z.X Li: this subroutine provides the +c atmospheric coupling fields to the coupler with the CLIM (PVM exchange +c messages) technique. +c IF last time step, writes output fields to binary files. +c ====================================================================== + IMPLICIT NONE + INTEGER kt, imjm +c + REAL fsolice(imjm) + REAL fsolwat(imjm) + REAL fnsolwat(imjm) + REAL fnsolice(imjm) + REAL fnsicedt(imjm) + REAL evice(imjm) + REAL evwat(imjm) + REAL lpre(imjm) + REAL spre(imjm) + REAL dirunoff(imjm) + REAL rivrunoff(imjm) + REAL calving(imjm) +c$$$ REAL tauxu(imjm) +c$$$ REAL tauxv(imjm) +c$$$ REAL tauyu(imjm) +c$$$ REAL tauyv(imjm) + REAL tauxx_u(imjm) + REAL tauxx_v(imjm) + REAL tauyy_u(imjm) + REAL tauyy_v(imjm) + REAL tauzz_u(imjm) + REAL tauzz_v(imjm) + LOGICAL last +c + INTEGER nuout + PARAMETER (nuout = 6) +c +#include "clim.h" +#include "param_cou.h" +#include "inc_cpl.h" +c + CHARACTER*8 file_name(jpmaxfld) + INTEGER max_file + INTEGER file_unit_max, file_unit(jpmaxfld), + $ file_unit_field(jpmaxfld) + + INTEGER icstep, info, jn, jf, ierror + LOGICAL trouve +c +#include "oasis.h" +c + icstep=kt +c + WRITE(nuout,*) ' ' + WRITE(nuout,*) 'Intocpl: sending fields to CPL, kt= ', kt + WRITE(nuout,*) 'last ', last + WRITE(nuout,*) + + IF (last) THEN +c +c -WRITE fields to binary files for coupler restart at last time step +c +c -initialisation and files opening +c + max_file=1 + file_unit_max=99 +c -keeps first file name + file_name(max_file)=cl_f_writ(max_file) +c -keeps first file unit + file_unit(max_file)=file_unit_max +c -decrements file unit maximum + file_unit_max=file_unit_max-1 +c -keeps file unit for field + file_unit_field(1)=file_unit(max_file) +c +c -different files names counter +c + DO jf= 2, jpflda2o1 + jpflda2o2 + trouve=.false. + DO jn= 1, max_file + IF (.not.trouve) THEN + IF (cl_f_writ(jf).EQ.file_name(jn)) THEN +c -keep file unit for field + file_unit_field(jf)=file_unit(jn) + trouve=.true. + END IF + END IF + END DO + IF (.not.trouve) then +c -increment the number of different files + max_file=max_file+1 +c -keep file name + file_name(max_file)=cl_f_writ(jf) +c -keep file unit for file + file_unit(max_file)=file_unit_max +c -keep file unit for field + file_unit_field(jf)=file_unit(max_file) +c -decrement unit maximum number from 99 to 98, ... + file_unit_max=file_unit_max-1 + END IF + END DO +c + DO jn=1, max_file + OPEN (file_unit(jn), FILE=file_name(jn), FORM='UNFORMATTED') + WRITE(*,*) 'Opening FILE ', file_unit(jn), ' ' + $ , file_name(jn) + REWIND(file_unit(jn)) + END DO +c +c WRITE fields to files + DO jf=1, jpflda2o1 + jpflda2o2 + IF (jf.eq.1) + $ CALL locwrite(cl_writ(jf),fsolice, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.2) + $ CALL locwrite(cl_writ(jf),fsolwat, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.3) + $ CALL locwrite(cl_writ(jf),fnsolice, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.4) + $ CALL locwrite(cl_writ(jf),fnsolwat, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.5) + $ CALL locwrite(cl_writ(jf),fnsicedt, imjm, + $ file_unit_field(jf), ierror) +c IF (jf.eq.6) +c $ CALL locwrite(cl_writ(jf),ictemp, imjm, +c $ file_unit_field(jf), ierror) + IF (jf.eq.6) + $ CALL locwrite(cl_writ(jf),evice, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.7) + $ CALL locwrite(cl_writ(jf),evwat, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.8) + $ CALL locwrite(cl_writ(jf),lpre, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.9) + $ CALL locwrite(cl_writ(jf),spre, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.10) + $ CALL locwrite(cl_writ(jf),dirunoff, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.11) + $ CALL locwrite(cl_writ(jf),rivrunoff, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.12) + $ CALL locwrite(cl_writ(jf),calving, imjm, + $ file_unit_field(jf), ierror) +c$$$ IF (jf.eq.13) +c$$$ $ CALL locwrite(cl_writ(jf),tauxu, imjm, +c$$$ $ file_unit_field(jf),ierror) +c$$$ IF (jf.eq.1') +c$$$ $ CALL locwrite(cl_writ(jf),tauxv, imjm, +c$$$ $ file_unit_field(jf),ierror) +c$$$ IF (jf.eq.15) +c$$$ $ CALL locwrite(cl_writ(jf),tauyv, imjm, +c$$$ $ file_unit_field(jf),ierror) +c$$$ IF (jf.eq.16) +c$$$ $ CALL locwrite(cl_writ(jf),tauyu, imjm, +c$$$ $ file_unit_field(jf), ierror) + IF (jf.eq.13) + $ CALL locwrite(cl_writ(jf),tauxx_u, imjm, + $ file_unit_field(jf),ierror) + IF (jf.eq.14) + $ CALL locwrite(cl_writ(jf),tauyy_u, imjm, + $ file_unit_field(jf),ierror) + IF (jf.eq.15) + $ CALL locwrite(cl_writ(jf),tauzz_u, imjm, + $ file_unit_field(jf),ierror) + IF (jf.eq.16) + $ CALL locwrite(cl_writ(jf),tauxx_v, imjm, + $ file_unit_field(jf),ierror) + IF (jf.eq.17) + $ CALL locwrite(cl_writ(jf),tauyy_v, imjm, + $ file_unit_field(jf),ierror) + IF (jf.eq.18) + $ CALL locwrite(cl_writ(jf),tauzz_v, imjm, + $ file_unit_field(jf),ierror) + END DO +C +C -simulate a FLUSH +C + DO jn=1, max_file + CLOSE (file_unit(jn)) + END DO +C +C + IF(cchan.eq.'CLIM') THEN +C +C -inform PVM daemon that message exchange is finished +C + CALL CLIM_Quit (CLIM_ContPvm, info) + IF (info .NE. CLIM_Ok) THEN + WRITE (6, *) + $ 'An error occured while leaving CLIM. Error = ', + $ info + ENDIF + END IF + RETURN + END IF +C + IF(cchan.eq.'CLIM') THEN +C +C -Give atmospheric fields to Oasis +C + DO jn=1, jpflda2o1 + jpflda2o2 +C + IF (jn.eq.1) CALL CLIM_Export(cl_writ(jn), kt, fsolice, info) + IF (jn.eq.2) CALL CLIM_Export(cl_writ(jn), kt, fsolwat, info) + IF (jn.eq.3) CALL CLIM_Export(cl_writ(jn), kt, fnsolice, info) + IF (jn.eq.4) CALL CLIM_Export(cl_writ(jn), kt, fnsolwat, info) + IF (jn.eq.5) CALL CLIM_Export(cl_writ(jn), kt, fnsicedt, info) +c IF (jn.eq.6) CALL CLIM_Export(cl_writ(jn), kt, ictemp, info) + IF (jn.eq.6) CALL CLIM_Export(cl_writ(jn), kt, evice, info) + IF (jn.eq.7) CALL CLIM_Export(cl_writ(jn), kt, evwat, info) + IF (jn.eq.8) CALL CLIM_Export(cl_writ(jn), kt, lpre, info) + IF (jn.eq.9) CALL CLIM_Export(cl_writ(jn), kt, spre, info) + IF (jn.eq.10) CALL CLIM_Export(cl_writ(jn),kt,dirunoff, info) + IF (jn.eq.11) CALL CLIM_Export(cl_writ(jn),kt,rivrunoff,info) + IF (jn.eq.12) CALL CLIM_Export(cl_writ(jn),kt,calving,info) +c$$$ IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, tauxu, info) +c$$$ IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, tauxv, info) +c$$$ IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, tauyv, info) +c$$$ IF (jn.eq.16) CALL CLIM_Export(cl_writ(jn), kt, tauyu, info) + IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, tauxx_u, info) + IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, tauyy_u, info) + IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, tauzz_u, info) + IF (jn.eq.16) CALL CLIM_Export(cl_writ(jn), kt, tauxx_v, info) + IF (jn.eq.17) CALL CLIM_Export(cl_writ(jn), kt, tauyy_v, info) + IF (jn.eq.18) CALL CLIM_Export(cl_writ(jn), kt, tauzz_v, info) + + IF (info .NE. CLIM_Ok) THEN + WRITE (nuout,*) 'STEP : Pb giving ',cl_writ(jn), ':',jn + WRITE (nuout,*) ' at timestep = ', icstep,'kt = ',kt + WRITE (nuout,*) 'Clim error code is = ',info + CALL halte('STOP in intocpl ') + ENDIF + END DO + ENDIF +C + RETURN + END + + SUBROUTINE pipe_model_define + print*,'Attention dans oasis.F, pipe_model_define est non defini' + RETURN + END + + SUBROUTINE pipe_model_stepi + print*,'Attention dans oasis.F, pipe_model_stepi est non defini' + RETURN + END + + SUBROUTINE pipe_model_recv + print *, 'Attention dans oasis.F, pipe_model_recv est non defini' + RETURN + END + + SUBROUTINE pipe_model_send + print *, 'Attention dans oasis.F, pipe_model_send est non defini' + RETURN + END + + SUBROUTINE quitcpl + print *, 'Attention dans oasis.F, quitcpl est non defini' + RETURN + END + + SUBROUTINE sipc_write_model + print *, 'Attention dans oasis.F, sipc_write_model est non defini' + RETURN + END + + SUBROUTINE sipc_attach + print *, 'Attention dans oasis.F, sipc_attach est non defini' + RETURN + END + + SUBROUTINE sipc_init_model + print *, 'Attention dans oasis.F, sipc_init_model est non defini' + RETURN + END + + SUBROUTINE sipc_read_model + print *, 'Attention dans oasis.F, sipc_read_model est non defini' + RETURN + END Index: /LMDZ4/trunk/libf/phylmd/oasis.dummy =================================================================== --- /LMDZ4/trunk/libf/phylmd/oasis.dummy (revision 524) +++ /LMDZ4/trunk/libf/phylmd/oasis.dummy (revision 524) @@ -0,0 +1,668 @@ +! +! $Header$ +! +C $Id$ +C**** +C +C**** *INICMA* - Initialize coupled mode communication for atmosphere +C and exchange some initial information with Oasis +C +C Input: +C ----- +C KASTP : total number of timesteps in atmospheric model +C KEXCH : frequency of exchange (in time steps) +C KSTEP : length of timestep (in seconds) +C +C ----------------------------------------------------------- +C + SUBROUTINE inicma(kastp,kexch,kstep,imjm) +c +c INCLUDE "param.h" +c + INTEGER kastp, kexch, kstep,imjm + INTEGER iparal(3) + INTEGER ifcpl, idt, info, imxtag, istep, jf +c +#include "param_cou.h" +#include "inc_cpl.h" + CHARACTER*3 cljobnam ! experiment name + CHARACTER*6 clmodnam ! model name +c EM: not used by Oasis2.4 +CEM CHARACTER*6 clbid(2) ! for CLIM_Init call (not used) +CEM ! must be dimensioned by the number of models +CEM INTEGER nbid(2) ! for CLIM_Init call (not used) +CEM ! must be dimensioned by the number of models + CHARACTER*5 cloasis ! coupler name (Oasis) + INTEGER imess(4) + INTEGER getpid ! system functions + INTEGER nuout +CEM LOGICAL llmodel + PARAMETER (nuout = 6) +c +#include "clim.h" +#include "mpiclim.h" +c +#include "oasis.h" + ! contains the name of communication technique. Here + ! cchan=CLIM only is possible. +c ! ctype=MPI2 +c +C ----------------------------------------------------------- +C +C* 1. Initializations +C --------------- +C + WRITE(nuout,*) ' ' + WRITE(nuout,*) ' ' + WRITE(nuout,*) ' ROUTINE INICMA' + WRITE(nuout,*) ' **************' + WRITE(nuout,*) ' ' + WRITE(nuout,*) ' ' +c +c Define the model name +c + clmodnam = 'lmdz.x' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp +c +c Define the coupler name +c + cloasis = 'Oasis' ! always 'Oasis' as in the coupler +c +c +c Define symbolic name for fields exchanged from atmos to coupler, +c must be the same as (1) of the field definition in namcouple: +c + cl_writ(1)='COSHFICE' + cl_writ(2)='COSHFOCE' + cl_writ(3)='CONSFICE' + cl_writ(4)='CONSFOCE' + cl_writ(5)='CODFLXDT' +c cl_writ(6)='COICTEMP' + cl_writ(6)='COTFSICE' + cl_writ(7)='COTFSOCE' + cl_writ(8)='COTOLPSU' + cl_writ(9)='COTOSPSU' + cl_writ(10)='CORUNCOA' + cl_writ(11)='CORIVFLU' + cl_writ(12)='COCALVIN' +c$$$ cl_writ(13)='COZOTAUX' +c$$$ cl_writ(14)='COZOTAUV' +c$$$ cl_writ(15)='COMETAUY' +c$$$ cl_writ(16)='COMETAUU' + cl_writ(13)='COTAUXXU' + cl_writ(14)='COTAUYYU' + cl_writ(15)='COTAUZZU' + cl_writ(16)='COTAUXXV' + cl_writ(17)='COTAUYYV' + cl_writ(18)='COTAUZZV' +c +c Define files name for fields exchanged from atmos to coupler, +c must be the same as (6) of the field definition in namcouple: +c + cl_f_writ(1)='flxatmos' + cl_f_writ(2)='flxatmos' + cl_f_writ(3)='flxatmos' + cl_f_writ(4)='flxatmos' + cl_f_writ(5)='flxatmos' + cl_f_writ(6)='flxatmos' + cl_f_writ(7)='flxatmos' + cl_f_writ(8)='flxatmos' + cl_f_writ(9)='flxatmos' + cl_f_writ(10)='flxatmos' + cl_f_writ(11)='flxatmos' + cl_f_writ(12)='flxatmos' + cl_f_writ(13)='flxatmos' + cl_f_writ(14)='flxatmos' + cl_f_writ(15)='flxatmos' + cl_f_writ(16)='flxatmos' + cl_f_writ(17)='flxatmos' + cl_f_writ(18)='flxatmos' + +c +c +c Define symbolic name for fields exchanged from coupler to atmosphere, +c must be the same as (2) of the field definition in namcouple: +c + cl_read(1)='SISUTESW' + cl_read(2)='SIICECOV' + cl_read(3)='SIICEALW' + cl_read(4)='SIICTEMW' +c +c Define files names for fields exchanged from coupler to atmosphere, +c must be the same as (7) of the field definition in namcouple: +c + cl_f_read(1)='sstatmos' + cl_f_read(2)='sstatmos' + cl_f_read(3)='sstatmos' + cl_f_read(4)='sstatmos' +c +c +c Define the number of processors involved in the coupling for +c Oasis (=1) and each model (as last two INTEGER on $CHATYPE line +c in the namcouple); they will be stored in a COMMON in mpiclim.h +c (used for CLIM/MPI2 only) + mpi_nproc(0)=1 + mpi_nproc(1)=1 + mpi_nproc(2)=1 +c +c Define infos to be sent initially to oasis +c + imess(1) = kastp ! total number of timesteps in atmospheric model + imess(2) = kexch ! period of exchange (in time steps) + imess(3) = kstep ! length of atmospheric timestep (in seconds) + imess(4) = getpid() ! PID of atmospheric model +c +c Initialization and exchange of initial info in the CLIM technique +c + IF (cchan.eq.'CLIM') THEN +c +c Define the experiment name : +c + cljobnam = 'CLI' ! as $JOBNAM in namcouple +c +c Start the coupling +c (see lib/clim/src/CLIM_Init for the definition of input parameters) +c +cEM clbid(1)=' ' +cEM clbid(2)=' ' +cEM nbid(1)=0 +cEM nbid(2)=0 +CEM llmodel=.true. +c +c Define the number of processors used by each model as in +c $CHATYPE line of namcouple (used for CLIM/MPI2 only) + mpi_totproc(1)=1 + mpi_totproc(2)=1 +c +c Define names of each model as in $NBMODEL line of namcouple +c (used for CLIM/MPI2 only) + cmpi_modnam(1)='lmdz.x' + cmpi_modnam(2)='opa.xx' +c Start the coupling +c + CALL CLIM_Init ( cljobnam, clmodnam, 3, 7, + * kastp, kexch, kstep, + * 5, 3600, 3600, info ) +c + IF (info.ne.CLIM_Ok) THEN + WRITE ( nuout, *) ' inicma : pb init clim ' + WRITE ( nuout, *) ' error code is = ', info + CALL halte('STOP in inicma') + ELSE + WRITE(nuout,*) 'inicma : init clim ok ' + ENDIF +c +c For each coupling field, association of a port to its symbolic name +c +c -Define the parallel decomposition associated to the port of each +c field; here no decomposition for all ports. + iparal ( clim_strategy ) = clim_serial + iparal ( clim_length ) = imjm + iparal ( clim_offset ) = 0 +c +c -Loop on total number of coupler-to-atmosphere fields +c (see lib/clim/src/CLIM_Define for the definition of input parameters) + DO jf=1, jpfldo2a + CALL CLIM_Define (cl_read(jf), clim_in , clim_double, iparal + $ , info ) + WRITE(nuout,*) 'inicma : clim define done for ',jf + $ ,cl_read(jf) + END DO +c +c -Loop on total number of atmosphere-to-coupler fields +c (see lib/clim/src/CLIM_Define for the definition of input parameters) + DO jf=1, jpflda2o1+jpflda2o2 + CALL CLIM_Define (cl_writ(jf), clim_out , clim_double, + $ iparal, info ) + WRITE(nuout,*) 'inicma : clim define done for ',jf + $ ,cl_writ(jf) + END DO +c + WRITE(nuout,*) 'inicma : clim_define ok ' +c +c -Join a pvm group, wait for other programs and broadcast usefull +c informations to Oasis and to the ocean (see lib/clim/src/CLIM_Start) + CALL CLIM_Start ( imxtag, info ) + IF (info.ne.clim_ok) THEN + WRITE ( nuout, *) 'inicma : pb start clim ' + WRITE ( nuout, *) ' error code is = ', info + CALL halte('stop in inicma') + ELSE + WRITE ( nuout, *) 'inicma : start clim ok ' + ENDIF +c +c -Get initial information from Oasis +c (see lib/clim/src/CLIM_Stepi) + CALL CLIM_Stepi (cloasis, istep, ifcpl, idt, info) + IF (info .NE. clim_ok) THEN + WRITE ( UNIT = nuout, FMT = *) + $ ' warning : problem in getting step info ', + $ 'from oasis ' + WRITE (UNIT = nuout, FMT = *) + $ ' ======= error code number = ', info + ELSE + WRITE (UNIT = nuout, FMT = *) + $ ' got step information from oasis ' + ENDIF + WRITE ( nuout, *) ' number of tstep in oasis ', istep + WRITE ( nuout, *) ' exchange frequency in oasis ', ifcpl + WRITE ( nuout, *) ' length of tstep in oasis ', idt + ENDIF + + RETURN + END + +c $Id$ + SUBROUTINE fromcpl(kt, imjm, sst, gla, tice, albedo) +c ====================================================================== +c S. Valcke (02/99) adapted From L.Z.X Li: this subroutine reads the SST +c and Sea-Ice provided by the coupler with the CLIM (PVM exchange messages) +c technique. +c====================================================================== + IMPLICIT none + INTEGER imjm, kt + REAL sst(imjm) ! sea-surface-temperature + REAL gla(imjm) ! sea-ice + REAL tice(imjm) ! temp glace + REAL albedo(imjm) ! albedo glace +c + INTEGER nuout ! listing output unit + PARAMETER (nuout=6) +c + INTEGER nuread, ios, iflag, icpliter + INTEGER info, jf +c +#include "clim.h" +c +#include "oasis.h" +#include "param_cou.h" +c +#include "inc_cpl.h" +c +c + WRITE (nuout,*) ' ' + WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, kt=',kt + WRITE (nuout,*) ' ' + CALL flush (nuout) + + + IF (cchan.eq.'CLIM') THEN + +c +c -Get interpolated oceanic fields from Oasis +c + DO jf=1,jpfldo2a + IF (jf.eq.1) CALL CLIM_Import (cl_read(jf) , kt, sst, info) + IF (jf.eq.2) CALL CLIM_Import (cl_read(jf) , kt, gla, info) + IF (jf.eq.3) CALL CLIM_Import (cl_read(jf), kt,albedo, info) + IF (jf.eq.4) CALL CLIM_Import (cl_read(jf) , kt, tice, info) + IF ( info .NE. CLIM_Ok) THEN + WRITE(nuout,*)'Pb in reading ', cl_read(jf), jf + WRITE(nuout,*)'Couplage kt is = ',kt + WRITE(nuout,*)'CLIM error code is = ', info + CALL halte('STOP in fromcpl.F') + ENDIF + END DO + + ENDIF +c + RETURN + END + +c $Id$ + SUBROUTINE intocpl(kt, imjm, fsolice, fsolwat, fnsolice, fnsolwat, + $ fnsicedt, evice, evwat, lpre, spre, dirunoff, rivrunoff, + $ calving, tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v + $ , last) +c ====================================================================== +c S. Valcke (02/99) adapted From L.Z.X Li: this subroutine provides the +c atmospheric coupling fields to the coupler with the CLIM (PVM exchange +c messages) technique. +c IF last time step, writes output fields to binary files. +c ====================================================================== + IMPLICIT NONE + INTEGER kt, imjm +c + REAL fsolice(imjm) + REAL fsolwat(imjm) + REAL fnsolwat(imjm) + REAL fnsolice(imjm) + REAL fnsicedt(imjm) + REAL evice(imjm) + REAL evwat(imjm) + REAL lpre(imjm) + REAL spre(imjm) + REAL dirunoff(imjm) + REAL rivrunoff(imjm) + REAL calving(imjm) +c$$$ REAL tauxu(imjm) +c$$$ REAL tauxv(imjm) +c$$$ REAL tauyu(imjm) +c$$$ REAL tauyv(imjm) + REAL tauxx_u(imjm) + REAL tauxx_v(imjm) + REAL tauyy_u(imjm) + REAL tauyy_v(imjm) + REAL tauzz_u(imjm) + REAL tauzz_v(imjm) + LOGICAL last +c + INTEGER nuout + PARAMETER (nuout = 6) +c +#include "clim.h" +#include "param_cou.h" +#include "inc_cpl.h" +c + CHARACTER*8 file_name(jpmaxfld) + INTEGER max_file + INTEGER file_unit_max, file_unit(jpmaxfld), + $ file_unit_field(jpmaxfld) + + INTEGER icstep, info, jn, jf, ierror + LOGICAL trouve +c +#include "oasis.h" +c + icstep=kt +c + WRITE(nuout,*) ' ' + WRITE(nuout,*) 'Intocpl: sending fields to CPL, kt= ', kt + WRITE(nuout,*) 'last ', last + WRITE(nuout,*) + + IF (last) THEN +c +c -WRITE fields to binary files for coupler restart at last time step +c +c -initialisation and files opening +c + max_file=1 + file_unit_max=99 +c -keeps first file name + file_name(max_file)=cl_f_writ(max_file) +c -keeps first file unit + file_unit(max_file)=file_unit_max +c -decrements file unit maximum + file_unit_max=file_unit_max-1 +c -keeps file unit for field + file_unit_field(1)=file_unit(max_file) +c +c -different files names counter +c + DO jf= 2, jpflda2o1 + jpflda2o2 + trouve=.false. + DO jn= 1, max_file + IF (.not.trouve) THEN + IF (cl_f_writ(jf).EQ.file_name(jn)) THEN +c -keep file unit for field + file_unit_field(jf)=file_unit(jn) + trouve=.true. + END IF + END IF + END DO + IF (.not.trouve) then +c -increment the number of different files + max_file=max_file+1 +c -keep file name + file_name(max_file)=cl_f_writ(jf) +c -keep file unit for file + file_unit(max_file)=file_unit_max +c -keep file unit for field + file_unit_field(jf)=file_unit(max_file) +c -decrement unit maximum number from 99 to 98, ... + file_unit_max=file_unit_max-1 + END IF + END DO +c + DO jn=1, max_file + OPEN (file_unit(jn), FILE=file_name(jn), FORM='UNFORMATTED') + WRITE(*,*) 'Opening FILE ', file_unit(jn), ' ' + $ , file_name(jn) + REWIND(file_unit(jn)) + END DO +c +c WRITE fields to files + DO jf=1, jpflda2o1 + jpflda2o2 + IF (jf.eq.1) + $ CALL locwrite(cl_writ(jf),fsolice, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.2) + $ CALL locwrite(cl_writ(jf),fsolwat, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.3) + $ CALL locwrite(cl_writ(jf),fnsolice, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.4) + $ CALL locwrite(cl_writ(jf),fnsolwat, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.5) + $ CALL locwrite(cl_writ(jf),fnsicedt, imjm, + $ file_unit_field(jf), ierror) +c IF (jf.eq.6) +c $ CALL locwrite(cl_writ(jf),ictemp, imjm, +c $ file_unit_field(jf), ierror) + IF (jf.eq.6) + $ CALL locwrite(cl_writ(jf),evice, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.7) + $ CALL locwrite(cl_writ(jf),evwat, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.8) + $ CALL locwrite(cl_writ(jf),lpre, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.9) + $ CALL locwrite(cl_writ(jf),spre, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.10) + $ CALL locwrite(cl_writ(jf),dirunoff, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.11) + $ CALL locwrite(cl_writ(jf),rivrunoff, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.12) + $ CALL locwrite(cl_writ(jf),calving, imjm, + $ file_unit_field(jf), ierror) +c$$$ IF (jf.eq.13) +c$$$ $ CALL locwrite(cl_writ(jf),tauxu, imjm, +c$$$ $ file_unit_field(jf),ierror) +c$$$ IF (jf.eq.1') +c$$$ $ CALL locwrite(cl_writ(jf),tauxv, imjm, +c$$$ $ file_unit_field(jf),ierror) +c$$$ IF (jf.eq.15) +c$$$ $ CALL locwrite(cl_writ(jf),tauyv, imjm, +c$$$ $ file_unit_field(jf),ierror) +c$$$ IF (jf.eq.16) +c$$$ $ CALL locwrite(cl_writ(jf),tauyu, imjm, +c$$$ $ file_unit_field(jf), ierror) + IF (jf.eq.13) + $ CALL locwrite(cl_writ(jf),tauxx_u, imjm, + $ file_unit_field(jf),ierror) + IF (jf.eq.14) + $ CALL locwrite(cl_writ(jf),tauyy_u, imjm, + $ file_unit_field(jf),ierror) + IF (jf.eq.15) + $ CALL locwrite(cl_writ(jf),tauzz_u, imjm, + $ file_unit_field(jf),ierror) + IF (jf.eq.16) + $ CALL locwrite(cl_writ(jf),tauxx_v, imjm, + $ file_unit_field(jf),ierror) + IF (jf.eq.17) + $ CALL locwrite(cl_writ(jf),tauyy_v, imjm, + $ file_unit_field(jf),ierror) + IF (jf.eq.18) + $ CALL locwrite(cl_writ(jf),tauzz_v, imjm, + $ file_unit_field(jf),ierror) + END DO +C +C -simulate a FLUSH +C + DO jn=1, max_file + CLOSE (file_unit(jn)) + END DO +C +C + IF(cchan.eq.'CLIM') THEN +C +C -inform PVM daemon that message exchange is finished +C + CALL CLIM_Quit (CLIM_ContPvm, info) + IF (info .NE. CLIM_Ok) THEN + WRITE (6, *) + $ 'An error occured while leaving CLIM. Error = ', + $ info + ENDIF + END IF + RETURN + END IF +C + IF(cchan.eq.'CLIM') THEN +C +C -Give atmospheric fields to Oasis +C + DO jn=1, jpflda2o1 + jpflda2o2 +C + IF (jn.eq.1) CALL CLIM_Export(cl_writ(jn), kt, fsolice, info) + IF (jn.eq.2) CALL CLIM_Export(cl_writ(jn), kt, fsolwat, info) + IF (jn.eq.3) CALL CLIM_Export(cl_writ(jn), kt, fnsolice, info) + IF (jn.eq.4) CALL CLIM_Export(cl_writ(jn), kt, fnsolwat, info) + IF (jn.eq.5) CALL CLIM_Export(cl_writ(jn), kt, fnsicedt, info) +c IF (jn.eq.6) CALL CLIM_Export(cl_writ(jn), kt, ictemp, info) + IF (jn.eq.6) CALL CLIM_Export(cl_writ(jn), kt, evice, info) + IF (jn.eq.7) CALL CLIM_Export(cl_writ(jn), kt, evwat, info) + IF (jn.eq.8) CALL CLIM_Export(cl_writ(jn), kt, lpre, info) + IF (jn.eq.9) CALL CLIM_Export(cl_writ(jn), kt, spre, info) + IF (jn.eq.10) CALL CLIM_Export(cl_writ(jn),kt,dirunoff, info) + IF (jn.eq.11) CALL CLIM_Export(cl_writ(jn),kt,rivrunoff,info) + IF (jn.eq.12) CALL CLIM_Export(cl_writ(jn),kt,calving,info) +c$$$ IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, tauxu, info) +c$$$ IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, tauxv, info) +c$$$ IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, tauyv, info) +c$$$ IF (jn.eq.16) CALL CLIM_Export(cl_writ(jn), kt, tauyu, info) + IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, tauxx_u, info) + IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, tauyy_u, info) + IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, tauzz_u, info) + IF (jn.eq.16) CALL CLIM_Export(cl_writ(jn), kt, tauxx_v, info) + IF (jn.eq.17) CALL CLIM_Export(cl_writ(jn), kt, tauyy_v, info) + IF (jn.eq.18) CALL CLIM_Export(cl_writ(jn), kt, tauzz_v, info) + + IF (info .NE. CLIM_Ok) THEN + WRITE (nuout,*) 'STEP : Pb giving ',cl_writ(jn), ':',jn + WRITE (nuout,*) ' at timestep = ', icstep,'kt = ',kt + WRITE (nuout,*) 'Clim error code is = ',info + CALL halte('STOP in intocpl ') + ENDIF + END DO + ENDIF +C + RETURN + END + + SUBROUTINE halte + print *, 'Attention dans oasis.F, halte est non defini' + RETURN + END + + SUBROUTINE locread + print *, 'Attention dans oasis.F, locread est non defini' + RETURN + END + + SUBROUTINE locwrite + print *, 'Attention dans oasis.F, locwrite est non defini' + RETURN + END + + SUBROUTINE pipe_model_define + print*,'Attention dans oasis.F, pipe_model_define est non defini' + RETURN + END + + SUBROUTINE pipe_model_stepi + print*,'Attention dans oasis.F, pipe_model_stepi est non defini' + RETURN + END + + SUBROUTINE pipe_model_recv + print *, 'Attention dans oasis.F, pipe_model_recv est non defini' + RETURN + END + + SUBROUTINE pipe_model_send + print *, 'Attention dans oasis.F, pipe_model_send est non defini' + RETURN + END + + SUBROUTINE clim_stepi + print *, 'Attention dans oasis.F, clim_stepi est non defini' + RETURN + END + + SUBROUTINE clim_start + print *, 'Attention dans oasis.F, clim_start est non defini' + RETURN + END + + SUBROUTINE clim_import + print *, 'Attention dans oasis.F, clim_import est non defini' + RETURN + END + + SUBROUTINE clim_export + print *, 'Attention dans oasis.F, clim_export est non defini' + RETURN + END + + SUBROUTINE clim_init + print *, 'Attention dans oasis.F, clim_init est non defini' + RETURN + END + + SUBROUTINE clim_define + print *, 'Attention dans oasis.F, clim_define est non defini' + RETURN + END + + SUBROUTINE clim_quit + print *, 'Attention dans oasis.F, clim_quit est non defini' + RETURN + END + + SUBROUTINE svipc_write + print *, 'Attention dans oasis.F, svipc_write est non defini' + RETURN + END + + SUBROUTINE svipc_close + print *, 'Attention dans oasis.F, svipc_close est non defini' + RETURN + END + + SUBROUTINE svipc_read + print *, 'Attention dans oasis.F, svipc_read est non defini' + RETURN + END + + SUBROUTINE quitcpl + print *, 'Attention dans oasis.F, quitcpl est non defini' + RETURN + END + + SUBROUTINE sipc_write_model + print *, 'Attention dans oasis.F, sipc_write_model est non defini' + RETURN + END + + SUBROUTINE sipc_attach + print *, 'Attention dans oasis.F, sipc_attach est non defini' + RETURN + END + + SUBROUTINE sipc_init_model + print *, 'Attention dans oasis.F, sipc_init_model est non defini' + RETURN + END + + SUBROUTINE sipc_read_model + print *, 'Attention dans oasis.F, sipc_read_model est non defini' + RETURN + END Index: /LMDZ4/trunk/libf/phylmd/oasis.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/oasis.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/oasis.h (revision 524) @@ -0,0 +1,17 @@ +! +! $Header$ +! +C +C -- oasis.h +C ****** +C@ +C@ Contents : choice for the OASIS version: clim or pipe +C@ -------- + + logical ok_oasis + parameter(ok_oasis = .false.) + + CHARACTER*8 cchan + PARAMETER ( cchan='CLIM' ) +C +C --- end of oasis.h Index: /LMDZ4/trunk/libf/phylmd/oasis.psmile =================================================================== --- /LMDZ4/trunk/libf/phylmd/oasis.psmile (revision 524) +++ /LMDZ4/trunk/libf/phylmd/oasis.psmile (revision 524) @@ -0,0 +1,431 @@ +! +! $Header$ +! + + MODULE oasis + +! Module contenant les routines pour l'initialisation du couplage, la +! lecture et l'ecriture des champs venant/transmis au coupleur +! + + IMPLICIT none + + PRIVATE + PUBLIC :: inicma, fromcpl, intocpl + + INTERFACE inicma + module procedure inicma + END INTERFACE + +#include "param_cou.h" + + integer, dimension(jpfldo2a), save :: in_var_id + integer, dimension(jpflda2o1+jpflda2o2), save :: il_out_var_id + CHARACTER (len=8), dimension(jpmaxfld), save :: cl_writ, cl_read + CHARACTER (len=8), dimension(jpmaxfld), save :: cl_f_writ, cl_f_read + +CONTAINS + +!**** +! +!**** *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 +! +! Input: +! ----- +! im, jm: size of grid passed between gcm and coupler +! +! ----------------------------------------------------------- +! + SUBROUTINE inicma(im, jm) + + use mod_prism_proto + use mod_prism_def_partition_proto + + implicit none + +#include "param_cou.h" + +! +! parameters +! + integer :: im, jm +! +! local variables +! +! integers +! + integer :: comp_id + integer :: ierror + integer :: il_part_id + integer, dimension(:), allocatable :: ig_paral + integer, dimension(jpfldo2a) :: in_var_id + integer, dimension(jpflda2o1+jpflda2o2) :: il_out_var_id + integer, dimension(2) :: il_var_nodims + integer, dimension(4) :: il_var_actual_shape + integer :: il_var_type + integer :: nuout = 6 + integer :: jf +! characters +! + character (len = 6) :: clmodnam + character (len = 20),save :: modname = 'inicma' + character (len = 80) :: abort_message + +! +! ----------------------------------------------------------- +! +!* 1. Initializations +! --------------- +! + WRITE(nuout,*) ' ' + WRITE(nuout,*) ' ' + WRITE(nuout,*) ' ROUTINE INICMA' + WRITE(nuout,*) ' **************' + WRITE(nuout,*) ' ' + WRITE(nuout,*) ' ' +! +! Define the model name +! + clmodnam = 'lmdz.x' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp +! +! +! Here we go: psmile initialisation +! + 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(nuout,*) 'inicma : init psmile ok ' + ENDIF + +! +! and domain decomposition +! +! monoproc case +! + allocate(ig_paral(3)) + ig_paral(1) = 0 + ig_paral(2) = 0 + ig_paral(3) = im * jm + + call prism_def_partition_proto (il_part_id, ig_paral, ierror) + deallocate(ig_paral) +! + IF (ierror .ne. PRISM_Ok) THEN + abort_message=' Probleme dans prism_def_partition ' + call abort_gcm(modname,abort_message,1) + ELSE + WRITE(nuout,*) 'inicma : decomposition domaine psmile ok ' + ENDIF + +! +! Field Declarations +! +! Define symbolic name for fields exchanged from atmos to coupler, +! must be the same as (1) of the field definition in namcouple: +! + cl_writ(1)='COSHFICE' + cl_writ(2)='COSHFOCE' + cl_writ(3)='CONSFICE' + cl_writ(4)='CONSFOCE' + cl_writ(5)='CODFLXDT' + cl_writ(6)='COTFSICE' + cl_writ(7)='COTFSOCE' + cl_writ(8)='COTOLPSU' + cl_writ(9)='COTOSPSU' + cl_writ(10)='CORUNCOA' + cl_writ(11)='CORIVFLU' + cl_writ(12)='COCALVIN' + cl_writ(13)='COTAUXXU' + cl_writ(14)='COTAUYYU' + cl_writ(15)='COTAUZZU' + cl_writ(16)='COTAUXXV' + cl_writ(17)='COTAUYYV' + cl_writ(18)='COTAUZZV' +! +! Define symbolic name for fields exchanged from coupler to atmosphere, +! must be the same as (2) of the field definition in namcouple: +! + cl_read(1)='SISUTESW' + cl_read(2)='SIICECOV' + cl_read(3)='SIICEALW' + cl_read(4)='SIICTEMW' + + il_var_nodims(1) = 2 + il_var_nodims(2) = 1 + + il_var_actual_shape(1) = 1 + il_var_actual_shape(2) = im + il_var_actual_shape(3) = 1 + il_var_actual_shape(4) = jm + + il_var_type = PRISM_Real +! +! Oceanic Fields +! + DO jf=1, jpfldo2a + call prism_def_var_proto(in_var_id(jf), cl_read(jf), il_part_id, & +& il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, & +& ierror) + IF (ierror .ne. PRISM_Ok) THEN + abort_message=' Probleme init dans prism_def_var_proto ' + call abort_gcm(modname,abort_message,1) + ENDIF + END DO +! +! Atmospheric Fields +! + DO jf=1, jpflda2o1+jpflda2o2 + call prism_def_var_proto(il_out_var_id(jf), cl_writ(jf), il_part_id, & +& il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, & +& ierror) + IF (ierror .ne. PRISM_Ok) THEN + abort_message=' Probleme init dans prism_def_var_proto ' + call abort_gcm(modname,abort_message,1) + ENDIF + END DO +! +! End +! + call prism_enddef_proto(ierror) + IF (ierror .ne. PRISM_Ok) THEN + abort_message=' Probleme init dans prism_ endef_proto' + call abort_gcm(modname,abort_message,1) + ELSE + WRITE(nuout,*) 'inicma : endef psmile ok ' + ENDIF + + END SUBROUTINE inicma + + SUBROUTINE fromcpl(kt, im, jm, sst, gla, tice, albedo) +! ====================================================================== +! 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 +!====================================================================== + + use mod_prism_proto + use mod_prism_get_proto + + IMPLICIT none + +! +! parametres +! + integer :: im, jm, kt + real, dimension(im, jm) :: sst ! sea-surface-temperature + real, dimension(im, jm) :: gla ! sea-ice + real, dimension(im, jm) :: tice ! temp glace + real, dimension(im, jm) :: albedo ! albedo glace +! +! local variables +! + integer :: nuout = 6 ! listing output unit + integer :: ierror + character (len = 20),save :: modname = 'fromcpl' + character (len = 80) :: abort_message +! +#include "param_cou.h" +! +! + WRITE (nuout,*) ' ' + WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, kt=',kt + WRITE (nuout,*) ' ' + CALL flush (nuout) + + call prism_get_proto(in_var_id(1), kt, sst, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_read(1), kt + abort_message=' Probleme dans prism_get_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_get_proto(in_var_id(2), kt, gla, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_read(2), kt + abort_message=' Probleme dans prism_get_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_get_proto(in_var_id(3), kt, albedo, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_read(3), kt + abort_message=' Probleme dans prism_get_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_get_proto(in_var_id(4), kt, tice, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_read(4), kt + abort_message=' Probleme dans prism_get_proto ' + call abort_gcm(modname,abort_message,1) + endif + +! + RETURN + END SUBROUTINE fromcpl + + SUBROUTINE intocpl(kt, im, jm, fsolice, fsolwat, fnsolice, fnsolwat, & + & fnsicedt, evice, evwat, lpre, spre, dirunoff, rivrunoff, & + & calving, tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v & + & , last) +! ====================================================================== +! 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. +! ====================================================================== + + use mod_prism_proto + use mod_prism_put_proto + + IMPLICIT NONE + +! +! parametres +! + integer :: kt, im, jm + real, dimension(im, jm) :: fsolice, fsolwat, fnsolwat, fnsolice + real, dimension(im, jm) :: fnsicedt, evice, evwat, lpre, spre + real, dimension(im, jm) :: dirunoff, rivrunoff, calving + real, dimension(im, jm) :: tauxx_u, tauxx_v, tauyy_u + real, dimension(im, jm) :: tauyy_v, tauzz_u, tauzz_v + logical :: last +! +! local +! + integer, parameter :: nuout = 6 + integer :: ierror + character (len = 20),save :: modname = 'intocpl' + character (len = 80) :: abort_message +! +! + WRITE(nuout,*) ' ' + WRITE(nuout,*) 'Intocpl: sending fields to CPL, kt= ', kt + WRITE(nuout,*) 'last ', last + WRITE(nuout,*) + + call prism_put_proto(il_out_var_id(1), kt, fsolice, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(1), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(2), kt, fsolwat, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(2), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(3), kt, fnsolice, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(3), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(4), kt, fnsolwat, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(4), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(5), kt, fnsicedt, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(5), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(6), kt, evice, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(6), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(7), kt, evwat, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(7), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(8), kt, lpre, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(8), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(9), kt, spre, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(9), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(10), kt, dirunoff, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(10), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(11), kt, rivrunoff, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(11), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(12), kt, calving, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(12), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(13), kt, tauxx_u, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(13), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(14), kt, tauyy_u, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(14), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(15), kt, tauzz_u, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(15), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(16), kt, tauxx_v, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(16), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(17), kt, tauyy_v, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(17), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(18), kt, tauzz_v, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(18), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + + if (last) then + call prism_terminate_proto(ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(18), kt + abort_message=' Probleme dans prism_terminate_proto ' + call abort_gcm(modname,abort_message,1) + endif + endif + + + RETURN + END SUBROUTINE intocpl + + END MODULE oasis Index: /LMDZ4/trunk/libf/phylmd/oasis.true =================================================================== --- /LMDZ4/trunk/libf/phylmd/oasis.true (revision 524) +++ /LMDZ4/trunk/libf/phylmd/oasis.true (revision 524) @@ -0,0 +1,602 @@ +! +! $Header$ +! +C $Id$ +C**** +C +C**** *INICMA* - Initialize coupled mode communication for atmosphere +C and exchange some initial information with Oasis +C +C Input: +C ----- +C KASTP : total number of timesteps in atmospheric model +C KEXCH : frequency of exchange (in time steps) +C KSTEP : length of timestep (in seconds) +C +C ----------------------------------------------------------- +C + SUBROUTINE inicma(kastp,kexch,kstep,imjm) +c +c INCLUDE "param.h" +c + INTEGER kastp, kexch, kstep,imjm + INTEGER iparal(3) + INTEGER ifcpl, idt, info, imxtag, istep, jf +c +#include "param_cou.h" +#include "inc_cpl.h" + CHARACTER*3 cljobnam ! experiment name + CHARACTER*6 clmodnam ! model name +c EM: not used by Oasis2.4 +CEM CHARACTER*6 clbid(2) ! for CLIM_Init call (not used) +CEM ! must be dimensioned by the number of models +CEM INTEGER nbid(2) ! for CLIM_Init call (not used) +CEM ! must be dimensioned by the number of models + CHARACTER*5 cloasis ! coupler name (Oasis) + INTEGER imess(4) + INTEGER getpid ! system functions + INTEGER nuout +CEM LOGICAL llmodel + PARAMETER (nuout = 6) +c +#include "clim.h" +#include "mpiclim.h" +c +#include "oasis.h" ! contains the name of communication technique. Here + ! cchan=CLIM only is possible. +c ! ctype=MPI2 +c +C ----------------------------------------------------------- +C +C* 1. Initializations +C --------------- +C + WRITE(nuout,*) ' ' + WRITE(nuout,*) ' ' + WRITE(nuout,*) ' ROUTINE INICMA' + WRITE(nuout,*) ' **************' + WRITE(nuout,*) ' ' + WRITE(nuout,*) ' ' +c +c Define the model name +c + clmodnam = 'lmdz.x' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp +c +c Define the coupler name +c + cloasis = 'Oasis' ! always 'Oasis' as in the coupler +c +c +c Define symbolic name for fields exchanged from atmos to coupler, +c must be the same as (1) of the field definition in namcouple: +c + cl_writ(1)='COSHFICE' + cl_writ(2)='COSHFOCE' + cl_writ(3)='CONSFICE' + cl_writ(4)='CONSFOCE' + cl_writ(5)='CODFLXDT' +c cl_writ(6)='COICTEMP' + cl_writ(6)='COTFSICE' + cl_writ(7)='COTFSOCE' + cl_writ(8)='COTOLPSU' + cl_writ(9)='COTOSPSU' + cl_writ(10)='CORUNCOA' + cl_writ(11)='CORIVFLU' + cl_writ(12)='COCALVIN' +c$$$ cl_writ(13)='COZOTAUX' +c$$$ cl_writ(14)='COZOTAUV' +c$$$ cl_writ(15)='COMETAUY' +c$$$ cl_writ(16)='COMETAUU' + cl_writ(13)='COTAUXXU' + cl_writ(14)='COTAUYYU' + cl_writ(15)='COTAUZZU' + cl_writ(16)='COTAUXXV' + cl_writ(17)='COTAUYYV' + cl_writ(18)='COTAUZZV' +c +c Define files name for fields exchanged from atmos to coupler, +c must be the same as (6) of the field definition in namcouple: +c + cl_f_writ(1)='flxatmos' + cl_f_writ(2)='flxatmos' + cl_f_writ(3)='flxatmos' + cl_f_writ(4)='flxatmos' + cl_f_writ(5)='flxatmos' + cl_f_writ(6)='flxatmos' + cl_f_writ(7)='flxatmos' + cl_f_writ(8)='flxatmos' + cl_f_writ(9)='flxatmos' + cl_f_writ(10)='flxatmos' + cl_f_writ(11)='flxatmos' + cl_f_writ(12)='flxatmos' + cl_f_writ(13)='flxatmos' + cl_f_writ(14)='flxatmos' + cl_f_writ(15)='flxatmos' + cl_f_writ(16)='flxatmos' + cl_f_writ(17)='flxatmos' + cl_f_writ(18)='flxatmos' + +c +c +c Define symbolic name for fields exchanged from coupler to atmosphere, +c must be the same as (2) of the field definition in namcouple: +c + cl_read(1)='SISUTESW' + cl_read(2)='SIICECOV' + cl_read(3)='SIICEALW' + cl_read(4)='SIICTEMW' +c +c Define files names for fields exchanged from coupler to atmosphere, +c must be the same as (7) of the field definition in namcouple: +c + cl_f_read(1)='sstatmos' + cl_f_read(2)='sstatmos' + cl_f_read(3)='sstatmos' + cl_f_read(4)='sstatmos' +c +c +c Define the number of processors involved in the coupling for +c Oasis (=1) and each model (as last two INTEGER on $CHATYPE line +c in the namcouple); they will be stored in a COMMON in mpiclim.h +c (used for CLIM/MPI2 only) + mpi_nproc(0)=1 + mpi_nproc(1)=1 + mpi_nproc(2)=1 +c +c Define infos to be sent initially to oasis +c + imess(1) = kastp ! total number of timesteps in atmospheric model + imess(2) = kexch ! period of exchange (in time steps) + imess(3) = kstep ! length of atmospheric timestep (in seconds) + imess(4) = getpid() ! PID of atmospheric model +c +c Initialization and exchange of initial info in the CLIM technique +c + IF (cchan.eq.'CLIM') THEN +c +c Define the experiment name : +c + cljobnam = 'CLI' ! as $JOBNAM in namcouple +c +c Start the coupling +c (see lib/clim/src/CLIM_Init for the definition of input parameters) +c +cEM clbid(1)=' ' +cEM clbid(2)=' ' +cEM nbid(1)=0 +cEM nbid(2)=0 +CEM llmodel=.true. +c +c Define the number of processors used by each model as in +c $CHATYPE line of namcouple (used for CLIM/MPI2 only) + mpi_totproc(1)=1 + mpi_totproc(2)=1 +c +c Define names of each model as in $NBMODEL line of namcouple +c (used for CLIM/MPI2 only) + cmpi_modnam(1)='lmdz.x' + cmpi_modnam(2)='opa.xx' +c Start the coupling +c + CALL CLIM_Init ( cljobnam, clmodnam, 3, 7, + * kastp, kexch, kstep, + * 5, 3600, 3600, info ) +c + IF (info.ne.CLIM_Ok) THEN + WRITE ( nuout, *) ' inicma : pb init clim ' + WRITE ( nuout, *) ' error code is = ', info + CALL halte('STOP in inicma') + ELSE + WRITE(nuout,*) 'inicma : init clim ok ' + ENDIF +c +c For each coupling field, association of a port to its symbolic name +c +c -Define the parallel decomposition associated to the port of each +c field; here no decomposition for all ports. + iparal ( clim_strategy ) = clim_serial + iparal ( clim_length ) = imjm + iparal ( clim_offset ) = 0 +c +c -Loop on total number of coupler-to-atmosphere fields +c (see lib/clim/src/CLIM_Define for the definition of input parameters) + DO jf=1, jpfldo2a + CALL CLIM_Define (cl_read(jf), clim_in , clim_double, iparal + $ , info ) + WRITE(nuout,*) 'inicma : clim define done for ',jf + $ ,cl_read(jf) + END DO +c +c -Loop on total number of atmosphere-to-coupler fields +c (see lib/clim/src/CLIM_Define for the definition of input parameters) + DO jf=1, jpflda2o1+jpflda2o2 + CALL CLIM_Define (cl_writ(jf), clim_out , clim_double, + $ iparal, info ) + WRITE(nuout,*) 'inicma : clim define done for ',jf + $ ,cl_writ(jf) + END DO +c + WRITE(nuout,*) 'inicma : clim_define ok ' +c +c -Join a pvm group, wait for other programs and broadcast usefull +c informations to Oasis and to the ocean (see lib/clim/src/CLIM_Start) + CALL CLIM_Start ( imxtag, info ) + IF (info.ne.clim_ok) THEN + WRITE ( nuout, *) 'inicma : pb start clim ' + WRITE ( nuout, *) ' error code is = ', info + CALL halte('stop in inicma') + ELSE + WRITE ( nuout, *) 'inicma : start clim ok ' + ENDIF +c +c -Get initial information from Oasis +c (see lib/clim/src/CLIM_Stepi) + CALL CLIM_Stepi (cloasis, istep, ifcpl, idt, info) + IF (info .NE. clim_ok) THEN + WRITE ( UNIT = nuout, FMT = *) + $ ' warning : problem in getting step info ', + $ 'from oasis ' + WRITE (UNIT = nuout, FMT = *) + $ ' ======= error code number = ', info + ELSE + WRITE (UNIT = nuout, FMT = *) + $ ' got step information from oasis ' + ENDIF + WRITE ( nuout, *) ' number of tstep in oasis ', istep + WRITE ( nuout, *) ' exchange frequency in oasis ', ifcpl + WRITE ( nuout, *) ' length of tstep in oasis ', idt + ENDIF + + RETURN + END + +c $Id$ + SUBROUTINE fromcpl(kt, imjm, sst, gla, tice, albedo) +c ====================================================================== +c S. Valcke (02/99) adapted From L.Z.X Li: this subroutine reads the SST +c and Sea-Ice provided by the coupler with the CLIM (PVM exchange messages) +c technique. +c====================================================================== + IMPLICIT none + INTEGER imjm, kt + REAL sst(imjm) ! sea-surface-temperature + REAL gla(imjm) ! sea-ice + REAL tice(imjm) ! temp glace + REAL albedo(imjm) ! albedo glace +c + INTEGER nuout ! listing output unit + PARAMETER (nuout=6) +c + INTEGER nuread, ios, iflag, icpliter + INTEGER info, jf +c +#include "clim.h" +c +#include "oasis.h" +#include "param_cou.h" +c +#include "inc_cpl.h" +c +c + WRITE (nuout,*) ' ' + WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, kt=',kt + WRITE (nuout,*) ' ' + CALL flush (nuout) + + + IF (cchan.eq.'CLIM') THEN + +c +c -Get interpolated oceanic fields from Oasis +c + DO jf=1,jpfldo2a + IF (jf.eq.1) CALL CLIM_Import (cl_read(jf) , kt, sst, info) + IF (jf.eq.2) CALL CLIM_Import (cl_read(jf) , kt, gla, info) + IF (jf.eq.3) CALL CLIM_Import (cl_read(jf), kt,albedo, info) + IF (jf.eq.4) CALL CLIM_Import (cl_read(jf) , kt, tice, info) + IF ( info .NE. CLIM_Ok) THEN + WRITE(nuout,*)'Pb in reading ', cl_read(jf), jf + WRITE(nuout,*)'Couplage kt is = ',kt + WRITE(nuout,*)'CLIM error code is = ', info + CALL halte('STOP in fromcpl.F') + ENDIF + END DO + + ENDIF +c + RETURN + END + +c $Id$ + SUBROUTINE intocpl(kt, imjm, fsolice, fsolwat, fnsolice, fnsolwat, + $ fnsicedt, evice, evwat, lpre, spre, dirunoff, rivrunoff, + $ calving, tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v + $ , last) +c ====================================================================== +c S. Valcke (02/99) adapted From L.Z.X Li: this subroutine provides the +c atmospheric coupling fields to the coupler with the CLIM (PVM exchange +c messages) technique. +c IF last time step, writes output fields to binary files. +c ====================================================================== + IMPLICIT NONE + INTEGER kt, imjm +c + REAL fsolice(imjm) + REAL fsolwat(imjm) + REAL fnsolwat(imjm) + REAL fnsolice(imjm) + REAL fnsicedt(imjm) + REAL evice(imjm) + REAL evwat(imjm) + REAL lpre(imjm) + REAL spre(imjm) + REAL dirunoff(imjm) + REAL rivrunoff(imjm) + REAL calving(imjm) +c$$$ REAL tauxu(imjm) +c$$$ REAL tauxv(imjm) +c$$$ REAL tauyu(imjm) +c$$$ REAL tauyv(imjm) + REAL tauxx_u(imjm) + REAL tauxx_v(imjm) + REAL tauyy_u(imjm) + REAL tauyy_v(imjm) + REAL tauzz_u(imjm) + REAL tauzz_v(imjm) + LOGICAL last +c + INTEGER nuout + PARAMETER (nuout = 6) +c +#include "clim.h" +#include "param_cou.h" +#include "inc_cpl.h" +c + CHARACTER*8 file_name(jpmaxfld) + INTEGER max_file + INTEGER file_unit_max, file_unit(jpmaxfld), + $ file_unit_field(jpmaxfld) + + INTEGER icstep, info, jn, jf, ierror + LOGICAL trouve +c +#include "oasis.h" +c + icstep=kt +c + WRITE(nuout,*) ' ' + WRITE(nuout,*) 'Intocpl: sending fields to CPL, kt= ', kt + WRITE(nuout,*) 'last ', last + WRITE(nuout,*) + + IF (last) THEN +c +c -WRITE fields to binary files for coupler restart at last time step +c +c -initialisation and files opening +c + max_file=1 + file_unit_max=99 +c -keeps first file name + file_name(max_file)=cl_f_writ(max_file) +c -keeps first file unit + file_unit(max_file)=file_unit_max +c -decrements file unit maximum + file_unit_max=file_unit_max-1 +c -keeps file unit for field + file_unit_field(1)=file_unit(max_file) +c +c -different files names counter +c + DO jf= 2, jpflda2o1 + jpflda2o2 + trouve=.false. + DO jn= 1, max_file + IF (.not.trouve) THEN + IF (cl_f_writ(jf).EQ.file_name(jn)) THEN +c -keep file unit for field + file_unit_field(jf)=file_unit(jn) + trouve=.true. + END IF + END IF + END DO + IF (.not.trouve) then +c -increment the number of different files + max_file=max_file+1 +c -keep file name + file_name(max_file)=cl_f_writ(jf) +c -keep file unit for file + file_unit(max_file)=file_unit_max +c -keep file unit for field + file_unit_field(jf)=file_unit(max_file) +c -decrement unit maximum number from 99 to 98, ... + file_unit_max=file_unit_max-1 + END IF + END DO +c + DO jn=1, max_file + OPEN (file_unit(jn), FILE=file_name(jn), FORM='UNFORMATTED') + WRITE(*,*) 'Opening FILE ', file_unit(jn), ' ' + $ , file_name(jn) + REWIND(file_unit(jn)) + END DO +c +c WRITE fields to files + DO jf=1, jpflda2o1 + jpflda2o2 + IF (jf.eq.1) + $ CALL locwrite(cl_writ(jf),fsolice, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.2) + $ CALL locwrite(cl_writ(jf),fsolwat, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.3) + $ CALL locwrite(cl_writ(jf),fnsolice, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.4) + $ CALL locwrite(cl_writ(jf),fnsolwat, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.5) + $ CALL locwrite(cl_writ(jf),fnsicedt, imjm, + $ file_unit_field(jf), ierror) +c IF (jf.eq.6) +c $ CALL locwrite(cl_writ(jf),ictemp, imjm, +c $ file_unit_field(jf), ierror) + IF (jf.eq.6) + $ CALL locwrite(cl_writ(jf),evice, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.7) + $ CALL locwrite(cl_writ(jf),evwat, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.8) + $ CALL locwrite(cl_writ(jf),lpre, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.9) + $ CALL locwrite(cl_writ(jf),spre, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.10) + $ CALL locwrite(cl_writ(jf),dirunoff, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.11) + $ CALL locwrite(cl_writ(jf),rivrunoff, imjm, + $ file_unit_field(jf), ierror) + IF (jf.eq.12) + $ CALL locwrite(cl_writ(jf),calving, imjm, + $ file_unit_field(jf), ierror) +c$$$ IF (jf.eq.13) +c$$$ $ CALL locwrite(cl_writ(jf),tauxu, imjm, +c$$$ $ file_unit_field(jf),ierror) +c$$$ IF (jf.eq.1') +c$$$ $ CALL locwrite(cl_writ(jf),tauxv, imjm, +c$$$ $ file_unit_field(jf),ierror) +c$$$ IF (jf.eq.15) +c$$$ $ CALL locwrite(cl_writ(jf),tauyv, imjm, +c$$$ $ file_unit_field(jf),ierror) +c$$$ IF (jf.eq.16) +c$$$ $ CALL locwrite(cl_writ(jf),tauyu, imjm, +c$$$ $ file_unit_field(jf), ierror) + IF (jf.eq.13) + $ CALL locwrite(cl_writ(jf),tauxx_u, imjm, + $ file_unit_field(jf),ierror) + IF (jf.eq.14) + $ CALL locwrite(cl_writ(jf),tauyy_u, imjm, + $ file_unit_field(jf),ierror) + IF (jf.eq.15) + $ CALL locwrite(cl_writ(jf),tauzz_u, imjm, + $ file_unit_field(jf),ierror) + IF (jf.eq.16) + $ CALL locwrite(cl_writ(jf),tauxx_v, imjm, + $ file_unit_field(jf),ierror) + IF (jf.eq.17) + $ CALL locwrite(cl_writ(jf),tauyy_v, imjm, + $ file_unit_field(jf),ierror) + IF (jf.eq.18) + $ CALL locwrite(cl_writ(jf),tauzz_v, imjm, + $ file_unit_field(jf),ierror) + END DO +C +C -simulate a FLUSH +C + DO jn=1, max_file + CLOSE (file_unit(jn)) + END DO +C +C + IF(cchan.eq.'CLIM') THEN +C +C -inform PVM daemon that message exchange is finished +C + CALL CLIM_Quit (CLIM_ContPvm, info) + IF (info .NE. CLIM_Ok) THEN + WRITE (6, *) + $ 'An error occured while leaving CLIM. Error = ', + $ info + ENDIF + END IF + RETURN + END IF +C + IF(cchan.eq.'CLIM') THEN +C +C -Give atmospheric fields to Oasis +C + DO jn=1, jpflda2o1 + jpflda2o2 +C + IF (jn.eq.1) CALL CLIM_Export(cl_writ(jn), kt, fsolice, info) + IF (jn.eq.2) CALL CLIM_Export(cl_writ(jn), kt, fsolwat, info) + IF (jn.eq.3) CALL CLIM_Export(cl_writ(jn), kt, fnsolice, info) + IF (jn.eq.4) CALL CLIM_Export(cl_writ(jn), kt, fnsolwat, info) + IF (jn.eq.5) CALL CLIM_Export(cl_writ(jn), kt, fnsicedt, info) +c IF (jn.eq.6) CALL CLIM_Export(cl_writ(jn), kt, ictemp, info) + IF (jn.eq.6) CALL CLIM_Export(cl_writ(jn), kt, evice, info) + IF (jn.eq.7) CALL CLIM_Export(cl_writ(jn), kt, evwat, info) + IF (jn.eq.8) CALL CLIM_Export(cl_writ(jn), kt, lpre, info) + IF (jn.eq.9) CALL CLIM_Export(cl_writ(jn), kt, spre, info) + IF (jn.eq.10) CALL CLIM_Export(cl_writ(jn),kt,dirunoff, info) + IF (jn.eq.11) CALL CLIM_Export(cl_writ(jn),kt,rivrunoff,info) + IF (jn.eq.12) CALL CLIM_Export(cl_writ(jn),kt,calving,info) +c$$$ IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, tauxu, info) +c$$$ IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, tauxv, info) +c$$$ IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, tauyv, info) +c$$$ IF (jn.eq.16) CALL CLIM_Export(cl_writ(jn), kt, tauyu, info) + IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, tauxx_u, info) + IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, tauyy_u, info) + IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, tauzz_u, info) + IF (jn.eq.16) CALL CLIM_Export(cl_writ(jn), kt, tauxx_v, info) + IF (jn.eq.17) CALL CLIM_Export(cl_writ(jn), kt, tauyy_v, info) + IF (jn.eq.18) CALL CLIM_Export(cl_writ(jn), kt, tauzz_v, info) + + IF (info .NE. CLIM_Ok) THEN + WRITE (nuout,*) 'STEP : Pb giving ',cl_writ(jn), ':',jn + WRITE (nuout,*) ' at timestep = ', icstep,'kt = ',kt + WRITE (nuout,*) 'Clim error code is = ',info + CALL halte('STOP in intocpl ') + ENDIF + END DO + ENDIF +C + RETURN + END + + SUBROUTINE pipe_model_define + print*,'Attention dans oasis.F, pipe_model_define est non defini' + RETURN + END + + SUBROUTINE pipe_model_stepi + print*,'Attention dans oasis.F, pipe_model_stepi est non defini' + RETURN + END + + SUBROUTINE pipe_model_recv + print *, 'Attention dans oasis.F, pipe_model_recv est non defini' + RETURN + END + + SUBROUTINE pipe_model_send + print *, 'Attention dans oasis.F, pipe_model_send est non defini' + RETURN + END + + SUBROUTINE quitcpl + print *, 'Attention dans oasis.F, quitcpl est non defini' + RETURN + END + + SUBROUTINE sipc_write_model + print *, 'Attention dans oasis.F, sipc_write_model est non defini' + RETURN + END + + SUBROUTINE sipc_attach + print *, 'Attention dans oasis.F, sipc_attach est non defini' + RETURN + END + + SUBROUTINE sipc_init_model + print *, 'Attention dans oasis.F, sipc_init_model est non defini' + RETURN + END + + SUBROUTINE sipc_read_model + print *, 'Attention dans oasis.F, sipc_read_model est non defini' + RETURN + END Index: /LMDZ4/trunk/libf/phylmd/orbite.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/orbite.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/orbite.F (revision 524) @@ -0,0 +1,322 @@ +! +! $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) + 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====================================================================== +#include "dimensions.h" +#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) + 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----INPUT : la longitude vraie de la terre dans son plan +c solaire a partir de l'equinoxe de printemps (degre) +c gmtime---INPUT : temps universel en fraction de jour +c pdtrad---INPUT : 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================================================================ +#include "dimensions.h" +#include "dimphy.h" +#include "YOMCST.h" +c================================================================ + real 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) + 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==================================================================== +#include "dimensions.h" +#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/trunk/libf/phylmd/orografi.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/orografi.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/orografi.F (revision 524) @@ -0,0 +1,1807 @@ +! +! $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 + 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====================================================================== +#include "dimensions.h" +#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) + . +rg*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k)) + pvstr(i) = pvstr(i) + . +rg*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k)) + 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 ) + + 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 +#include "dimensions.h" +#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" +c----------------------------------------------------------------------- +c +c* 0.1 arguments +c --------- +c +c + integer nlon, nlev, klevm1 + 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 + 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----------------------------------------------------------------------- + implicit none +c + +#include "dimensions.h" +#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).xor.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).xor.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).xor.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----------------------------------------------------------------------- + implicit none +#include "dimensions.h" +#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----------------------------------------------------------------------- + implicit none +C + +C + +#include "dimensions.h" +#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 + 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====================================================================== +#include "dimensions.h" +#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) + . +RG*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k)) + pvstr(i) = pvstr(i) + . +RG*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k)) + 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 + implicit none +C +C +#include "dimensions.h" +#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, ll1 + integer klevm1, 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 + 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).XOR.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) +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 +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 + DO 110 JK=1,NLEV + ZPM1R=pplay(nlon/2,jk)/paprs(nlon/2,1) + IF(ZPM1R.GE.ZSIGT)THEN + nktopg=JK + ENDIF + ZPM1R=pplay(nlon/2,jk)/paprs(nlon/2,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/trunk/libf/phylmd/ozonecm.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/ozonecm.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/ozonecm.F (revision 524) @@ -0,0 +1,70 @@ +! +! $Header$ +! + SUBROUTINE ozonecm(rjour, rlat, paprs, o3) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" + REAL rlat(klon), paprs(klon,klev+1) + REAL o3(klon,klev) + REAL tozon, rjour, pi, pl + INTEGER i, k +C---------------------------------------------------------- + REAL field(klon,klev+1) + REAL ps + PARAMETER (ps=101325.0) + REAL an, unit, zo3q3 + SAVE an, unit, zo3q3 + REAL mu,gms, zslat, zsint, zcost, z, ppm, qpm, a + REAL asec, bsec, aprim, zo3a3 +C---------------------------------------------------------- +c data an /365.25/ (meteo) + DATA an /360.00/ + DATA unit /2.1415e-05/ + DATA zo3q3 /4.0e-08/ + + pi = 4.0 * ATAN(1.0) + 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 + mu = ABS(sin(pi/180.*rlat(i))) + 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 + tozon = tozon / 9.81 ! en kg/m**2 + tozon = tozon / unit ! en kg/m**2 > u dobson (10e-5 m) + tozon = tozon / 1000. ! en cm + field(i,k) = tozon + ENDDO + ENDDO +c + DO i = 1, klon + field(i,klev+1) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + o3(i,k) = field(i,k) - field(i,k+1) + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ4/trunk/libf/phylmd/param_cou.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/param_cou.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/param_cou.h (revision 524) @@ -0,0 +1,21 @@ +! +! $Header$ +! +! $Id$ +! +! -- param_cou.h +! + INTEGER jpmaxfld + PARAMETER(jpmaxfld = 40) ! Maximum number of fields exchanged + ! between ocean and atmosphere + INTEGER jpflda2o1 + PARAMETER(jpflda2o1 = 12) ! Number of fields exchanged from + ! atmosphere to ocean via flx.F + INTEGER jpflda2o2 + PARAMETER(jpflda2o2 = 6) ! Number of fields exchanged from + ! atmosphere to ocean via tau.F +! + INTEGER jpfldo2a + PARAMETER(jpfldo2a = 4) ! Number of fields exchanged from + ! ocean to atmosphere +! Index: /LMDZ4/trunk/libf/phylmd/param_sipc.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/param_sipc.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/param_sipc.h (revision 524) @@ -0,0 +1,24 @@ +! +! $Header$ +! +C@ +C@ -- param_sipc.h +C@ +C@ -- jpbyteint : number of bytes per integer +C@ +C@ -- jpbyterea : number of bytes per real +C@ +C@ -- jpbytecha : number of bytes per character +C@ + INTEGER jpbyteint,jpbyterea, jpbytecha + PARAMETER (jpbyteint = 4) + PARAMETER (jpbyterea = 8) + PARAMETER (jpbytecha = 1) +C@ +C@ -- jptest : The models will test during 2*jptest seconds if the file +C@ DUMMY_SIPC has been created by OASIS, signaling that the +C@ SHM pools are opened. After, they will abort. +C@ + INTEGER jptest + PARAMETER(jptest = 100) + Index: /LMDZ4/trunk/libf/phylmd/phyetat0.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/phyetat0.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/phyetat0.F (revision 524) @@ -0,0 +1,1392 @@ +! +! $Header$ +! +c +c + SUBROUTINE phyetat0 (fichnom,dtime,co2_ppm_etat0,solaire_etat0, + . rlat,rlon, pctsrf, tsol,tsoil,deltat,qsurf,qsol,snow, + . albe, alblw, evap, rain_fall, snow_fall, solsw, sollw, + . fder,radsol,frugs,agesno,clesphy0, + . zmea,zstd,zsig,zgam,zthe,zpic,zval,rugsrel,tabcntr0, + . t_ancien,q_ancien,ancien_ok, rnebcon, ratqs,clwcon, + . run_off_lic_0) + 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 "dimphy.h" +#include "netcdf.inc" +#include "indicesol.h" +#include "dimsoil.h" +#include "clesphys.h" +#include "temps.h" +c====================================================================== + CHARACTER*(*) fichnom + REAL dtime + INTEGER radpas + REAL rlat(klon), rlon(klon) + REAL co2_ppm_etat0 + REAL solaire_etat0 + REAL tsol(klon,nbsrf) + REAL tsoil(klon,nsoilmx,nbsrf) + REAL deltat(klon) + REAL qsurf(klon,nbsrf) + REAL qsol(klon) + REAL snow(klon,nbsrf) + REAL albe(klon,nbsrf) +cIM BEG alblw + REAL alblw(klon,nbsrf) +cIM END alblw + REAL evap(klon,nbsrf) + REAL radsol(klon) + REAL rain_fall(klon) + REAL snow_fall(klon) + REAL sollw(klon) + real solsw(klon) + real fder(klon) + REAL frugs(klon,nbsrf) + REAL agesno(klon,nbsrf) + REAL zmea(klon) + REAL zstd(klon) + REAL zsig(klon) + REAL zgam(klon) + REAL zthe(klon) + REAL zpic(klon) + REAL zval(klon) + REAL rugsrel(klon) + REAL pctsrf(klon, nbsrf) + REAL fractint(klon) + REAL run_off_lic_0(klon) + + REAL t_ancien(klon,klev), q_ancien(klon,klev) + real rnebcon(klon,klev),clwcon(klon,klev),ratqs(klon,klev) + LOGICAL ancien_ok + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) +c + REAL xmin, xmax +c + INTEGER nid, nvarid + INTEGER ierr, i, nsrf, isoil + INTEGER length + PARAMETER (length=100) + REAL tab_cntrl(length), tabcntr0(length) + CHARACTER*7 str7 + CHARACTER*2 str2 +c +c Ouvrir le fichier contenant l'etat initial: +c + print*,'fichnom',fichnom + ierr = NF_OPEN (fichnom, NF_NOWRITE,nid) + IF (ierr.NE.NF_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier '//fichnom + write(6,*)' ierr = ', ierr + CALL ABORT + ENDIF +c +c Lecture des parametres de controle: +c + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: 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*, 'phyetat0: Lecture echouee pour ' + CALL abort + ELSE +c + DO i = 1, length + tabcntr0( i ) = tab_cntrl( i ) + ENDDO +c + cycle_diurne = .FALSE. + soil_model = .FALSE. + new_oliq = .FALSE. + ok_orodr = .FALSE. + ok_orolf = .FALSE. + ok_limitvrai = .FALSE. + + + IF( clesphy0(1).NE.tab_cntrl( 5 ) ) THEN + tab_cntrl( 5 ) = clesphy0(1) + ENDIF + + IF( clesphy0(2).NE.tab_cntrl( 6 ) ) THEN + tab_cntrl( 6 ) = clesphy0(2) + ENDIF + + IF( clesphy0(3).NE.tab_cntrl( 7 ) ) THEN + tab_cntrl( 7 ) = clesphy0(3) + ENDIF + + IF( clesphy0(4).NE.tab_cntrl( 8 ) ) THEN + tab_cntrl( 8 ) = clesphy0(4) + ENDIF + + IF( clesphy0(5).NE.tab_cntrl( 9 ) ) THEN + tab_cntrl( 9 ) = clesphy0( 5 ) + ENDIF + + IF( clesphy0(6).NE.tab_cntrl( 10 ) ) THEN + tab_cntrl( 10 ) = clesphy0( 6 ) + ENDIF + + IF( clesphy0(7).NE.tab_cntrl( 11 ) ) THEN + tab_cntrl( 11 ) = clesphy0( 7 ) + ENDIF + + IF( clesphy0(8).NE.tab_cntrl( 12 ) ) THEN + tab_cntrl( 12 ) = clesphy0( 8 ) + ENDIF + + + dtime = tab_cntrl(1) + radpas = tab_cntrl(2) + co2_ppm_etat0 = tab_cntrl(3) + solaire_etat0 = tab_cntrl(4) + iflag_con = tab_cntrl(5) + nbapp_rad = tab_cntrl(6) + + + cycle_diurne = .FALSE. + soil_model = .FALSE. + new_oliq = .FALSE. + ok_orodr = .FALSE. + ok_orolf = .FALSE. + ok_limitvrai = .FALSE. + + IF( tab_cntrl( 7) .EQ. 1. ) cycle_diurne = .TRUE. + IF( tab_cntrl( 8) .EQ. 1. ) soil_model = .TRUE. + IF( tab_cntrl( 9) .EQ. 1. ) new_oliq = .TRUE. + IF( tab_cntrl(10) .EQ. 1. ) ok_orodr = .TRUE. + IF( tab_cntrl(11) .EQ. 1. ) ok_orolf = .TRUE. + IF( tab_cntrl(12) .EQ. 1. ) ok_limitvrai = .TRUE. + + ENDIF + + itau_phy = tab_cntrl(15) + +c +c Lecture des latitudes (coordonnees): +c + ierr = NF_INQ_VARID (nid, "latitude", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlat) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlat) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF +c +c Lecture des longitudes (coordonnees): +c + ierr = NF_INQ_VARID (nid, "longitude", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlon) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlon) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF +C +C +C Lecture du masque terre mer +C + ierr = NF_INQ_VARID (nid, "masque", nvarid) + IF (ierr .EQ. NF_NOERR) THEN +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zmasq) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zmasq) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + else + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'fichier startphy non compatible avec phyetat0' +C CALL abort + ENDIF +C Lecture des fractions pour chaque sous-surface +C +C initialisation des sous-surfaces +C + pctsrf = 0. +C +C fraction de terre +C + ierr = NF_INQ_VARID (nid, "FTER", nvarid) + IF (ierr .EQ. NF_NOERR) THEN +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, pctsrf(1 : klon,is_ter)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, pctsrf(1 : klon,is_ter)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + else + PRINT*, 'phyetat0: Le champ est absent' +c$$$ CALL abort + ENDIF +C +C fraction de glace de terre +C + ierr = NF_INQ_VARID (nid, "FLIC", nvarid) + IF (ierr .EQ. NF_NOERR) THEN +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, pctsrf(1 : klon,is_lic)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, pctsrf(1 : klon,is_lic)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + else + PRINT*, 'phyetat0: Le champ est absent' +c$$$ CALL abort + ENDIF +C +C fraction d'ocean +C + ierr = NF_INQ_VARID (nid, "FOCE", nvarid) + IF (ierr .EQ. NF_NOERR) THEN +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, pctsrf(1 : klon,is_oce)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, pctsrf(1 : klon,is_oce)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + else + PRINT*, 'phyetat0: Le champ est absent' +c$$$ CALL abort + ENDIF +C +C fraction glace de mer +C + ierr = NF_INQ_VARID (nid, "FSIC", nvarid) + IF (ierr .EQ. NF_NOERR) THEN +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, pctsrf(1 : klon,is_sic)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, pctsrf(1 : klon, is_sic)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + else + PRINT*, 'phyetat0: Le champ est absent' +c$$$ CALL abort + ENDIF +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 + ierr = NF_INQ_VARID (nid, "TS", nvarid) + IF (ierr.NE.NF_NOERR) 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 + ierr = NF_INQ_VARID (nid, "TS"//str2, nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsol(1,nsrf)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tsol(1,nsrf)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(tsol(i,nsrf),xmin) + xmax = MAX(tsol(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**' +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsol(1,1)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tsol(1,1)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(tsol(i,1),xmin) + xmax = MAX(tsol(i,1),xmax) + ENDDO + PRINT*,'Temperature du sol ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + tsol(i,nsrf) = tsol(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 + ierr = NF_INQ_VARID (nid, 'Tsoil'//str7, nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, " Il prend donc la valeur de surface" + DO i=1, klon + tsoil(i,isoil,nsrf)=tsol(i,nsrf) + ENDDO + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsoil(1,isoil,nsrf)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tsoil(1,isoil,nsrf)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "Lecture echouee pour " + CALL abort + ENDIF + ENDIF + ENDDO + ENDDO +c +c Lecture de deltat (pour slab ocean seulement): +c + ierr = NF_INQ_VARID (nid, "DELTAT", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, deltat) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, deltat) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(deltat(i),xmin) + xmax = MAX(deltat(i),xmax) + ENDDO + PRINT*,'Ecart de la SST deltat:', xmin, xmax +c +c Lecture de l'humidite de l'air juste au dessus du sol: +c + ierr = NF_INQ_VARID (nid, "QS", nvarid) + IF (ierr.NE.NF_NOERR) 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 + ierr = NF_INQ_VARID (nid, "QS"//str2, nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, qsurf(1,nsrf)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, qsurf(1,nsrf)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + 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**' +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, qsurf(1,1)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, qsurf(1,1)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "QSOL", nvarid) + IF (ierr .EQ. NF_NOERR) THEN +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, qsol) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, qsol) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + else + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Valeur par defaut nulle' + qsol(:)=0. +c$$$ CALL abort + 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 + ierr = NF_INQ_VARID (nid, "SNOW", nvarid) + IF (ierr.NE.NF_NOERR) 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 + ierr = NF_INQ_VARID (nid, "SNOW"//str2, nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow(1,nsrf)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, snow(1,nsrf)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + 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**' +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow(1,1)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, snow(1,1)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + 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 au sol: +c + ierr = NF_INQ_VARID (nid, "ALBE", nvarid) + IF (ierr.NE.NF_NOERR) 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 + ierr = NF_INQ_VARID (nid, "ALBE"//str2, nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, albe(1,nsrf)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, albe(1,nsrf)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(albe(i,nsrf),xmin) + xmax = MAX(albe(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**' +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, albe(1,1)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, albe(1,1)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(albe(i,1),xmin) + xmax = MAX(albe(i,1),xmax) + ENDDO + PRINT*,'Neige du sol ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + albe(i,nsrf) = albe(i,1) + ENDDO + ENDDO + ENDIF + +c +cIM BEG alblw +c Lecture de albedo au sol LW: +c + ierr = NF_INQ_VARID (nid, "ALBLW", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' +c PRINT*, ' Mais je vais essayer de lire ALBLW**' + PRINT*, ' Mais je vais prendre ALBE**' + DO nsrf = 1, nbsrf + DO i = 1, klon + alblw(i,nsrf) = albe(i,nsrf) + ENDDO + ENDDO +c IF (nsrf.GT.99) THEN +c PRINT*, "Trop de sous-mailles" +c CALL abort +c ENDIF +c WRITE(str2,'(i2.2)') nsrf +c ierr = NF_INQ_VARID (nid, "ALBLW"//str2, nvarid) +c IF (ierr.NE.NF_NOERR) THEN +c PRINT*, "phyetat0: Le champ est absent" +c CALL abort +c ENDIF +c#ifdef NC_DOUBLE +c ierr = NF_GET_VAR_DOUBLE(nid, nvarid, alblw(1,nsrf)) +c#else +c ierr = NF_GET_VAR_REAL(nid, nvarid, alblw(1,nsrf)) +c#endif +c IF (ierr.NE.NF_NOERR) THEN +c PRINT*, "phyetat0: Lecture echouee pour " +c CALL abort +c ENDIF +c xmin = 1.0E+20 +c xmax = -1.0E+20 +c DO i = 1, klon +c xmin = MIN(alblw(i,nsrf),xmin) +c xmax = MAX(alblw(i,nsrf),xmax) +c ENDDO +c PRINT*,'Albedo du sol ALBLW**:', nsrf, xmin, xmax +c ENDDO + ELSE + PRINT*, 'phyetat0: Le champ est present' + PRINT*, ' J ignore donc les autres ALBLW**' +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, alblw(1,1)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, alblw(1,1)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(alblw(i,1),xmin) + xmax = MAX(alblw(i,1),xmax) + ENDDO + PRINT*,'Neige du sol ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + alblw(i,nsrf) = alblw(i,1) + ENDDO + ENDDO + ENDIF + +cIM END alblw + +c +c Lecture de evaporation: +c + ierr = NF_INQ_VARID (nid, "EVAP", nvarid) + IF (ierr.NE.NF_NOERR) 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 + ierr = NF_INQ_VARID (nid, "EVAP"//str2, nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, evap(1,nsrf)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, evap(1,nsrf)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + 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**' +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, evap(1,1)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, evap(1,1)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "rain_f", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rain_fall) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rain_fall) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "snow_f", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow_fall) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, snow_fall) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "solsw", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + solsw = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, solsw) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, solsw) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "sollw", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + sollw = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, sollw) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, sollw) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "fder", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + fder = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, fder) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, fder) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "RADS", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, radsol) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, radsol) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "RUG", nvarid) + IF (ierr.NE.NF_NOERR) 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 + ierr = NF_INQ_VARID (nid, "RUG"//str2, nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, frugs(1,nsrf)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, frugs(1,nsrf)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + 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**' +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, frugs(1,1)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, frugs(1,1)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "AGESNO", nvarid) + IF (ierr.NE.NF_NOERR) 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 + ierr = NF_INQ_VARID (nid, "AGESNO"//str2, nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ est absent" + agesno = 50.0 + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, agesno(1,nsrf)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, agesno(1,nsrf)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + 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**' +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, agesno(1,1)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, agesno(1,1)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "ZMEA", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zmea) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zmea) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "ZSTD", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zstd) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zstd) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "ZSIG", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zsig) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zsig) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "ZGAM", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zgam) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zgam) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "ZTHE", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zthe) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zthe) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "ZPIC", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zpic) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zpic) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "ZVAL", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zval) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zval) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "RUGSREL", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rugsrel) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rugsrel) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(rugsrel(i),xmin) + xmax = MAX(rugsrel(i),xmax) + ENDDO + PRINT*,'Rugosite relief (ecart-type) rugsrel:', xmin, xmax +c +c + ancien_ok = .TRUE. +c + ierr = NF_INQ_VARID (nid, "TANCIEN", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ancien_ok = .FALSE. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, t_ancien) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, t_ancien) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + ENDIF +c + ierr = NF_INQ_VARID (nid, "QANCIEN", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ancien_ok = .FALSE. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q_ancien) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, q_ancien) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + ENDIF +c + ierr = NF_INQ_VARID (nid, "CLWCON", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ CLWCON est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + clwcon = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, clwcon) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, clwcon) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "RNEBCON", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ RNEBCON est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + rnebcon = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rnebcon) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rnebcon) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(rnebcon) + xmax = MAXval(rnebcon) + PRINT*,'Nebulosite convective (ecart-type) rnebcon:', xmin, xmax + +c + ierr = NF_INQ_VARID (nid, "QANCIEN", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ancien_ok = .FALSE. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q_ancien) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, q_ancien) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + ENDIF +c +c Lecture ratqs +c + ierr = NF_INQ_VARID (nid, "RATQS", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ratqs = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ratqs) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ratqs) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + 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 + ierr = NF_INQ_VARID (nid, "RUNOFFLIC0", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + run_off_lic_0 = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, run_off_lic_0) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, run_off_lic_0) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + 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 +c Fermer le fichier: +c + ierr = NF_CLOSE(nid) +c + RETURN + END Index: /LMDZ4/trunk/libf/phylmd/phyredem.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/phyredem.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/phyredem.F (revision 524) @@ -0,0 +1,786 @@ +! +! $Header$ +! +c +cIM SUBROUTINE phyredem (fichnom,dtime,radpas,co2_ppm,solaire, + SUBROUTINE phyredem (fichnom,dtime,radpas, + . rlat,rlon, pctsrf,tsol,tsoil,deltat,qsurf,qsol,snow, + . albedo, alblw, evap, rain_fall, snow_fall, + . solsw, sollw,fder, + . radsol,frugs,agesno, + . zmea,zstd,zsig,zgam,zthe,zpic,zval,rugsrel, + . t_ancien, q_ancien, rnebcon, ratqs, clwcon, + . run_off_lic_0) + 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 "dimensions.h" +#include "dimphy.h" +#include "netcdf.inc" +#include "indicesol.h" +#include "dimsoil.h" +#include "clesphys.h" +#include "control.h" +#include "temps.h" +c====================================================================== + CHARACTER*(*) fichnom + REAL dtime + INTEGER radpas + REAL rlat(klon), rlon(klon) +cIM REAL co2_ppm +cIM REAL solaire + REAL tsol(klon,nbsrf) + REAL tsoil(klon,nsoilmx,nbsrf) + REAL deltat(klon) + REAL qsurf(klon,nbsrf) + REAL qsol(klon) + REAL snow(klon,nbsrf) + REAL albedo(klon,nbsrf) +cIM BEG + REAL alblw(klon,nbsrf) +cIM END + REAL evap(klon,nbsrf) + REAL rain_fall(klon) + REAL snow_fall(klon) + real solsw(klon) + real sollw(klon) + real fder(klon) + REAL radsol(klon) + REAL frugs(klon,nbsrf) + REAL agesno(klon,nbsrf) + REAL zmea(klon) + REAL zstd(klon) + REAL zsig(klon) + REAL zgam(klon) + REAL zthe(klon) + REAL zpic(klon) + REAL zval(klon) + REAL rugsrel(klon) + REAL pctsrf(klon, nbsrf) + REAL t_ancien(klon,klev), q_ancien(klon,klev) + real clwcon(klon,klev),rnebcon(klon,klev),ratqs(klon,klev) + REAL run_off_lic_0(klon) +c + INTEGER nid, nvarid, idim1, idim2, idim3 + INTEGER ierr + INTEGER length + PARAMETER (length=100) + REAL tab_cntrl(length) +c + INTEGER isoil, nsrf + CHARACTER*7 str7 + CHARACTER*2 str2 +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 + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 28, + . "Fichier redemmarage physique") +c + ierr = NF_DEF_DIM (nid, "index", length, idim1) + ierr = NF_DEF_DIM (nid, "points_physiques", klon, idim2) + ierr = NF_DEF_DIM (nid, "horizon_vertical", klon*klev, idim3) +c + ierr = NF_ENDDEF(nid) +c + DO ierr = 1, length + tab_cntrl(ierr) = 0.0 + ENDDO + tab_cntrl(1) = dtime + tab_cntrl(2) = radpas + 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 + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "controle", NF_DOUBLE, 1, idim1,nvarid) +#else + ierr = NF_DEF_VAR (nid, "controle", NF_FLOAT, 1, idim1,nvarid) +#endif + 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) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "longitude", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "longitude", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 32, + . "Longitudes de la grille physique") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlon) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlon) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "latitude", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "latitude", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 31, + . "Latitudes de la grille physique") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlat) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlat) +#endif +c +C PB ajout du masque terre/mer +C + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "masque", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "masque", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 16, + . "masque terre mer") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zmasq) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,zmasq) +#endif +c BP ajout des fraction de chaque sous-surface +C +C 1. fraction de terre +C + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "FTER", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 21, + . "fraction de continent") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon, is_ter)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon, is_ter)) +#endif +C +C 2. Fraction de glace de terre +C + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "FLIC", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 24, + . "fraction glace de terre") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon,is_lic)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon, is_lic)) +#endif +C +C 3. fraction ocean +C + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "FOCE", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 14, + . "fraction ocean") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon, is_oce)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon, is_oce)) +#endif +C +C 4. Fraction glace de mer +C + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "FSIC", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 18, + . "fraction glace mer") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon, is_sic)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon, is_sic)) +#endif +C +C +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "TS"//str2, NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "TS"//str2, NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "Temperature de surface No."//str2) + ierr = NF_ENDDEF(nid) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsol(1,nsrf)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tsol(1,nsrf)) +#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 + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "Tsoil"//str7,NF_DOUBLE,1,idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "Tsoil"//str7,NF_FLOAT,1,idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 29, + . "Temperature du sol No."//str7) + ierr = NF_ENDDEF(nid) + ELSE + PRINT*, "Trop de couches" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsoil(1,isoil,nsrf)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tsoil(1,isoil,nsrf)) +#endif + ENDDO + ENDDO +c +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "DELTAT", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "DELTAT", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 33, + . "Ecart de la SST (pour slab-ocean)") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,deltat) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,deltat) +#endif +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"QS"//str2,NF_DOUBLE,1,idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"QS"//str2,NF_FLOAT,1,idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 25, + . "Humidite de surface No."//str2) + ierr = NF_ENDDEF(nid) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,qsurf(1,nsrf)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,qsurf(1,nsrf)) +#endif + END DO +C + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"QSOL",NF_DOUBLE,1,idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"QSOL",NF_FLOAT,1,idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 20, + . "Eau dans le sol (mm)") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,qsol) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,qsol) +#endif +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ALBE"//str2,NF_DOUBLE,1,idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ALBE"//str2,NF_FLOAT,1,idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23, + . "albedo de surface No."//str2) + ierr = NF_ENDDEF(nid) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,albedo(1,nsrf)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,albedo(1,nsrf)) +#endif + ENDDO + +cIM BEG albedo LW + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ALBLW"//str2,NF_DOUBLE,1,idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ALBLW"//str2,NF_FLOAT,1,idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23, + . "albedo LW de surface No."//str2) + ierr = NF_ENDDEF(nid) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,alblw(1,nsrf)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,alblw(1,nsrf)) +#endif + ENDDO +cIM END albedo LW +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"EVAP"//str2,NF_DOUBLE,1,idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"EVAP"//str2,NF_FLOAT,1,idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "Evaporation de surface No."//str2) + ierr = NF_ENDDEF(nid) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,evap(1,nsrf)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,evap(1,nsrf)) +#endif + ENDDO + +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"SNOW"//str2,NF_DOUBLE,1,idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"SNOW"//str2,NF_FLOAT,1,idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 22, + . "Neige de surface No."//str2) + ierr = NF_ENDDEF(nid) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,snow(1,nsrf)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,snow(1,nsrf)) +#endif + ENDDO + +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "RADS", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "RADS", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "Rayonnement net a la surface") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,radsol) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,radsol) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "solsw", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "solsw", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 32, + . "Rayonnement solaire a la surface") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,solsw) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,solsw) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "sollw", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "sollw", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 27, + . "Rayonnement IF a la surface") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,sollw) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,sollw) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "fder", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "fder", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 14, + . "Derive de flux") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,fder) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,fder) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "rain_f", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "rain_f", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 21, + . "precipitation liquide") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rain_fall) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rain_fall) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "snow_f", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "snow_f", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 20, + . "precipitation solide") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,snow_fall) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,snow_fall) +#endif +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"RUG"//str2,NF_DOUBLE,1,idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"RUG"//str2,NF_FLOAT,1,idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23, + . "rugosite de surface No."//str2) + ierr = NF_ENDDEF(nid) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,frugs(1,nsrf)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,frugs(1,nsrf)) +#endif + ENDDO +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"AGESNO"//str2,NF_DOUBLE,1,idim2 + $ ,nvarid) +#else + ierr = NF_DEF_VAR (nid,"AGESNO"//str2,NF_FLOAT,1,idim2 + $ ,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 15, + . "Age de la neige surface No."//str2) + ierr = NF_ENDDEF(nid) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,agesno(1,nsrf)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,agesno(1,nsrf)) +#endif + ENDDO +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "ZMEA", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "ZMEA", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zmea) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,zmea) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "ZSTD", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "ZSTD", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zstd) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,zstd) +#endif + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "ZSIG", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "ZSIG", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zsig) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,zsig) +#endif + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "ZGAM", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "ZGAM", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zgam) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,zgam) +#endif + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "ZTHE", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "ZTHE", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zthe) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,zthe) +#endif + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "ZPIC", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "ZPIC", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zpic) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,zpic) +#endif + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "ZVAL", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "ZVAL", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zval) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,zval) +#endif + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "RUGSREL", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "RUGSREL", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rugsrel) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rugsrel) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "TANCIEN", NF_DOUBLE, 1, idim3,nvarid) +#else + ierr = NF_DEF_VAR (nid, "TANCIEN", NF_FLOAT, 1, idim3,nvarid) +#endif + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,t_ancien) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,t_ancien) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "QANCIEN", NF_DOUBLE, 1, idim3,nvarid) +#else + ierr = NF_DEF_VAR (nid, "QANCIEN", NF_FLOAT, 1, idim3,nvarid) +#endif + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q_ancien) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q_ancien) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "RUGMER", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "RUGMER", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "Longueur de rugosite sur mer") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,frugs(1,is_oce)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,frugs(1,is_oce)) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "CLWCON", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "CLWCON", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "Eau liquide convective") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,clwcon) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,clwcon) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "RNEBCON", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "RNEBCON", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "Nebulosite convective") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rnebcon) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rnebcon) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "RATQS", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "RATQS", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "Ratqs") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ratqs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ratqs) +#endif +c +c run_off_lic_0 +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr=NF_DEF_VAR(nid,"RUNOFFLIC0",NF_DOUBLE,1,idim2,nvarid) +#else + ierr=NF_DEF_VAR(nid,"RUNOFFLIC0",NF_FLOAT, 1,idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "Runofflic0") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,run_off_lic_0) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,run_off_lic_0) +#endif +c +c + ierr = NF_CLOSE(nid) +c + RETURN + END Index: /LMDZ4/trunk/libf/phylmd/physiq.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/physiq.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/physiq.F (revision 524) @@ -0,0 +1,2905 @@ +! +! $Header$ +! +C +c $Header$ +c + SUBROUTINE physiq (nlon,nlev,nqmax, + . debut,lafin,rjourvrai,gmtime,pdtphys, + . paprs,pplay,pphi,pphis,presnivs,clesphy0, + . u,v,t,qx, + . omega, +#ifdef INCA_CH4 + . flxmass_w, +#endif + . d_u, d_v, d_t, d_qx, d_ps) + + USE ioipsl + USE histcom +#ifdef INCA + USE chemshut +#ifdef INCA_CH4 +! USE obs_pos +#endif +#endif + 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 histhf +#define histday +#define histmth +#define histins +c #define histISCCP +c #define histREGDYN +c #define histmthNMC +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 +c nqmax---input-I-nombre de traceurs (y compris vapeur d'eau) = 1 +c debut---input-L-variable logique indiquant le premier passage +c lafin---input-L-variable logique indiquant le dernier passage +c rjour---input-R-numero du jour de l'experience +c gmtime--input-R-temps universel dans la journee (0 a 86400 s) +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 omega---input-R-vitesse verticale en Pa/s +c +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 +c====================================================================== +#include "dimensions.h" + integer jjmp1 + parameter (jjmp1=jjm+1-1/jjm) +#include "dimphy.h" +#include "regdim.h" +#include "indicesol.h" +#include "dimsoil.h" +#include "clesphys.h" +#include "control.h" +#include "temps.h" +#include "comgeomphy.h" +#include "advtrac.h" +#include "iniprint.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.) +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====================================================================== +c Parametres lies au coupleur OASIS: +#include "oasis.h" + INTEGER,SAVE :: npas, nexca + logical rnpb +#ifdef INCA + parameter(rnpb=.false.) +#else + parameter(rnpb=.true.) +#endif +c ocean = type de modele ocean a utiliser: force, slab, couple + character*6 ocean + SAVE ocean + +c parameter (ocean = 'force ') +c parameter (ocean = 'couple') + logical ok_ocean +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.) + logical ok_veget + save ok_veget +c parameter (ok_veget = .true.) +c parameter (ok_veget = .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 PARAMETER (ok_journe=.true.) +c + LOGICAL ok_mensuel ! sortir le fichier mensuel + save ok_mensuel +c PARAMETER (ok_mensuel=.true.) +c + LOGICAL ok_instan ! sortir le fichier instantane + save ok_instan +c PARAMETER (ok_instan=.true.) +c + LOGICAL ok_region ! sortir le fichier regional + PARAMETER (ok_region=.FALSE.) +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 + INTEGER nqmax + REAL rjourvrai + REAL gmtime + 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 zsurf(nbsrf) + + REAL u(klon,klev) + REAL v(klon,klev) + REAL t(klon,klev) + REAL qx(klon,klev,nqmax) + + REAL t_ancien(klon,klev), q_ancien(klon,klev) + SAVE t_ancien, q_ancien + LOGICAL ancien_ok + SAVE ancien_ok + + REAL d_t_dyn(klon,klev) + REAL d_q_dyn(klon,klev) + + REAL omega(klon,klev) + +#ifdef INCA_CH4 + REAL flxmass_w(klon,klev) +#endif + REAL d_u(klon,klev) + REAL d_v(klon,klev) + REAL d_t(klon,klev) + REAL d_qx(klon,klev,nqmax) + REAL d_ps(klon) + + INTEGER klevp1, klevm1 + PARAMETER(klevp1=klev+1,klevm1=klev-1) +#include "raddim.h" +c +cIM 080304 REAL swdn0(klon,2), swdn(klon,2), swup0(klon,2), swup(klon,2) + REAL swdn0(klon,klevp1), swdn(klon,klevp1) + REAL swup0(klon,klevp1), swup(klon,klevp1) + SAVE swdn0 , swdn, swup0, swup +c + REAL SWdn200clr(klon), SWdn200(klon) + REAL SWup200clr(klon), SWup200(klon) + SAVE SWdn200clr, SWdn200, SWup200clr, SWup200 +c + REAL lwdn0(klon,klevp1), lwdn(klon,klevp1) + REAL lwup0(klon,klevp1), lwup(klon,klevp1) + SAVE lwdn0 , lwdn, lwup0, lwup +c + REAL LWdn200clr(klon), LWdn200(klon) + REAL LWup200clr(klon), LWup200(klon) + SAVE LWdn200clr, LWdn200, LWup200clr, LWup200 +c + REAL LWdnTOA(klon), LWdnTOAclr(klon) + SAVE LWdnTOA, LWdnTOAclr +c +c vents meridien et zonal a un niveau de pression +c + integer nlevSTD + PARAMETER(nlevSTD=17) + real rlevSTD(nlevSTD) + DATA rlevSTD/100000., 92500., 85000., 70000., + .60000., 50000., 40000., 30000., 25000., 20000., + .15000., 10000., 7000., 5000., 3000., 2000., 1000./ + CHARACTER*5 clevSTD(nlevSTD), aa, bb + DATA clevSTD/'1000','925 ','850 ','700 ','600 ', + .'500 ','400 ','300 ','250 ','200 ','150 ','100 ', + .'70 ','50 ','30 ','20 ','10 '/ +c + real tlevSTD(klon,nlevSTD), qlevSTD(klon,nlevSTD) + real rhlevSTD(klon,nlevSTD), philevSTD(klon,nlevSTD) + real ulevSTD(klon,nlevSTD), vlevSTD(klon,nlevSTD) +c +cIM ENSEMBLES BEG +c + integer nlevENS + PARAMETER(nlevENS=4) + integer indENS(nlevENS) + save indENS + real rlevENS(nlevENS) + DATA rlevENS/85000., 70000., 50000., 20000./ + CHARACTER*3 clev(nlevENS) + DATA clev/'850','700','500','200'/ + + real tlev(klon,nlevENS), qlev(klon,nlevENS), rhlev(klon,nlevENS) + real ulev(klon,nlevENS), vlev(klon,nlevENS), philev(klon,nlevENS) + real wlev(klon,nlevENS) +cIM ENSEMBLES END +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) + +c ISCCP simulator v3.4 +c dans clesphys.h top_height, overlap +cv3.4 + INTEGER debug, debugcol + INTEGER npoints + 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 +c + REAL nbsunlit(nregISCtot,klon) !nbsunlit : moyenne de sunlit + INTEGER ncol, seed(klon) + +c ncol = nb. de sous-colonnes pour chaque maille du GCM +c PARAMETER(ncol=100) +c PARAMETER(ncol=625) +c PARAMETER(ncol=10) + PARAMETER(ncol=25) + REAL tautab(0:255) + INTEGER invtau(-20:45000) + REAL emsfc_lw + PARAMETER(emsfc_lw=0.99) + 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 output from ISCCP simulator + REAL fq_isccp(klon,7,7) + REAL totalcldarea(klon) + REAL meanptop(klon) + REAL meantaucld(klon) + REAL boxtau(klon,ncol) + REAL boxptop(klon,ncol) +c + INTEGER l, ni, nj, kmax, lmax + PARAMETER(kmax=8, lmax=8) + INTEGER kmaxm1, lmaxm1 + PARAMETER(kmaxm1=kmax-1, lmaxm1=lmax-1) + INTEGER iimx7, jjmx7, jjmp1x7 + PARAMETER(iimx7=iim*kmaxm1, jjmx7=jjm*lmaxm1, + .jjmp1x7=jjmp1*lmaxm1) + REAL fq4d(iim,jjmp1,kmaxm1,lmaxm1) + REAL fq3d(iimx7, jjmp1x7) +c + INTEGER iw, iwmax + REAL wmin, pas_w +c PARAMETER(wmin=-100.,pas_w=10.,iwmax=30) + PARAMETER(wmin=-200.,pas_w=10.,iwmax=40) + REAL o500(klon) +c +cIM: nbregdyn = nbre regions pour calculs statistiques sur output du ISCCP +cIM: dynamiques + INTEGER nreg, nbregdyn + PARAMETER(nbregdyn=5) + REAL histoW(kmaxm1,lmaxm1,iwmax,nbregdyn) + REAL nhistoW(kmaxm1,lmaxm1,iwmax,nbregdyn) + REAL nhistoWt(kmaxm1,lmaxm1,iwmax,nbregdyn) + SAVE nhistoWt + + INTEGER linv + INTEGER pct_ocean(klon,nbregdyn) + REAL rlonPOS(klon) + +c sorties ISCCP + + logical ok_isccp + real ecrit_isccp + integer nid_isccp + save ok_isccp, ecrit_isccp, nid_isccp + +#ifdef histISCCP + data ok_isccp/.true./ +#else + data ok_isccp/.false./ +#endif + +c sorties statistiques regime dynamique + logical ok_regdyn + real ecrit_regdyn + integer nid_regdyn + save ok_regdyn, ecrit_regdyn, nid_regdyn + +#ifdef histREGDYN +c data ok_regdyn,ecrit_regdyn/.true.,0.125/ +c data ok_regdyn,ecrit_regdyn/.true.,1./ + data ok_regdyn/.true./ +#else + data ok_regdyn/.false./ +#endif + + 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./ + DATA zx_pc/50., 180., 310., 440., 560., 680., 800./ + +c cldtopres pression au sommet des nuages + REAL cldtopres(lmaxm1) + DATA cldtopres/50., 180., 310., 440., 560., 680., 800./ + + INTEGER komega, nhoriRD + +c taulev: numero du niveau de tau dans les sorties ISCCP + CHARACTER *4 taulev(kmaxm1) + DATA taulev/'tau1','tau2','tau3','tau4','tau5','tau6','tau7'/ + + REAL zx_lonx7(iimx7), zx_latx7(jjmp1x7) + INTEGER nhorix7 +cIM: region='3d' <==> sorties en global + CHARACTER*3 region + PARAMETER(region='3d') +c + logical ok_hf + real ecrit_hf + integer nid_hf, nid_hf3d + save ok_hf, ecrit_hf, nid_hf, nid_hf3d + +c QUESTION : noms de variables ? + +#ifdef histhf + data ok_hf,ecrit_hf/.true.,0.25/ +#else + data ok_hf/.false./ +#endif + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) +c +c Variables quasi-arguments +c + REAL xjour + SAVE xjour +c +c +c Variables propres a la physique +c + REAL dtime + SAVE dtime ! pas temporel de la physique +c + INTEGER radpas + SAVE radpas ! frequence d'appel rayonnement +c + REAL radsol(klon) + SAVE radsol ! bilan radiatif au sol calcule par code radiatif +c + REAL rlat(klon) + SAVE rlat ! latitude pour chaque point +c + REAL rlon(klon) + SAVE rlon ! longitude pour chaque point +c +cc INTEGER iflag_con +cc SAVE iflag_con ! indicateur de la convection +c + INTEGER itap + SAVE itap ! compteur pour la physique +c + REAL co2_ppm_etat0 +c + REAL solaire_etat0 +c + real slp(klon) ! sea level pressure + + REAL ftsol(klon,nbsrf) + SAVE ftsol ! temperature du sol +c + REAL ftsoil(klon,nsoilmx,nbsrf) + SAVE ftsoil ! temperature dans le sol +c + REAL fevap(klon,nbsrf) + SAVE fevap ! evaporation + REAL fluxlat(klon,nbsrf) + SAVE fluxlat +c + REAL deltat(klon) + SAVE deltat ! ecart avec la SST de reference +c + REAL fqsurf(klon,nbsrf) + SAVE fqsurf ! humidite de l'air au contact de la surface +c + REAL qsol(klon) + SAVE qsol ! hauteur d'eau dans le sol +c + REAL fsnow(klon,nbsrf) + SAVE fsnow ! epaisseur neigeuse +c + REAL falbe(klon,nbsrf) + SAVE falbe ! albedo par type de surface + REAL falblw(klon,nbsrf) + SAVE falblw ! albedo par type de surface + +c +c +c Parametres de l'Orographie a l'Echelle Sous-Maille (OESM): +c + REAL zmea(klon) + SAVE zmea ! orographie moyenne +c + REAL zstd(klon) + SAVE zstd ! deviation standard de l'OESM +c + REAL zsig(klon) + SAVE zsig ! pente de l'OESM +c + REAL zgam(klon) + save zgam ! anisotropie de l'OESM +c + REAL zthe(klon) + SAVE zthe ! orientation de l'OESM +c + REAL zpic(klon) + SAVE zpic ! Maximum de l'OESM +c + REAL zval(klon) + SAVE zval ! Minimum de l'OESM +c + REAL rugoro(klon) + SAVE rugoro ! longueur de rugosite de l'OESM +c + REAL zulow(klon),zvlow(klon),zustr(klon), zvstr(klon) +c + REAL zuthe(klon),zvthe(klon) + SAVE zuthe + SAVE zvthe + INTEGER igwd,idx(klon),itest(klon) +c + REAL agesno(klon,nbsrf) + SAVE agesno ! age de la neige +c + REAL alb_neig(klon) + SAVE alb_neig ! albedo de la neige +c + REAL run_off_lic_0(klon) + SAVE run_off_lic_0 +cKE43 +c Variables liees a la convection de K. Emanuel (sb): +c + REAL ema_workcbmf(klon) ! cloud base mass flux + SAVE ema_workcbmf + + REAL ema_cbmf(klon) ! cloud base mass flux + SAVE ema_cbmf + + REAL ema_pcb(klon) ! cloud base pressure + SAVE ema_pcb + + REAL ema_pct(klon) ! cloud top pressure + SAVE ema_pct + + REAL bas, top ! cloud base and top levels + SAVE bas + SAVE top + + REAL Ma(klon,klev) ! undilute upward mass flux + SAVE Ma + REAL qcondc(klon,klev) ! in-cld water content from convect + SAVE qcondc + REAL ema_work1(klon, klev), ema_work2(klon, klev) + SAVE ema_work1, ema_work2 + REAL wdn(klon), tdn(klon), qdn(klon) + + REAL wd(klon) ! sb + SAVE wd ! sb + +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 ycoefh(klon,klev) ! coef d'echange pour phytrac + REAL yu1(klon) ! vents dans la premiere couche U + REAL yv1(klon) ! vents dans la premiere couche V + REAL ffonte(klon,nbsrf) !Flux thermique utilise pour fondre la neige + REAL fqcalving(klon,nbsrf) !Flux d'eau "perdue" par la surface +c !et necessaire pour limiter la +c !hauteur de neige, en kg/m2/s + REAL zxffonte(klon), zxfqcalving(klon) + + LOGICAL offline ! Controle du stockage ds "physique" + PARAMETER (offline=.false.) + INTEGER physid + REAL pfrac_impa(klon,klev)! Produits des coefs lessivage impaction + save pfrac_impa + REAL pfrac_nucl(klon,klev)! Produits des coefs lessivage nucleation + save pfrac_nucl + REAL pfrac_1nucl(klon,klev)! Produits des coefs lessi nucl (alpha = 1) + save pfrac_1nucl + REAL frac_impa(klon,klev) ! fractions d'aerosols lessivees (impaction) + REAL frac_nucl(klon,klev) ! idem (nucleation) +#ifdef INCA + REAL :: calday +#endif + +cAA + REAL rain_fall(klon) ! pluie + REAL snow_fall(klon) ! neige + save snow_fall, rain_fall +cIM 050204 BEG + REAL total_rain(klon), nday_rain(klon) + save total_rain, nday_rain +cIM 050204 END + REAL evap(klon), devap(klon) ! evaporation et sa derivee + REAL sens(klon), dsens(klon) ! chaleur sensible et sa derivee + REAL dlw(klon) ! derivee infra rouge + REAL bils(klon) ! bilan de chaleur au sol + REAL wfbils(klon,nbsrf) ! bilan de chaleur au sol, pour chaque +C ! type de sous-surface et pondere par la fraction + REAL fder(klon) ! Derive de flux (sensible et latente) + save fder + 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) ! longueur de rugosite + save frugs + REAL zxrugs(klon) ! longueur de rugosite +c +c Conditions aux limites +c + INTEGER julien +c + INTEGER lmt_pas + SAVE lmt_pas ! frequence de mise a jour + REAL pctsrf(klon,nbsrf) +cIM + REAL pctsrf_new(klon,nbsrf) !pourcentage surfaces issus d'ORCHIDEE + REAL paire_ter(klon) !surfaces terre +cIM + SAVE pctsrf ! sous-fraction du sol + REAL albsol(klon) + SAVE albsol ! albedo du sol total + REAL albsollw(klon) + SAVE albsollw ! albedo du sol total + + REAL wo(klon,klev) + SAVE wo ! ozone +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 clmain ! couche limite + 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 + EXTERNAL o3cm ! initialiser l'ozone + EXTERNAL orbite ! calculer l'orbite terrestre + EXTERNAL ozonecm ! prescrire l'ozone + EXTERNAL phyetat0 ! lire l'etat initial de la physique + EXTERNAL phyredem ! ecrire l'etat de redemarrage de la physique + EXTERNAL radlwsw ! rayonnements solaire et infrarouge + EXTERNAL suphec ! 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 +c +c Variables locales +c + real clwcon(klon,klev),rnebcon(klon,klev) + real clwcon0(klon,klev),rnebcon0(klon,klev) + save rnebcon, clwcon + + 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 + REAL heat(klon,klev) ! chauffage solaire + REAL heat0(klon,klev) ! chauffage solaire ciel clair + REAL cool(klon,klev) ! refroidissement infrarouge + REAL cool0(klon,klev) ! refroidissement infrarouge ciel clair + REAL topsw(klon), toplw(klon), solsw(klon), sollw(klon) + real sollwdown(klon) ! downward LW flux at surface +cIM BEG + real sollwdownclr(klon) ! downward CS LW flux at surface + real toplwdown(klon) ! downward CS LW flux at TOA + real toplwdownclr(klon) ! downward CS LW flux at TOA +cIM END + REAL topsw0(klon), toplw0(klon), solsw0(klon), sollw0(klon) + REAL albpla(klon) + 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 + SAVE heat,cool,albpla,topsw,toplw,solsw,sollw,sollwdown + SAVE sollwdownclr, toplwdown, toplwdownclr + SAVE topsw0,toplw0,solsw0,sollw0, heat0, cool0 +c + INTEGER itaprad + SAVE 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) +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 + REAL t_coup + PARAMETER (t_coup=234.0) +c + REAL zphi(klon,klev) + REAL zx_tmp_x(iim), zx_tmp_yjjmp1 + REAL zx_relief(iim,jjmp1) + REAL zx_aire(iim,jjmp1) +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 + REAL cape(klon) ! CAPE + SAVE cape + CHARACTER*40 capemaxcels !max(CAPE) + + REAL pbase(klon) ! cloud base pressure + SAVE pbase + REAL bbase(klon) ! cloud base buoyancy + SAVE bbase + 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 d_t_con(klon,klev),d_q_con(klon,klev) + REAL d_u_con(klon,klev),d_v_con(klon,klev) + REAL d_t_lsc(klon,klev),d_q_lsc(klon,klev),d_ql_lsc(klon,klev) + REAL d_t_ajs(klon,klev), d_q_ajs(klon,klev) + REAL d_t_eva(klon,klev),d_q_eva(klon,klev) + REAL rneb(klon,klev) +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 + INTEGER ibas_con(klon), itop_con(klon) + REAL rain_con(klon), rain_lsc(klon) + REAL snow_con(klon), snow_lsc(klon) + REAL d_ts(klon,nbsrf) +c + REAL d_u_vdf(klon,klev), d_v_vdf(klon,klev) + REAL d_t_vdf(klon,klev), d_q_vdf(klon,klev) +c + REAL d_u_oro(klon,klev), d_v_oro(klon,klev) + REAL d_t_oro(klon,klev) + REAL d_u_lif(klon,klev), d_v_lif(klon,klev) + REAL d_t_lif(klon,klev) + REAL d_u_oli(klon,klev), d_v_oli(klon,klev) !tendances dues a oro et lif + + REAL ratqs(klon,klev),ratqss(klon,klev),ratqsc(klon,klev) + real ratqsbas,ratqshaut + save ratqsbas,ratqshaut, 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 + save fact_cldcon,facttemps + real facteur + + integer iflag_cldcon + save iflag_cldcon + + logical ptconv(klon,klev) + +c +c Variables liees a l'ecriture de la bande histoire physique +c + INTEGER ecrit_mth + SAVE ecrit_mth ! frequence d'ecriture (fichier mensuel) +c + INTEGER ecrit_day + SAVE ecrit_day ! frequence d'ecriture (fichier journalier) +c + INTEGER ecrit_ins + SAVE ecrit_ins ! frequence d'ecriture (fichier instantane) +c + INTEGER ecrit_reg + SAVE ecrit_reg ! frequence d'ecriture +c + integer itau_w ! pas de temps ecriture = itap + itau_phy +c +c +c Variables locales pour effectuer les appels en serie +c + REAL t_seri(klon,klev), q_seri(klon,klev) + REAL ql_seri(klon,klev),qs_seri(klon,klev) + REAL u_seri(klon,klev), v_seri(klon,klev) +c + REAL tr_seri(klon,klev,nbtr) + REAL d_tr(klon,klev,nbtr) + + REAL zx_rh(klon,klev) + + INTEGER length + PARAMETER ( length = 100 ) + REAL tabcntr0( length ) +c + INTEGER ndex2d(iim*jjmp1),ndex3d(iim*jjmp1*klev) + REAL zx_tmp_fi2d(klon) ! variable temporaire grille physique + REAL zx_tmp_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 + SAVE nid_day, nid_mth, nid_ins, nid_nmc +c + INTEGER nhori, nvert + REAL zsto, zout, zsto1, zsto2 + real zjulian + save 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 + 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 + REAL zero_v(klon) + CHARACTER*15 ztit + INTEGER ip_ebil ! PRINT level for energy conserv. diag. + SAVE ip_ebil + DATA ip_ebil/0/ + INTEGER if_ebil ! level for energy conserv. dignostics + SAVE 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 +cIM: t2m, q2m, u10m, v10m et t2mincels, t2maxcels + REAL t2m(klon,nbsrf), q2m(klon,nbsrf) !temperature, humidite a 2m + REAL u10m(klon,nbsrf), v10m(klon,nbsrf) !vents a 10m + 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 +cjq Aerosol effects (Johannes Quaas, 27/11/2003) + REAL sulfate(klon, klev) ! SO4 aerosol concentration [ug/m3] + REAL sulfate_pi(klon, klev) ! SO4 aerosol concentration [ug/m3] (pre-industrial value) + SAVE sulfate_pi + + 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 + REAL tau_ae(klon,klev,2), piz_ae(klon,klev,2) + REAL cg_ae(klon,klev,2) + + REAL topswad(klon), solswad(klon) ! Aerosol direct effect. + ! ok_ade=T -ADE=topswad-topsw + + REAL topswai(klon), solswai(klon) ! Aerosol indirect effect. + ! ok_aie=T -> + ! ok_ade=T -AIE=topswai-topswad + ! ok_ade=F -AIE=topswai-topsw + + REAL aerindex(klon) ! POLDER aerosol index + + ! Parameters + LOGICAL ok_ade, ok_aie ! Apply aerosol (in)direct effects or not + REAL bl95_b0, bl95_b1 ! Parameter in Boucher and Lohmann (1995) +cjq-end +c +c Declaration des constantes et des fonctions thermodynamiques +c +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +c====================================================================== + modname = 'physiq' + IF (if_ebil.ge.1) THEN + DO i=1,klon + zero_v(i)=0. + END DO + END IF + ok_sync=.TRUE. + IF (nqmax .LT. 2) THEN + abort_message = 'eaux vapeur et liquide sont indispensables' + CALL abort_gcm (modname,abort_message,1) + ENDIF + IF (debut) THEN + CALL suphec ! initialiser constantes et parametres phys. +c +cIM 050204 BEG + DO i=1, klon + nday_rain(i)=0. + ENDDO +cIM 050204 END +c +c====================================================================== +cIM BEG + DO k=1, nlev + DO l=1, nlevSTD +c + bb=clevSTD(l) +c + IF(l.GE.2) THEN + aa=clevSTD(l) + bb=aa(1:lnblnk1(aa)) + ENDIF +c + IF(bb.EQ.clev(k)) THEN +c print*,'k=',k,'l=',l,'clev=',clev(k) + indENS(k)=l +c print*,'k=',k,'l=',l,'clev=',clev(k),'indENS=',indENS(k) + ENDIF +c + ENDDO + ENDDO +c + ENDIF !debut +cIM END + xjour = rjourvrai +c +c Si c'est le debut, il faut initialiser plusieurs choses +c ******** +c + IF (debut) THEN +C + IF (if_ebil.ge.1) d_h_vcol_phy=0. +c +c appel a la lecture du run.def physique +c + call conf_phys(ocean, ok_veget, ok_journe, ok_mensuel, + . ok_instan, fact_cldcon, facttemps,ok_newmicro, + . iflag_cldcon,ratqsbas,ratqshaut, if_ebil, + . ok_ade, ok_aie, + . bl95_b0, bl95_b1) +cIM . , RI0) + +c +c +c Initialiser les compteurs: +c + + frugs = 0. + itap = 0 + itaprad = 0 + CALL phyetat0 ("startphy.nc",dtime,co2_ppm_etat0,solaire_etat0, + . rlat,rlon,pctsrf, ftsol,ftsoil,deltat,fqsurf,qsol,fsnow, + . falbe, falblw, fevap, rain_fall,snow_fall,solsw, sollwdown, + . dlw,radsol,frugs,agesno,clesphy0, + . zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro,tabcntr0, + . t_ancien, q_ancien, ancien_ok, rnebcon, ratqs,clwcon, + . run_off_lic_0) + +c + radpas = NINT( 86400./dtime/nbapp_rad) +c +C on remet le calendrier a zero +c + IF (raz_date .eq. 1) THEN + itau_phy = 0 + ENDIF + +c + CALL printflag( tabcntr0,radpas,ok_ocean,ok_oasis ,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) + 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) = klev+1 + ENDDO +cIM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>END + + ENDIF + +c34EK + IF (ok_orodr) THEN + DO i=1,klon + rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0) + ENDDO + CALL SUGWD(klon,klev,paprs,pplay) + 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 + ecrit_mth = NINT(86400./dtime *ecritphy) ! tous les ecritphy jours + IF (ok_mensuel) THEN + WRITE(lunout,*)'La frequence de sortie mensuelle est de ', + . ecrit_mth + ENDIF + ecrit_day = NINT(86400./dtime *1.0) ! tous les jours + IF (ok_journe) THEN + WRITE(lunout,*)'La frequence de sortie journaliere est de ', + . ecrit_day + ENDIF +ccc ecrit_ins = NINT(86400./dtime *0.5) ! 2 fois par jour +ccc ecrit_ins = NINT(86400./dtime *0.25) ! 4 fois par jour + ecrit_ins = NINT(86400./dtime/48.) ! a chaque pas de temps ==> PB. dans time_counter pour 1mois + ecrit_ins = NINT(86400./dtime/12.) ! toutes les deux heures + IF (ok_instan) THEN + WRITE(lunout,*)'La frequence de sortie instant. est de ', + . ecrit_ins + ENDIF + ecrit_reg = NINT(86400./dtime *0.25) ! 4 fois par jour + IF (ok_region) THEN + WRITE(lunout,*)'La frequence de sortie region est de ', + . ecrit_reg + ENDIF + +c +c Initialiser le couplage si necessaire +c + npas = 0 + nexca = 0 + if (ocean == 'couple') then + npas = itaufin/ iphysiq + nexca = 86400 / dtime + write(lunout,*)' ##### Ocean couple #####' + write(lunout,*)' Valeurs des pas de temps' + write(lunout,*)' npas = ', npas + write(lunout,*)' nexca = ', nexca + endif +c +c +cIM + capemaxcels = 't_max(X)' + t2mincels = 't_min(X)' + t2maxcels = 't_max(X)' + +c +c============================================================= +c Initialisation des sorties +c============================================================= + +#ifdef CPP_IOIPSL + +#ifdef histhf +#include "ini_histhf.h" +#endif + +#ifdef histday +#include "ini_histday.h" +#endif + +#ifdef histmth +#include "ini_histmth.h" +#endif + +#ifdef histins +#include "ini_histins.h" +#endif + +#ifdef histISCCP +#include "ini_histISCCP.h" +#endif + +#ifdef histmthNMC +#include "ini_histmthNMC.h" +#endif + +#ifdef histREGDYN +#include "ini_histREGDYN.h" +#endif + +#ifdef histISCCP +#include "ini_histISCCP.h" +#endif +#endif + +cXXXPB Positionner date0 pour initialisation de ORCHIDEE + date0 = zjulian +C date0 = day_ini + 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 +#ifdef INCA + iii = MOD(NINT(xjour),360) + calday = FLOAT(iii) + gmtime + WRITE(lunout,*) 'initial time ', xjour, calday +#ifdef INCAINFO + WRITE(lunout,*) 'Appel CHEMINI ...' +#endif + CALL chemini( rpi, + $ rg, + $ ra, + $ airephy, + $ rlat, + $ rlon, + $ presnivs, + $ calday, + $ tracnam, + $ natsnam, +c $ mxoutflds, +c $ outinst, +c $ outtimav, + $ klon, + $ nqmax, + $ pdtphys, + $ anne_ref, + $ day_ini) +#ifdef INCAINFO + WRITE(lunout,*) 'OK.' +#endif +#endif +c + ENDIF +c +c **************** Fin de IF ( debut ) *************** +c +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, nqmax + DO k = 1, klev + DO i = 1, klon + d_qx(i,k,iq) = 0.0 + ENDDO + ENDDO + ENDDO +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 (nqmax.GE.3) THEN + DO iq = 3, nqmax + 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 +C + IF (if_ebil.ge.1) THEN + ztit='after dynamic' + CALL diagetpq(airephy,ztit,ip_ebil,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 + 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_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_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 + CALL hgardfou(t_seri,ftsol,'debutphy') +c +c Incrementer le compteur de la physique +c + itap = itap + 1 + julien = MOD(NINT(xjour),360) + if (julien .eq. 0) julien = 360 +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 (MOD(itap-1,lmt_pas) .EQ. 0) THEN + WRITE(lunout,*)' PHYS cond julien ',julien + CALL ozonecm( FLOAT(julien), rlat, paprs, wo) + 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 +c + IF (if_ebil.ge.2) THEN + ztit='after reevap' + CALL diagetpq(airephy,ztit,ip_ebil,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 + 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 +c Appeler la diffusion verticale (programme de couche limite) +c + DO i = 1, klon +c if (.not. ok_veget) then +c frugs(i,is_ter) = SQRT(frugs(i,is_ter)**2+rugoro(i)**2) +c endif +c frugs(i,is_lic) = rugoro(i) +c frugs(i,is_oce) = rugmer(i) +c frugs(i,is_sic) = 0.001 + zxrugs(i) = 0.0 + ENDDO + DO nsrf = 1, nbsrf + DO i = 1, klon +c frugs(i,nsrf) = MAX(frugs(i,nsrf),0.001) + frugs(i,nsrf) = MAX(frugs(i,nsrf),0.000015) + ENDDO + ENDDO + DO nsrf = 1, nbsrf + DO i = 1, klon + zxrugs(i) = zxrugs(i) + frugs(i,nsrf)*pctsrf(i,nsrf) + ENDDO + ENDDO +c +C calculs necessaires au calcul de l'albedo dans l'interface +c + CALL orbite(FLOAT(julien),zlongi,dist) + IF (cycle_diurne) THEN + zdtime=dtime*FLOAT(radpas) ! pas de temps du rayonnement (s) + CALL zenang(zlongi,gmtime,zdtime,rlat,rlon,rmu0,fract) + ELSE + rmu0 = -999.999 + ENDIF +cIM BEG + DO i=1, klon + sunlit(i)=1 + IF(rmu0(i).EQ.0.) sunlit(i)=0 + nbsunlit(1,i)=FLOAT(sunlit(i)) + ENDDO +cIM END +C Calcul de l'abedo moyen par maille + albsol(:)=0. + albsollw(:)=0. + DO nsrf = 1, nbsrf + DO i = 1, klon + albsol(i) = albsol(i) + falbe(i,nsrf) * pctsrf(i,nsrf) + albsollw(i) = albsollw(i) + falblw(i,nsrf) * pctsrf(i,nsrf) + ENDDO + ENDDO +C +C Repartition sous maille des flux LW et SW +C Modif OM+PASB+JLD +C Repartition du longwave par sous-surface linearisee +Cn + + DO nsrf = 1, nbsrf + DO i = 1, klon +c$$$ fsollw(i,nsrf) = sollwdown(i) - RSIGMA*ftsol(i,nsrf)**4 +c$$$ fsollw(i,nsrf) = sollw(i) + fsollw(i,nsrf) = sollw(i) + $ + 4.0*RSIGMA*ztsol(i)**3 * (ztsol(i)-ftsol(i,nsrf)) + fsolsw(i,nsrf) = solsw(i)*(1.-falbe(i,nsrf))/(1.-albsol(i)) + ENDDO + ENDDO + + fder = dlw + + + CALL clmain(dtime,itap,date0,pctsrf,pctsrf_new, + e t_seri,q_seri,u_seri,v_seri, + e julien, rmu0, co2_ppm, + e ok_veget, ocean, npas, nexca, ftsol, + $ soil_model,cdmmax, cdhmax, + $ ksta, ksta_ter, ok_kzmin, ftsoil, qsol, + $ paprs,pplay,radsol, fsnow,fqsurf,fevap,falbe,falblw, + $ fluxlat, +cIM cf. JLD e rain_fall, snow_fall, solsw, sollw, sollwdown, fder, + e rain_fall, snow_fall, fsolsw, fsollw, sollwdown, fder, + e rlon, rlat, cuphy, cvphy, frugs, + e debut, lafin, agesno,rugoro , + s d_t_vdf,d_q_vdf,d_u_vdf,d_v_vdf,d_ts, + s fluxt,fluxq,fluxu,fluxv,cdragh,cdragm, + s dsens, devap, + s ycoefh,yu1,yv1, t2m, q2m, u10m, v10m, + s fqcalving, ffonte, run_off_lic_0) +c +CXXX PB +CXXX Incrementation des flux +CXXX + + zxfluxt=0. + zxfluxq=0. + zxfluxu=0. + zxfluxv=0. + DO nsrf = 1, nbsrf + DO k = 1, klev + DO i = 1, klon + zxfluxt(i,k) = zxfluxt(i,k) + + $ fluxt(i,k,nsrf) * pctsrf( i, nsrf) + zxfluxq(i,k) = zxfluxq(i,k) + + $ fluxq(i,k,nsrf) * pctsrf( i, nsrf) + zxfluxu(i,k) = zxfluxu(i,k) + + $ fluxu(i,k,nsrf) * pctsrf( i, nsrf) + zxfluxv(i,k) = zxfluxv(i,k) + + $ fluxv(i,k,nsrf) * pctsrf( i, nsrf) + END DO + END DO + END DO + DO i = 1, klon + sens(i) = - zxfluxt(i,1) ! flux de chaleur sensible au sol +c evap(i) = - fluxq(i,1) ! flux d'evaporation au sol + evap(i) = - zxfluxq(i,1) ! flux d'evaporation au sol + fder(i) = dlw(i) + dsens(i) + devap(i) + ENDDO + + + DO k = 1, klev + DO i = 1, klon + t_seri(i,k) = t_seri(i,k) + d_t_vdf(i,k) + q_seri(i,k) = q_seri(i,k) + d_q_vdf(i,k) + u_seri(i,k) = u_seri(i,k) + d_u_vdf(i,k) + v_seri(i,k) = v_seri(i,k) + d_v_vdf(i,k) + ENDDO + ENDDO +c + IF (if_ebil.ge.2) THEN + ztit='after clmain' + CALL diagetpq(airephy,ztit,ip_ebil,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 + 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 Incrementer la temperature du sol +c + DO i = 1, klon + zxtsol(i) = 0.0 + zxfluxlat(i) = 0.0 +c + zt2m(i) = 0.0 + zq2m(i) = 0.0 + zu10m(i) = 0.0 + zv10m(i) = 0.0 +cIM cf JLD ?? + zxffonte(i) = 0.0 + zxfqcalving(i) = 0.0 +c + IF ( abs( pctsrf(i, is_ter) + pctsrf(i, is_lic) + + $ pctsrf(i, is_oce) + pctsrf(i, is_sic) - 1.) .GT. EPSFRA) + $ THEN + WRITE(*,*) 'physiq : pb sous surface au point ', i, + $ pctsrf(i, 1 : nbsrf) + ENDIF + ENDDO + DO nsrf = 1, nbsrf + DO i = 1, klon +c IF (pctsrf(i,nsrf) .GE. EPSFRA) THEN + ftsol(i,nsrf) = ftsol(i,nsrf) + d_ts(i,nsrf) +cIM cf. JLD + wfbils(i,nsrf) = ( fsolsw(i,nsrf) + fsollw(i,nsrf) + $ + fluxt(i,1,nsrf) + fluxlat(i,nsrf) ) * pctsrf(i,nsrf) + zxtsol(i) = zxtsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf) + zxfluxlat(i) = zxfluxlat(i) + fluxlat(i,nsrf)*pctsrf(i,nsrf) +cccIM + 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) +cIM cf JLD ?? + zxffonte(i) = zxffonte(i) + ffonte(i,nsrf)*pctsrf(i,nsrf) + zxfqcalving(i) = zxfqcalving(i) + + . fqcalving(i,nsrf)*pctsrf(i,nsrf) +c ENDIF + ENDDO + ENDDO + +c +c Si une sous-fraction n'existe pas, elle prend la temp. moyenne +c + DO nsrf = 1, nbsrf + DO i = 1, klon + IF (pctsrf(i,nsrf) .LT. epsfra) ftsol(i,nsrf) = zxtsol(i) +cccIM + IF (pctsrf(i,nsrf) .LT. epsfra) t2m(i,nsrf) = zt2m(i) + IF (pctsrf(i,nsrf) .LT. epsfra) q2m(i,nsrf) = zq2m(i) + IF (pctsrf(i,nsrf) .LT. epsfra) u10m(i,nsrf) = zu10m(i) + IF (pctsrf(i,nsrf) .LT. epsfra) v10m(i,nsrf) = zv10m(i) +cIM cf JLD ?? + IF (pctsrf(i,nsrf) .LT. epsfra) ffonte(i,nsrf) = zxffonte(i) + IF (pctsrf(i,nsrf) .LT. epsfra) + . fqcalving(i,nsrf) = zxfqcalving(i) + ENDDO + ENDDO +c +c +c Calculer la derive du flux infrarouge +c +cXXX DO nsrf = 1, nbsrf + DO i = 1, klon +cXXX IF (pctsrf(i,nsrf) .GE. EPSFRA) THEN + dlw(i) = - 4.0*RSIGMA*zxtsol(i)**3 +cXXX . *(ftsol(i,nsrf)-zxtsol(i)) +cXXX . *pctsrf(i,nsrf) +cXXX ENDIF +cXXX ENDDO + ENDDO +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 + 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, zxfluxq(1,1), 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) + 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: + if (nqmax .GE. 4) then + ntra = nbtr + else + ntra = 1 + endif +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, + . dtime,paprs,pplay,t_seri,q_seri, + . u_seri,v_seri,tr_seri,nbtr, + . 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, + . Ma,cape,tvp,iflagctrl, + . pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,qcondc,wd) +cIM cf. FH + clwcon0=qcondc + + ELSE ! ok_cvl + + CALL conema3 (dtime, + . paprs,pplay,t_seri,q_seri, + . u_seri,v_seri,tr_seri,nbtr, + . 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 + + 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 + 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 + +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 + ema_pct(i) = paprs(i,itop_con(i)) + ENDDO + DO i = 1, klon + ema_cbmf(i) = ema_workcbmf(i) + ENDDO + 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) + + DO k = 1, klev + DO i = 1, klon + t_seri(i,k) = t_seri(i,k) + d_t_con(i,k) + q_seri(i,k) = q_seri(i,k) + d_q_con(i,k) + u_seri(i,k) = u_seri(i,k) + d_u_con(i,k) + v_seri(i,k) = v_seri(i,k) + d_v_con(i,k) + ENDDO + ENDDO +c + IF (if_ebil.ge.2) THEN + ztit='after convect' + CALL diagetpq(airephy,ztit,ip_ebil,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 + 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 + IF (nqmax.GT.2) THEN !--melange convectif de traceurs +c + IF (iflag_con .NE. 2 .AND. debut) THEN + WRITE(lunout,*)'Pour l instant, seul conflx fonctionne ', + $ 'avec traceurs', iflag_con + WRITE(lunout,*)' Mettre iflag_con', + $ ' = 2 dans run.def et repasser' +c CALL abort + ENDIF +c + ENDIF !--nqmax.GT.2 +c +c Appeler l'ajustement sec +c + CALL ajsec(paprs, pplay, t_seri, q_seri, d_t_ajs, d_q_ajs) + DO k = 1, klev + DO i = 1, klon + t_seri(i,k) = t_seri(i,k) + d_t_ajs(i,k) + q_seri(i,k) = q_seri(i,k) + d_q_ajs(i,k) + ENDDO + ENDDO +c + IF (if_ebil.ge.2) THEN + ztit='after dry_adjust' + CALL diagetpq(airephy,ztit,ip_ebil,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 + endif + +c ratqs stables +c ------------- + do k=1,klev +cIM RAJOUT boucle do=i + do i=1, klon +cIM ratqss(:,k)=ratqsbas+(ratqshaut-ratqsbas)* +cIM s min((paprs(:,1)-pplay(:,k))/(paprs(:,1)-30000.),1.) + ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)* + s min((paprs(i,1)-pplay(i,k))/(paprs(i,1)-30000.),1.) +cIM print*,' IMratqs STABLE i, k',i,k,ratqss(i,k) + enddo + enddo + + +c ratqs final +c ----------- + if (iflag_cldcon.eq.1 .or.iflag_cldcon.eq.2) then +c les ratqs sont une conbinaison de ratqss et ratqsc +c ratqs final +c 1e4 (en gros 3 heures), en dur pour le moment, est le temps de +c relaxation des ratqs +c facttemps=exp(-pdtphys/1.e4) + facteur=exp(-pdtphys*facttemps) + ratqs(:,:)=max(ratqs(:,:)*facteur,ratqss(:,:)) + ratqs(:,:)=max(ratqs(:,:),ratqsc(:,:)) +c print*,'calcul des ratqs fini' + else +c 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. + DO k = 1, klev + DO i = 1, klon + t_seri(i,k) = t_seri(i,k) + d_t_lsc(i,k) + q_seri(i,k) = q_seri(i,k) + d_q_lsc(i,k) + ql_seri(i,k) = ql_seri(i,k) + d_ql_lsc(i,k) + 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 +c + IF (if_ebil.ge.2) THEN + ztit='after fisrt' + CALL diagetpq(airephy,ztit,ip_ebil,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 + 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 +c +c------------------------------------------------------------------- +c PRESCRIPTION DES NUAGES POUR LE RAYONNEMENT +c------------------------------------------------------------------- + +c 1. NUAGES CONVECTIFS +c + IF (iflag_cldcon.eq.-1) THEN ! seulement pour Tiedtke + +c Nuages diagnostiques pour Tiedtke + CALL diagcld1(paprs,pplay, + . rain_con,snow_con,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.eq.3) THEN +c On prend pour les nuages convectifs le max du calcul de la +c convection et du calcul du pas de temps précédent diminué d'un facteur +c facttemps +c facttemps=pdtphys/1.e4 + 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 + +cIM calcul nuages par le simulateur ISCCP + IF (ok_isccp) THEN +cIM calcul tau. emi nuages convectifs + convfra(:,:)=rnebcon(:,:) + convliq(:,:)=rnebcon(:,:)*clwcon(:,:) + 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 sulfate, sulfate_pi, + e bl95_b0, bl95_b1, + s cldtaupi, re, fl) +c +cIM calcul tau. emi nuages startiformes + 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 sulfate, sulfate_pi, + e bl95_b0, bl95_b1, + s cldtaupi, re, fl) +c + cldtot(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.) + +cIM inversion des niveaux de pression ==> de haut en bas + 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 open(99,file='tautab.bin',access='sequential', +c $ form='unformatted',status='old') +c read(99) tautab + +cIM210503 + IF (debut) THEN + open(99,file='tautab.formatted', FORM='FORMATTED') + read(99,'(f30.20)') tautab + close(99) +c + open(99,file='invtau.formatted',form='FORMATTED') + read(99,'(i10)') invtau + close(99) +c +cIM: calcul coordonnees regions pour statistiques distribution +cIM: nuages en ftion du regime dynamique pour regions oceaniques + IF (ok_regdyn) THEN !histREGDYN + 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 + ENDIF !ok_regdyn + +cIM somme de toutes les nhistoW BEG + 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 +cIM somme de toutes les nhistoW END + ENDIF +cIM: initialisation de seed + DO i=1, klon + seed(i)=i+100 + ENDDO + +cIM: pas de debug, debugcol + debug=0 + debugcol=0 +cIM260503 +c o500 ==> distribution nuage ftion du regime dynamique a 500 hPa + 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 + + CALL ISCCP_CLOUD_TYPES( + & debug, + & debugcol, + & klon, + & sunlit, + & klev, + & ncol, + & seed, + & pfull, + & phalf, + & qv, cc, conv, dtau_sH2B, dtau_cH2B, + & top_height, + & overlap, + & tautab, + & invtau, + & ztsol, + & emsfc_lw, + & at, dem_sH2B, dem_cH2B, + & fq_isccp, + & totalcldarea, + & meanptop, + & meantaucld, + & boxtau, + & boxptop) + + +c passage de la grille (klon,7,7) a (iim,jjmp1,7,7) + DO l=1, lmaxm1 + DO k=1, kmaxm1 + DO i=1, iim + fq4d(i,1,k,l)=fq_isccp(1,k,l) + ENDDO + DO j=2, jjm + DO i=1, iim + ig=i+1+(j-2)*iim + fq4d(i,j,k,l)=fq_isccp(ig,k,l) + ENDDO + ENDDO + DO i=1, iim + fq4d(i,jjmp1,k,l)=fq_isccp(klon,k,l) + ENDDO + ENDDO + ENDDO +c + DO l=1, lmaxm1 + DO k=1, kmaxm1 + DO j=1, jjmp1 + DO i=1, iim + ni=(i-1)*lmaxm1+l + nj=(j-1)*kmaxm1+k + fq3d(ni,nj)=fq4d(i,j,k,l) + ENDDO + ENDDO + ENDDO + ENDDO + +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 + ENDIF !ok_isccp + +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 +c + IF (if_ebil.ge.2) THEN + ztit="after diagcld" + CALL diagetpq(airephy,ztit,ip_ebil,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 +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 + ! Get sulfate aerosol distribution + CALL readsulfate(rjourvrai, debut, sulfate) + CALL readsulfate_preind(rjourvrai, debut, sulfate_pi) + + ! Calculate aerosol optical properties (Olivier Boucher) + CALL aeropt(pplay, paprs, t_seri, sulfate, rhcl, + . tau_ae, piz_ae, cg_ae, aerindex) + ENDIF + +#ifdef INCA + calday = FLOAT(julien) + gmtime + +#ifdef INCA_AER + call AEROSOL_METEO_CALC(calday,pdtphys,pplay,paprs,t,pmflxr,pmflxs, + & prfl,psfl,pctsrf,airephy,xjour,rlat,rlon) +#endif + +#ifdef INCAINFO + WRITE(lunout,*)'Appel CHEMHOOK_BEGIN ...' +#endif + CALL chemhook_begin (calday, + $ pctsrf(1,3), + $ rlat, + $ rlon, + $ airephy, + $ paprs, + $ pplay, + $ ycoefh, + $ pphi, + $ t_seri, + $ u, + $ v, + $ wo, + $ q_seri, + $ zxtsol, + $ zxsnow, + $ solsw, + $ albsol, + $ rain_fall, + $ snow_fall, + $ itop_con, + $ ibas_con, + $ cldfra, + $ iim, + $ jjm, + $ tr_seri) +#ifdef INCAINFO + WRITE(lunout,*)'OK.' +#endif +#endif +c +c Calculer les parametres optiques des nuages et quelques +c parametres pour diagnostiques: +c + 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 sulfate, sulfate_pi, + e bl95_b0, bl95_b1, + s cldtaupi, re, fl) + else + CALL nuage (paprs, pplay, + . t_seri, cldliq, cldfra, cldtau, cldemi, + . cldh, cldl, cldm, cldt, cldq, + e ok_aie, + e sulfate, sulfate_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 + albsol(i) = falbe(i,is_oce) * pctsrf(i,is_oce) + . + falbe(i,is_lic) * pctsrf(i,is_lic) + . + falbe(i,is_ter) * pctsrf(i,is_ter) + . + falbe(i,is_sic) * pctsrf(i,is_sic) + albsollw(i) = falblw(i,is_oce) * pctsrf(i,is_oce) + . + falblw(i,is_lic) * pctsrf(i,is_lic) + . + falblw(i,is_ter) * pctsrf(i,is_ter) + . + falblw(i,is_sic) * pctsrf(i,is_sic) + ENDDO + CALL radlwsw ! nouveau rayonnement (compatible Arpege-IFS) + e (dist, rmu0, fract, + e paprs, pplay,zxtsol,albsol, albsollw, t_seri,q_seri, + e wo, + 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, ! new for aerosol radiative effects + e tau_ae, piz_ae, cg_ae, ! ="= + s topswad, solswad, ! ="= + e cldtaupi, ! ="= + s topswai, solswai) ! ="= + itaprad = 0 + ENDIF + itaprad = itaprad + 1 +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/86400. + ENDDO + ENDDO +c + IF (if_ebil.ge.2) THEN + ztit='after rad' + CALL diagetpq(airephy,ztit,ip_ebil,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 + 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 + DO i = 1, klon + zxqsurf(i) = 0.0 + zxsnow(i) = 0.0 + ENDDO + DO nsrf = 1, nbsrf + DO i = 1, klon + zxqsurf(i) = zxqsurf(i) + fqsurf(i,nsrf)*pctsrf(i,nsrf) + zxsnow(i) = zxsnow(i) + fsnow(i,nsrf)*pctsrf(i,nsrf) + ENDDO + ENDDO +c +c Si une sous-fraction n'existe pas, elle prend la valeur moyenne +c +cXXX DO nsrf = 1, nbsrf +cXXX DO i = 1, klon +cXXX IF (pctsrf(i,nsrf).LT.epsfra) THEN +cXXX fqsurf(i,nsrf) = zxqsurf(i) +cXXX fsnow(i,nsrf) = zxsnow(i) +cXXX ENDIF +cXXX ENDDO +cXXX ENDDO +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 + 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, zustr, zvstr, + s d_t_oro, d_u_oro, d_v_oro) +c +c ajout des tendances + DO k = 1, klev + DO i = 1, klon + t_seri(i,k) = t_seri(i,k) + d_t_oro(i,k) + u_seri(i,k) = u_seri(i,k) + d_u_oro(i,k) + v_seri(i,k) = v_seri(i,k) + d_v_oro(i,k) + ENDDO + ENDDO +c + ENDIF ! fin de test sur ok_orodr +c + 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 + 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, zustr, zvstr, + s d_t_lif, d_u_lif, d_v_lif) +c +c ajout des tendances + DO k = 1, klev + DO i = 1, klon + t_seri(i,k) = t_seri(i,k) + d_t_lif(i,k) + u_seri(i,k) = u_seri(i,k) + d_u_lif(i,k) + v_seri(i,k) = v_seri(i,k) + d_v_lif(i,k) + ENDDO + ENDDO +c + ENDIF ! fin de test sur ok_orolf +c + IF (if_ebil.ge.2) THEN + ztit='after orography' + CALL diagetpq(airephy,ztit,ip_ebil,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 +cAA +cAA Installation de l'interface online-offline pour traceurs +cAA +c==================================================================== +c Calcul des tendances traceurs +c==================================================================== +C Pascale : il faut quand meme apeller phytrac car il gere les sorties +cKE43 des traceurs => il faut donc mettre des flags a .false. + IF (iflag_con.GE.3) THEN +c on ajoute les tendances calculees par KE43 +cXXX OM on onhibe la convection sur les traceurs + DO iq=1, nqmax-2 ! Sandrine a -3 ??? +cXXX OM on inhibe la convection sur les traceur +cXXX DO k = 1, nlev +cXXX DO i = 1, klon +cXXX tr_seri(i,k,iq) = tr_seri(i,k,iq) + d_tr(i,k,iq) +cXXX ENDDO +cXXX ENDDO + WRITE(iqn,'(i2.2)') iq + CALL minmaxqfi(tr_seri(1,1,iq),0.,1.e33,'couche lim iq='//iqn) + ENDDO +CMAF modif pour garder info du nombre de traceurs auxquels +C la physique s'applique + ELSE +CMAF modif pour garder info du nombre de traceurs auxquels +C la physique s'applique +C + call phytrac (rnpb, + I itap, julien, gmtime, + I debut,lafin, + I nqmax-2, + I nlon,nlev,dtime, + I u,v,t,paprs,pplay, + I pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, + I ycoefh,yu1,yv1,ftsol,pctsrf,rlat, + I frac_impa, frac_nucl, + I rlon,presnivs,pphis,pphi, + I albsol, + I qx(1,1,1), rhcl, + I cldfra, rneb, diafra, cldliq, itop_con, + I ibas_con, + I pmflxr,pmflxs,prfl,psfl, +#ifdef INCA_CH4 + I flxmass_w, +#endif + O tr_seri) + ENDIF + + IF (offline) THEN + + call phystokenc ( + I nlon,nlev,pdtphys,rlon,rlat, + I t,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, + I ycoefh,yu1,yv1,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 +c Accumuler les variables a stocker dans les fichiers histoire: +c +c +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) + 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 + IF (if_ebil.ge.1) THEN + ztit='after physic' + CALL diagetpq(airephy,ztit,ip_ebil,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 + 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======================================================================= + +c Interpollation sur quelques niveaux de pression +c ----------------------------------------------- +c +c on moyenne mensuellement les champs 3D et on les interpole sur les niveaux STD +c if(itap.EQ.1.OR.itap.EQ.13.OR.itap.EQ.25.OR.itap.EQ.37) THEN +c if(MOD(itap,12).EQ.1) THEN +cIM 120304 END + DO k=1, nlevSTD + call plevel(klon,klev,.true.,pplay,rlevSTD(k), + . t_seri,tlevSTD(:,k)) + call plevel(klon,klev,.false.,pplay,rlevSTD(k), + . u_seri,ulevSTD(:,k)) + call plevel(klon,klev,.false.,pplay,rlevSTD(k), + . v_seri,vlevSTD(:,k)) + call plevel(klon,klev,.false.,pplay,rlevSTD(k), + . zphi,philevSTD(:,k)) + call plevel(klon,klev,.false.,pplay,rlevSTD(k), + . qx(:,:,ivap),qlevSTD(:,k)) + call plevel(klon,klev,.false.,pplay,rlevSTD(k), + . zx_rh,rhlevSTD(:,k)) + ENDDO !nlevSTD +c ENSEMBLES BEG + DO k=1, nlevENS +cIM 170304 + tlev(:,k)=tlevSTD(:,indENS(k)) + ulev(:,k)=ulevSTD(:,indENS(k)) + vlev(:,k)=vlevSTD(:,indENS(k)) + philev(:,k)=philevSTD(:,indENS(k)) + qlev(:,k)=qlevSTD(:,indENS(k)) + rhlev(:,k)=rhlevSTD(:,indENS(k)) +c + call plevel(klon,klevp1,.true.,paprs,rlevENS(k), + . omega,wlev(:,k)) +c + ENDDO !k=1, nlevENS +cIM 100304 BEG +cIM interpolation a chaque pas de temps du SWup(clr) et SWdn(clr) a 200 hPa + 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 +cIM 100304 END +c +c ENSEMBLES END +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 sorties bilans energie cinetique et potentielle MJO + 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 + IF (MOD(itap-1,lmt_pas) .EQ. 0) THEN +cIM PRINT *,' PHYS cond julien ',julien +c CALL ozonecm( FLOAT(julien), rlat, paprs, wo) + 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 +c + ENDIF +c surface terre + IF (debut) THEN + DO i=1, klon + IF(pctsrf_new(i,is_ter).GT.0.) THEN + paire_ter(i)=airephy(i)*pctsrf_new(i,is_ter) + ENDIF + ENDDO + ENDIF +cIM 050204 END + +c============================================================= +c +c Convertir les incrementations en tendances +c + 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 (nqmax.GE.3) THEN + DO iq = 3, nqmax + 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 +c Sauvegarder les valeurs de t et q a la fin de la physique: +c + DO k = 1, klev + DO i = 1, klon + t_ancien(i,k) = t_seri(i,k) + q_ancien(i,k) = q_seri(i,k) + ENDDO + ENDDO +c +c 22.03.04 BEG +c============================================================= +c Ecriture des sorties +c============================================================= +#ifdef CPP_IOIPSL + +#ifdef histhf +#include "write_histhf.h" +#endif + +#ifdef histday +#include "write_histday.h" +#endif + +#ifdef histmth +#include "write_histmth.h" +#endif + +#ifdef histins +#include "write_histins.h" +#endif + +#ifdef histREGDYN +#include "write_histREGDYN.h" +#endif + +#ifdef histISCCP +#include "write_histISCCP.h" +#endif + +#ifdef histmthNMC +#include "write_histmthNMC.h" +#endif + +#endif + +#ifdef INCA +#ifdef INCAINFO + WRITE(lunout,*)'Appel CHEMHOOK_END ...' +#endif + CALL chemhook_end (calday, + $ dtime, + $ pplay, + $ t_seri, + $ tr_seri, + $ nbtr, + $ paprs, + $ q_seri, + $ anne_ini, + $ day_ini, + $ xjour) +#ifdef INCAINFO + WRITE(lunout,*)'OK.' +#endif +#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 +ccc IF (ok_oasis) CALL quitcpl + CALL phyredem ("restartphy.nc",dtime,radpas, + . rlat, rlon, pctsrf, ftsol, ftsoil, deltat, fqsurf, qsol, + . fsnow, falbe,falblw, fevap, rain_fall, snow_fall, + . solsw, sollwdown,dlw, + . radsol,frugs,agesno, + . zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro, + . t_ancien, q_ancien, rnebcon, ratqs, clwcon,run_off_lic_0) + ENDIF + + + 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/trunk/libf/phylmd/phystokenc.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/phystokenc.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/phystokenc.F (revision 524) @@ -0,0 +1,344 @@ +! +! $Header$ +! +c +c + SUBROUTINE phystokenc ( + I nlon,nlev,pdtphys,rlon,rlat, + I pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, + I pcoefh,yu1,yv1,ftsol,pctsrf, + I pfrac_impa,pfrac_nucl, + I pphis,paire,dtime,itap) + USE ioipsl + USE histcom + + IMPLICIT none + +c====================================================================== +c Auteur(s) FH +c Objet: Moniteur general des tendances traceurs +c + +c====================================================================== +#include "dimensions.h" +#include "dimphy.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,ndex(1) + +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) +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 pcoefh(klon,klev) ! coeff melange CL + REAL yv1(klon) + REAL yu1(klon),pphis(klon),paire(klon) +c +c Lessivage: +c ---------- +c + REAL pfrac_impa(klon,klev) + REAL pfrac_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 mfu(klon,klev) ! flux de masse dans le panache montant + REAL mfd(klon,klev) ! flux de masse dans le panache descendant + REAL en_u(klon,klev) ! flux entraine dans le panache montant + REAL de_u(klon,klev) ! flux detraine dans le panache montant + REAL en_d(klon,klev) ! flux entraine dans le panache descendant + REAL de_d(klon,klev) ! flux detraine dans le panache descendant + REAL coefh(klon,klev) ! flux detraine dans le panache descendant + REAL t(klon,klev) + REAL frac_impa(klon,klev) + REAL frac_nucl(klon,klev) + REAL rain(klon) + + REAL pyu1(klon),pyv1(klon) + REAL pftsol(klon,nbsrf),ppsrf(klon,nbsrf) + 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 + + save t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,dtcum + save iadvtr,irec + save frac_impa,frac_nucl,rain + save pyu1,pyv1,pftsol,ppsrf + + data iadvtr,irec/0,1/ +c +c Couche limite: +c====================================================================== + + print*,'iadvtr= ',iadvtr + print*,'istphy= ',istphy + print*,'istdyn= ',istdyn + + IF (iadvtr.eq.0) THEN + + CALL initphysto('phystoke', + . rlon,rlat,dtime, dtime*istphy,dtime*istphy,nqmx,physid) + + write(*,*) 'apres initphysto ds phystokenc' + + ndex(1) = 0 + i=itap + CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d) + CALL histwrite(physid,"phis",i,zx_tmp_2d,iim*(jjm+1),ndex) +c + i=itap + CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d) + CALL histwrite(physid,"aire",i,zx_tmp_2d,iim*(jjm+1),ndex) + + ENDIF +c + iadvtr=iadvtr+1 +c +c +c reinitialisation des champs cumules + 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 + frac_impa(i,k)=1. + frac_nucl(i,k)=1. + 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. + enddo + enddo + do i=1,klon + rain(i)=0. + 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 + frac_impa(i,k)=frac_impa(i,k)*pfrac_impa(i,k) + frac_nucl(i,k)=frac_nucl(i,k)*pfrac_nucl(i,k) + 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(i,k)*pdtphys + t(i,k)=t(i,k)+pt(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 +c + IF(mod(iadvtr,istphy).eq.0) THEN +c +c normalisation par le temps cumule + do k=1,klev + do i=1,klon +c frac_impa=frac_impa : c'est la fraction cumulee qu'on stoke +c frac_nucl=frac_nucl : c'est la fraction cumulee qu'on stoke + 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 + t(i,k)=t(i,k)/dtcum + enddo + enddo + do i=1,klon + rain(i)=rain(i)/dtcum + pyv1(i)=pyv1(i)/dtcum + pyu1(i)=pyu1(i)/dtcum + end do +c modif abderr 23 11 00 do k=1,nbsrf + do i=1,klon + do k=1,nbsrf + pftsol(i,k)=pftsol(i,k)/dtcum + ppsrf(i,k)=ppsrf(i,k)/dtcum + enddo + pftsol1(i) = pftsol(i,1) + pftsol2(i) = pftsol(i,2) + pftsol3(i) = pftsol(i,3) + pftsol4(i) = pftsol(i,4) + +c 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 +c enddo +c +c ecriture des champs +c + irec=irec+1 + +ccccc + print*,'AVANT ECRITURE' + CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t, zx_tmp_3d) + CALL histwrite(physid,"t",itap,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex) + print*,'APRES ECRITURE' + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfu, zx_tmp_3d) + CALL histwrite(physid,"mfu",itap,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex) + CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfd, zx_tmp_3d) + CALL histwrite(physid,"mfd",itap,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex) + CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_u, zx_tmp_3d) + CALL histwrite(physid,"en_u",itap,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex) + CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_u, zx_tmp_3d) + CALL histwrite(physid,"de_u",itap,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex) + CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_d, zx_tmp_3d) + CALL histwrite(physid,"en_d",itap,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex) + CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_d, zx_tmp_3d) + CALL histwrite(physid,"de_d",itap,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex) + CALL gr_fi_ecrit(klev,klon,iim,jjm+1, coefh, zx_tmp_3d) + CALL histwrite(physid,"coefh",itap,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex) +cccc + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_impa,zx_tmp_3d) + CALL histwrite(physid,"frac_impa",itap,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex) + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_nucl,zx_tmp_3d) + CALL histwrite(physid,"frac_nucl",itap,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex) + + CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyu1,zx_tmp_2d) + CALL histwrite(physid,"pyu1",itap,zx_tmp_2d,iim*(jjm+1),ndex) + + CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyv1,zx_tmp_2d) + CALL histwrite(physid,"pyv1",itap,zx_tmp_2d,iim*(jjm+1),ndex) + + CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol1, zx_tmp_2d) + CALL histwrite(physid,"ftsol1",itap,zx_tmp_2d, + . iim*(jjm+1),ndex) + CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol2, zx_tmp_2d) + CALL histwrite(physid,"ftsol2",itap,zx_tmp_2d, + . iim*(jjm+1),ndex) + CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol3, zx_tmp_2d) + CALL histwrite(physid,"ftsol3",itap,zx_tmp_2d, + . iim*(jjm+1),ndex) + +c + CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol4, zx_tmp_2d) + CALL histwrite(physid,"ftsol4",itap,zx_tmp_2d, + . iim*(jjm+1),ndex) + + CALL gr_fi_ecrit(1,klon,iim,jjm+1, rain, zx_tmp_2d) + CALL histwrite(physid,"rain",itap,zx_tmp_2d, + . iim*(jjm+1),ndex) + + CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf1, zx_tmp_2d) + CALL histwrite(physid,"psrf1",itap,zx_tmp_2d, + . iim*(jjm+1),ndex) + CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf2, zx_tmp_2d) + CALL histwrite(physid,"psrf2",itap,zx_tmp_2d, + . iim*(jjm+1),ndex) + CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf3, zx_tmp_2d) + CALL histwrite(physid,"psrf3",itap,zx_tmp_2d, + . iim*(jjm+1),ndex) + CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf4, zx_tmp_2d) + CALL histwrite(physid,"psrf4",itap,zx_tmp_2d, + . iim*(jjm+1),ndex) + +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 + + + RETURN + END Index: /LMDZ4/trunk/libf/phylmd/phytrac.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/phytrac.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/phytrac.F (revision 524) @@ -0,0 +1,753 @@ +! +! $Header$ +! +c +c + SUBROUTINE phytrac (rnpb,nstep, + I julien,gmtime, + I debutphy,lafin, + I nqmax, + I nlon, + I nlev, + I pdtphys, + I u, + I v, + I t_seri, + I paprs, + I pplay, + I pmfu, + I pmfd, + I pen_u, + I pde_u, + I pen_d, + I pde_d, + I coefh, + I yu1, + I yv1, + I ftsol, + I pctsrf, + I xlat, + I frac_impa, + I frac_nucl, + I xlon, + I presnivs, + I pphis, + I pphi, + I albsol, + I sh, + I rh, + I cldfra, + I rneb, + I diafra, + I cldliq, + I itop_con, + I ibas_con, + I pmflxr, + I pmflxs, + I prfl, + I psfl, +#ifdef INCA_CH4 + I flxmass_w, +#endif + O tr_seri) + + USE ioipsl + +#ifdef INCA + USE sflx + USE chem_tracnm + USE species_names + USE chem_mods + USE pht_tables, ONLY : jrates + USE transport_controls, ONLY : conv_flg, pbl_flg + USE airplane_src, ONLY : ptrop + USE lightning, ONLY : prod_light +#ifdef INCA_AER + USE AEROSOL_MOD, only : ntr,trmx,trnx + USE AEROSOL_DIAG, only : cla,las,tausum,angst,aload,scon + . ,scavcoef_st,scavcoef_cv + USE AEROSOL_PROGNOS, ONLY : md +#endif +#endif + IMPLICIT none +c====================================================================== +c Auteur(s) FH +c Objet: Moniteur general des tendances traceurs +c +cAA Remarques en vrac: +cAA-------------------- +cAA 1/ le call phytrac se fait avec nqmax-2 donc nous avons bien +cAA les vrais traceurs (nbtr) dans phytrac (pas la vapeur ni eau liquide) +cAA 2/ Le choix du radon et du pb se fait juste avec un data +cAA (peu propre). Peut-etre pourrait-on prevoir dans l'avenir +cAA une variable "type de traceur" +c====================================================================== +#include "YOMCST.h" +#include "dimensions.h" +#include "dimphy.h" +#include "indicesol.h" +#include "temps.h" +#include "paramet.h" +#include "control.h" +#include "comgeomphy.h" +#include "advtrac.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 + integer nqmax ! nombre de traceurs auxquels on applique la physique + integer nstep ! appel physique + integer julien !jour julien + integer itop_con(nlon) + integer ibas_con(nlon) + real gmtime + real pdtphys ! pas d'integration pour la physique (seconde) + real t_seri(nlon,nlev) ! temperature + real tr_seri(nlon,nlev,nbtr) ! traceur + real u(klon,klev) + real v(klon,klev) + real sh(nlon,nlev) ! humidite specifique + real rh(nlon,nlev) ! humidite relative + real cldliq(nlon,nlev) ! eau liquide nuageuse + real cldfra(nlon,nlev) ! fraction nuageuse (tous les nuages) + real diafra(nlon,nlev) ! fraction nuageuse (convection ou stratus artificiels) + real rneb(nlon,nlev) ! fraction nuageuse (grande echelle) + real albsol(nlon) ! albedo surface + real paprs(nlon,nlev+1) ! pression pour chaque inter-couche (en Pa) + real ps(nlon) ! pression surface + real pplay(nlon,nlev) ! pression pour le mileu de chaque couche (en Pa) + real pphi(nlon,klev) ! geopotentiel + real pphis(klon) + REAL presnivs(klev) + logical debutphy ! le flag de l'initialisation de la physique + logical lafin ! le flag de la fin de la physique + + REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1) !--lessivage convection + REAL prfl(klon,klev+1), psfl(klon,klev+1) !--lessivage large-scale + +#ifdef INCA_CH4 + REAL flxmass_w(klon,klev) +#endif + +cAA Rem : nbtr : nombre de vrais traceurs est defini dans dimphy.h +c +c convection: +c ----------- +c + REAL pmfu(nlon,nlev) ! flux de masse dans le panache montant + REAL pmfd(nlon,nlev) ! flux de masse dans le panache descendant + REAL pen_u(nlon,nlev) ! flux entraine dans le panache montant + REAL pde_u(nlon,nlev) ! flux detraine dans le panache montant + REAL pen_d(nlon,nlev) ! flux entraine dans le panache descendant + REAL pde_d(nlon,nlev) ! flux detraine dans le panache descendant +c +c Couche limite: +c -------------- +c + REAL coefh(nlon,nlev) ! coeff melange CL + REAL yu1(nlon) ! vents au premier niveau + REAL yv1(nlon) ! vents au premier niveau + REAL xlat(nlon) ! latitudes pour chaque point + REAL xlon(nlon) ! longitudes pour chaque point + +c +c Lessivage: +c ---------- +c +c pour le ON-LINE +c + REAL frac_impa(nlon,nlev) ! fraction d'aerosols impactes + REAL frac_nucl(nlon,nlev) ! fraction d'aerosols nuclees +c +cAA +cAA Arguments necessaires pour les sources et puits de traceur: +cAA ---------------- +cAA + real ftsol(nlon,nbsrf) ! Temperature du sol (surf)(Kelvin) + real pctsrf(nlon,nbsrf) ! Pourcentage de sol f(nature du sol) +c abder + real pftsol1(nlon),pftsol2(nlon),pftsol3(nlon),pftsol4(nlon) + real ppsrf1(nlon),ppsrf2(nlon),ppsrf3(nlon),ppsrf4(nlon) +c fin +cAA ---------------------------- +cAA VARIABLES LOCALES TRACEURS +cAA ---------------------------- +cAA +cAA Sources et puits des traceurs: +cAA ------------------------------ +cAA +cAA Pour l'instant seuls les cas du rn et du pb ont ete envisages. + + REAL source(klon) ! a voir lorsque le flux est prescrit +cAA +cAA Pour la source de radon et son reservoir de sol +cAA ................................................ + + REAL trs(klon,nbtr) ! Conc. radon ds le sol + SAVE trs + + REAL masktr(klon,nbtr) ! Masque reservoir de sol traceur +c Masque de l'echange avec la surface +c (1 = reservoir) ou (possible => 1 ) + SAVE masktr + REAL fshtr(klon,nbtr) ! Flux surfacique dans le reservoir de sol + SAVE fshtr + REAL hsoltr(nbtr) ! Epaisseur equivalente du reservoir de sol + SAVE hsoltr + REAL tautr(nbtr) ! Constante de decroissance radioactive + SAVE tautr + REAL vdeptr(nbtr) ! Vitesse de depot sec dans la couche Brownienne + SAVE vdeptr + REAL scavtr(nbtr) ! Coefficient de lessivage + SAVE scavtr +cAA + CHARACTER*2 itn +C maf ioipsl + CHARACTER*2 str2 + INTEGER nhori, nvert + REAL zsto, zout, zjulian + INTEGER nid_tra + SAVE nid_tra +#ifdef INCA_AER + INTEGER nid_tra2,nid_tra3 + SAVE nid_tra2,nid_tra3 +#endif +c REAL x(klon,klev,nbtr+2) ! traceurs + INTEGER ndex(1) + INTEGER ndex2d(iim*(jjm+1)),ndex3d(iim*(jjm+1)*klev) + REAL zx_tmp_2d(iim,jjm+1), zx_tmp_3d(iim,jjm+1,klev) + REAL zx_lon(iim,jjm+1), zx_lat(iim,jjm+1) +c + integer itau_w ! pas de temps ecriture = nstep + itau_phy +c + +C +C Variables liees a l'ecriture de la bande histoire : phytrac.nc +c + INTEGER ecrit_tra + SAVE ecrit_tra + logical ok_sync + parameter (ok_sync = .true.) +C +C nature du traceur +c + logical aerosol(nbtr) ! Nature du traceur +c ! aerosol(it) = true => aerosol +c ! aerosol(it) = false => gaz +c ! nat_trac(it) = 1. aerosol + logical clsol(nbtr) ! clsol(it) = true => CL sol calculee + logical radio(nbtr) ! radio(it)=true => decroisssance radioactive + save aerosol,clsol,radio +C +c====================================================================== +c +c Declaration des procedures appelees +c +c--modif convection tiedtke + INTEGER i, k, it + INTEGER iq, iiq + REAL delp(klon,klev) +c--end modif +c +c Variables liees a l'ecriture de la bande histoire physique +c +c Variables locales pour effectuer les appels en serie +c---------------------------------------------------- +c + REAL d_tr(klon,klev), d_trs(klon) ! tendances de traceurs + REAL d_tr_cl(klon,klev) ! tendance de traceurs couche limite + REAL d_tr_cv(klon,klev) ! tendance de traceurs convection + REAL d_tr_dec(klon,klev,nbtr) ! la tendance de la decroissance +c ! radioactive du rn - > pb + REAL d_tr_lessi_impa(klon,klev,nbtr) ! la tendance du lessivage +c ! par impaction + REAL d_tr_lessi_nucl(klon,klev,nbtr) ! la tendance du lessivage +c ! par nucleation + REAL fluxrn(klon,klev) + REAL fluxpb(klon,klev) + REAL pbimpa(klon,klev) + REAL pbnucl(klon,klev) + REAL rn(klon,klev) + REAL pb(klon,klev) + REAL flestottr(klon,klev,nbtr) ! flux de lessivage +c ! dans chaque couche + +C + character*20 modname + character*80 abort_message +c +c Controles +c------------- + logical first,couchelimite,convection,lessivage,sorties, + s rnpb,inirnpb + save first,couchelimite,convection,lessivage,sorties, + s inirnpb + data first,couchelimite,convection,lessivage,sorties + s /.true.,.true.,.false.,.true.,.true./ + +#ifdef INCA + INTEGER :: ncsec +#ifdef INCA_CH4 +#ifdef INCA_AER + INTEGER :: prt_flag_ts(51)=(/1,1,1 +#else + INTEGER :: prt_flag_ts(43)=(/1,1,1 +#endif +#else +#ifdef INCA_AER + INTEGER :: prt_flag_ts(11)=(/1,1,1 +#endif +#endif + +#ifdef INCA_CH4 + . ,1,0,1,1,0,1,0, + . 0,0,0,0,0,0,0,1,0,0, + . 0,1,1,1,1,0,1,1,1,0, + . 1,1,1,1,1,1,1,1,1,1, + . 1,0,0 +#endif +#ifdef INCA_AER + . ,1,1,1,1,1,1,1,1 +#endif + . /) + + + REAL, PARAMETER :: dry_mass = 28.966 + REAL, POINTER :: hbuf(:) + REAL, ALLOCATABLE :: obuf(:) + REAL :: calday + REAL :: pdel(klon,klev) + REAL :: dummy(klon,klev) = 0. +#endif +#ifdef INCA_AER + integer la +#endif +c +c====================================================================== + modname='phytrac' + + ps(:)=paprs(:,1) + + if (debutphy) then + + ecrit_tra = NINT(86400./pdtphys *ecritphy) + print*,'dans phytrac ',pdtphys,ecritphy,ecrit_tra + + if(nbtr.lt.nqmax) then +c print*,'NQMAX=',nqmax +c print*,'NBTR=',nbtr + abort_message='See above' + call abort_gcm(modname,abort_message,1) + endif + + inirnpb=rnpb + PRINT*, 'La frequence de sortie traceurs est ', ecrit_tra +C +c============================================================= +c Initialisation des sorties +c============================================================= + +#ifdef CPP_IOIPSL +#include "ini_histrac.h" +#endif + +c====================================================================== +c Initialisation de certaines variables pour le Rn et le Pb +c====================================================================== + +c Initialisation du traceur dans le sol (couche limite radonique) +c +c print*,'valeur de debut dans phytrac :',debutphy + trs(:,:) = 0. + + open (99,file='starttrac',status='old', + . err=999,form='formatted') + read(99,*) (trs(i,1),i=1,klon) +999 close(99) +c print*, 'apres starttrac' + +c Initialisation de la fraction d'aerosols lessivee +c + d_tr_lessi_impa(:,:,:) = 0. + d_tr_lessi_nucl(:,:,:) = 0. +c +c Initialisation de la nature des traceurs +c + DO it = 1, nqmax + aerosol(it) = .FALSE. ! Tous les traceurs sont des gaz par defaut + radio(it) = .FALSE. ! Par defaut pas de passage par radiornpb + clsol(it) = .FALSE. ! Par defaut couche limite avec flux prescrit + ENDDO +c + ENDIF ! fin debutphy +c Initialisation du traceur dans le sol (couche limite radonique) + if(inirnpb) THEN +c + radio(1)= .true. + radio(2)= .true. + clsol(1)= .true. + clsol(2)= .true. + aerosol(2) = .TRUE. ! le Pb est un aerosol +c + call initrrnpb (ftsol,pctsrf,masktr,fshtr,hsoltr,tautr + . ,vdeptr,scavtr) + inirnpb=.false. + endif +#ifdef INCA +!====================================================================== +! Chimie +!====================================================================== + + calday = FLOAT(julien) + gmtime + ncsec = NINT (86400.*gmtime) + + DO k = 1, nlev + pdel(:,k) = paprs(:,k) - paprs (:,k+1) + END DO + +#ifdef INCAINFO + PRINT *, 'CHEMMAIN @ ', calday, ' ... ' + DO it = 1, nbtr + PRINT *, solsym(it), MINVAL(tr_seri(:,:,it)), + $ MAXVAL(tr_seri(:,:,it)) + END DO +#endif + + +#ifdef INCA_AER + CALL aerosolmain (tr_seri, + $ pdtphys, + $ pplay, + $ prfl, + $ pmflxr, + $ psfl, + $ pmflxs, + $ pmfu, + $ itop_con, + $ ibas_con, + $ pphi, + $ airephy, + $ nstep) +#endif + + CALL chemmain (tr_seri, !mmr + $ nas, !nas + $ nstep, !nstep + $ calday, !calday + $ julien, !ncdate + $ ncsec, !ncsec + $ 1, !lat + $ pdtphys, !delt + $ paprs(1,1), !ps + $ pplay, !pmid + $ pdel, !pdel + $ pctsrf(1,3),!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 + $ .false., !wrhstts + $ hbuf, !hbuf + $ obuf, !obuf + $ iip1, !nx + $ jjp1) !ny +#ifdef INCAINFO + PRINT *, 'OK.' + DO it = 1, nbtr + PRINT *, solsym(it), MINVAL(tr_seri(:,:,it)), + $ MAXVAL(tr_seri(:,:,it)) + END DO +#endif +#else + +c Abder + if(nqmax.gt.2) aerosol(3)=.true. + + do i=1,nlon + pftsol1(i) = ftsol(i,1) + pftsol2(i) = ftsol(i,2) + pftsol3(i) = ftsol(i,3) + pftsol4(i) = ftsol(i,4) + + ppsrf1(i) = pctsrf(i,1) + ppsrf2(i) = pctsrf(i,2) + ppsrf3(i) = pctsrf(i,3) + ppsrf4(i) = pctsrf(i,4) + + enddo +c Abder +#endif +c====================================================================== +c Calcul de l'effet de la convection +c====================================================================== +c print*,'Avant convection' + do it=1,nqmax + WRITE(itn,'(i2)') it +c call diagtracphy(tr_seri(:,:,it),paprs,'Avant conv'//itn) + enddo + + if (convection) then + +c print*,'Pas de temps dans phytrac : ',pdtphys + DO it=1, nqmax +#ifdef INCA + IF ( conv_flg(it) == 0 ) CYCLE +#endif + CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, + . pplay, paprs, tr_seri(1,1,it), d_tr_cv) + DO k = 1, nlev + DO i = 1, klon + tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cv(i,k) + ENDDO + ENDDO +c WRITE(itn,'(i1)') it +#ifdef INCA + CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'convection it = ' + . //solsym(it)) +#else + CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'convection it = '//itn) +#endif + ENDDO +c print*,'apres nflxtr' + + endif ! convection +c print*,'Apres convection' +c do it=1,nqmax +c WRITE(itn,'(i1)') it +c call diagtracphy(tr_seri(:,:,it),paprs,'Avant conv'//itn) +c enddo + +c====================================================================== +c Calcul de l'effet de la couche limite +c====================================================================== +c print *,'Avant couchelimite' +c do it=1,nqmax +c WRITE(itn,'(i1)') it +c call diagtracphy(tr_seri(:,:,it),paprs,'Avant CL '//itn) +c enddo + + if (couchelimite) then + + DO k = 1, nlev + DO i = 1, klon + delp(i,k) = paprs(i,k)-paprs(i,k+1) + ENDDO + ENDDO + +C maf modif pour tenir compte du cas rnpb + traceur + DO it=1, nqmax +#ifdef INCA + IF ( pbl_flg(it) == 0 ) CYCLE +#endif +c print *,'it',it,clsol(it) + if (clsol(it)) then ! couche limite avec quantite dans le sol calculee + CALL cltracrn(it, pdtphys, yu1, yv1, + e coefh,t_seri,ftsol,pctsrf, + e tr_seri(1,1,it),trs(1,it), + e paprs, pplay, delp, + e masktr(1,it),fshtr(1,it),hsoltr(it), + e tautr(it),vdeptr(it), + e xlat, + s d_tr_cl,d_trs) + DO k = 1, nlev + DO i = 1, klon + tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cl(i,k) + ENDDO + ENDDO +c +c Traceur ds sol +c + DO i = 1, klon + trs(i,it) = trs(i,it) + d_trs(i) + END DO +C +C maf provisoire suppression des prints +C WRITE(itn,'(i1)') it +C CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'cltracrn it='//itn) + else ! couche limite avec flux prescrit +#ifdef INCA + DO k = 1, klon + source(k) = eflux(k,it)-dflux(k,it) + END DO +#else + +Cmaf provisoire source / traceur a creer + DO i=1, klon + source(i) = 0.0 ! pas de source, pour l'instant + ENDDO +C +#endif + CALL cltrac(pdtphys, coefh,t_seri, + s tr_seri(1,1,it), source, + e paprs, pplay, delp, + s d_tr ) + DO k = 1, nlev + DO i = 1, klon + tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr(i,k) + ENDDO + ENDDO +Cmaf provisoire suppression des prints +Cmaf WRITE(itn,'(i1)') it +cmaf CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'cltracn it='//itn) + endif + ENDDO +c + endif ! couche limite + +c print*,'Apres couchelimite' +c do it=1,nqmax +c WRITE(itn,'(i1)') it +c call diagtracphy(tr_seri(:,:,it),paprs,'Avant CL '//itn) +c enddo + +c====================================================================== +c Calcul de l'effet du puits radioactif +c====================================================================== + +C MAF il faudrait faire une modification pour passer dans radiornpb +c si radio=true mais pour l'instant radiornpb propre au cas rnpb + if(rnpb) then + print *, 'decroissance radiactive activee' + call radiornpb (tr_seri,pdtphys,tautr,d_tr_dec) +C + DO it=1,nqmax + if(radio(it)) then + DO k = 1, nlev + DO i = 1, klon + tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_dec(i,k,it) + ENDDO + ENDDO + WRITE(itn,'(i1)') it + CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'puits rn it='//itn) + endif + ENDDO +c + endif ! rnpb decroissance radioactive +C +c====================================================================== +c Calcul de l'effet de la precipitation +c====================================================================== + +c print*,'LESSIVAGE =',lessivage + IF (lessivage) THEN + +c print*,'avant lessivage' + + d_tr_lessi_nucl(:,:,:) = 0. + d_tr_lessi_impa(:,:,:) = 0. + flestottr(:,:,:) = 0. +c +c tendance des aerosols nuclees et impactes +c + DO it = 1, nqmax + IF (aerosol(it)) THEN + DO k = 1, nlev + DO i = 1, klon + d_tr_lessi_nucl(i,k,it) = d_tr_lessi_nucl(i,k,it) + + s ( 1 - frac_nucl(i,k) )*tr_seri(i,k,it) + d_tr_lessi_impa(i,k,it) = d_tr_lessi_impa(i,k,it) + + s ( 1 - frac_impa(i,k) )*tr_seri(i,k,it) + ENDDO + ENDDO + ENDIF + ENDDO +c +c Mises a jour des traceurs + calcul des flux de lessivage +c Mise a jour due a l'impaction et a la nucleation +c +c call dump2d(iim,jjm-1,frac_impa(2:klon-1,10),'FRACIMPA') +c call dump2d(iim,jjm-1,frac_nucl(2:klon-1,10),'FRACNUCL') +c call dump2d(iim,jjm-1,tr_seri(2:klon-1,10,3),'TRACEUR3') + DO it = 1, nqmax +c print*,'IT=',it,aerosol(it) + IF (aerosol(it)) THEN +c print*,'IT=',it,' On lessive' + DO k = 1, nlev + DO i = 1, klon + tr_seri(i,k,it)=tr_seri(i,k,it) + s *frac_impa(i,k)*frac_nucl(i,k) + ENDDO + ENDDO + ENDIF + ENDDO +c call dump2d(iim,jjm-1,tr_seri(2:klon-1,10,3),'TRACEUR3B') +c +c Flux lessivage total +c + DO it = 1, nqmax + DO k = 1, nlev + DO i = 1, klon + flestottr(i,k,it) = flestottr(i,k,it) - + s ( d_tr_lessi_nucl(i,k,it) + + s d_tr_lessi_impa(i,k,it) ) * + s ( paprs(i,k)-paprs(i,k+1) ) / + s (RG * pdtphys) + ENDDO + ENDDO +c +Cmaf WRITE(itn,'(i1)') it +Cmaf CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'tr(lessi) it='//itn) + ENDDO +c +c print*,'apres lessivage' + ENDIF +Cc + DO k = 1, nlev + DO i = 1, klon + fluxrn(i,k) = flestottr(i,k,1) + fluxpb(i,k) = flestottr(i,k,2) + rn(i,k) = tr_seri(i,k,1) + pb(i,k) = tr_seri(i,k,2) + pbnucl(i,k)=d_tr_lessi_nucl(i,k,2) + pbimpa(i,k)=d_tr_lessi_impa(i,k,2) + ENDDO + ENDDO + +c============================================================= +c Ecriture des sorties +c============================================================= + +#ifdef CPP_IOIPSL +#include "write_histrac.h" +#endif + +c============================================================= + + if (lafin) then + print*, 'c est la fin de la physique' + open (99,file='restarttrac', form='formatted') + do i=1,klon + write(99,*) trs(i,1) + enddo + PRINT*, 'Ecriture du fichier restarttrac' + close(99) + else + print*, 'physique pas fini' + endif + + + RETURN + END Index: /LMDZ4/trunk/libf/phylmd/plevel.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/plevel.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/plevel.F (revision 524) @@ -0,0 +1,118 @@ +! +! $Header$ +! +c================================================================ +c================================================================ + SUBROUTINE plevel(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres) +c================================================================ +c================================================================ + + IMPLICIT none + +#include "dimensions.h" +#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 ------- + + INTEGER lt(klon), lb(klon) + REAL ptop, pbot, aist(klon), aisb(klon) + + save lt,lb,ptop,pbot,aist,aisb + + INTEGER i, k +c + +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, 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édéric 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 +c Qpres(i)=1e33 + Qpres(i)=1e+20 + endif + enddo + +c + RETURN + END Index: /LMDZ4/trunk/libf/phylmd/printflag.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/printflag.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/printflag.F (revision 524) @@ -0,0 +1,190 @@ +! +! $Header$ +! + SUBROUTINE printflag( tabcntr0, radpas, ok_ocean,ok_oasis, + , 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_ocean,ok_oasis,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.EQ. 3 ) THEN + PRINT *,' ***** Shema convection CCM + , ******' + 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 5, ok_ocean,ok_oasis + 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(1H*),' ok_journe= ',l3,3x,',ok_instan = ', + , l3,3x,',ok_region = ',l3,3x,5(1H*) ) + + 5 FORMAT(2x,5(1H*),' ok_ocean = ',l3,6x,' , ok_oasis = ', + , l3,14x,5(1H*) ) + + + 7 FORMAT(2x,5(1H*),15x,' ok_limitvrai = ',l3,16x,5(1h*) ) + + 8 FORMAT(2x,'***** radpas = ' , + , i4,6x,' *****') + + 10 FORMAT(2x,5(1H*),' Cycle_diurne = ',l3,4x,', Soil_model = ', + , l3,12x,6(1H*) ) + + + 11 FORMAT(2x,5(1H*),' new_oliq = ',l3,3x,', Ok_orodr = ', + , l3,3x,', Ok_orolf = ',l3,3x,5(1H*) ) + + + 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/trunk/libf/phylmd/raddim.160.98.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/raddim.160.98.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/raddim.160.98.h (revision 524) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=78,kflev=klev) ! 78*199 Index: /LMDZ4/trunk/libf/phylmd/raddim.192.143.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/raddim.192.143.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/raddim.192.143.h (revision 524) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=10,kflev=klev) Index: /LMDZ4/trunk/libf/phylmd/raddim.32.24.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/raddim.32.24.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/raddim.32.24.h (revision 524) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=klon,kflev=klev) Index: /LMDZ4/trunk/libf/phylmd/raddim.48.32.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/raddim.48.32.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/raddim.48.32.h (revision 524) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=149,kflev=klev) Index: /LMDZ4/trunk/libf/phylmd/raddim.72.46.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/raddim.72.46.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/raddim.72.46.h (revision 524) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=1621,kflev=klev) Index: /LMDZ4/trunk/libf/phylmd/raddim.96.72.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/raddim.96.72.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/raddim.96.72.h (revision 524) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=487,kflev=klev) Index: /LMDZ4/trunk/libf/phylmd/raddim.defaut.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/raddim.defaut.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/raddim.defaut.h (revision 524) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=klon,kflev=klev) Index: /LMDZ4/trunk/libf/phylmd/raddim.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/raddim.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/raddim.h (revision 524) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=klon,kflev=klev) Index: /LMDZ4/trunk/libf/phylmd/raddimlw.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/raddimlw.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/raddimlw.h (revision 524) @@ -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/trunk/libf/phylmd/radepsi.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/radepsi.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/radepsi.h (revision 524) @@ -0,0 +1,16 @@ +! +! $Header$ +! + REAL*8 ZEELOG, ZEPSC, ZEPSCO, ZEPSCQ, ZEPSCT, ZEPSCW + REAL*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*8 REPSCT + PARAMETER (REPSCT=1.0E-10) Index: /LMDZ4/trunk/libf/phylmd/radiornpb.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/radiornpb.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/radiornpb.F (revision 524) @@ -0,0 +1,53 @@ +! +! $Header$ +! + SUBROUTINE radiornpb(tr,dtime,tautr,d_tr) + IMPLICIT none +c====================================================================== +c Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94 +c Objet: Decroissance radioactive d'un traceur dans l'atmosphere +CG240694 : Pour un traceur, le radon +CG161294 : Plus un 2eme traceur, le 210Pb. Le radon decroit en plomb. +c====================================================================== +c Arguments: +c====================================================================== +#include "dimensions.h" +#include "dimphy.h" +c====================================================================== +C + INTEGER i , k , it + REAL tr(klon,klev,nbtr) , d_tr(klon,klev,nbtr) + REAL dtime + REAL tautr(nbtr) +C + WRITE(*,'(''PASSAGE radiornpb ... '',$)') +C Attention, pour un pas de temps beaucoup plus petit que la decroissance!!! + + DO it = 1,2 + 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 + DO k = 1,klev + DO i = 1,klon + d_tr(i,k,it) = 0. + END DO + END DO + END IF + END DO +C +CG161294 : Cas particulier radon 1 => plomb 2 +c + 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 +c + WRITE(*,*) ' radiornpb OK' +c + RETURN + END Index: /LMDZ4/trunk/libf/phylmd/radlwsw.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/radlwsw.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/radlwsw.F (revision 524) @@ -0,0 +1,6510 @@ +! +! $Header$ +! + SUBROUTINE radlwsw(dist, rmu0, fract, + . paprs, pplay,tsol,albedo, alblw, t,q,wo, + . cldfra, cldemi, cldtaupd, + . heat,heat0,cool,cool0,radsol,albpla, + . topsw,toplw,solsw,sollw, + . sollwdown, + . topsw0,toplw0,solsw0,sollw0, + . lwdn0, lwdn, lwup0, lwup, + . swdn0, swdn, swup0, swup, + . ok_ade, ok_aie, + . tau_ae, piz_ae, cg_ae, + . topswad, solswad, + . cldtaupi, topswai, solswai) +c + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19960719 +c Objet: interface entre le modele et les rayonnements +c Arguments: +c dist-----input-R- distance astronomique terre-soleil +c rmu0-----input-R- cosinus de l'angle zenithal +c fract----input-R- duree d'ensoleillement normalisee +c co2_ppm--input-R- concentration du gaz carbonique (en ppm) +c solaire--input-R- constante solaire (W/m**2) +c paprs----input-R- pression a inter-couche (Pa) +c pplay----input-R- pression au milieu de couche (Pa) +c tsol-----input-R- temperature du sol (en K) +c albedo---input-R- albedo du sol (entre 0 et 1) +c t--------input-R- temperature (K) +c q--------input-R- vapeur d'eau (en kg/kg) +c wo-------input-R- contenu en ozone (en cm.atm) +c cldfra---input-R- fraction nuageuse (entre 0 et 1) +c cldtaupd---input-R- epaisseur optique des nuages dans le visible (present-day value) +c cldemi---input-R- emissivite des nuages dans l'IR (entre 0 et 1) +c ok_ade---input-L- apply the Aerosol Direct Effect or not? +c ok_aie---input-L- apply the Aerosol Indirect Effect or not? +c tau_ae, piz_ae, cg_ae-input-R- aerosol optical properties (calculated in aeropt.F) +c cldtaupi-input-R- epaisseur optique des nuages dans le visible +c calculated for pre-industrial (pi) aerosol concentrations, i.e. with smaller +c droplet concentration, thus larger droplets, thus generally cdltaupi cldtaupd +c it is needed for the diagnostics of the aerosol indirect radiative forcing +c +c heat-----output-R- echauffement atmospherique (visible) (K/jour) +c cool-----output-R- refroidissement dans l'IR (K/jour) +c radsol---output-R- bilan radiatif net au sol (W/m**2) (+ vers le bas) +c albpla---output-R- albedo planetaire (entre 0 et 1) +c topsw----output-R- flux solaire net au sommet de l'atm. +c toplw----output-R- ray. IR montant au sommet de l'atmosphere +c solsw----output-R- flux solaire net a la surface +c sollw----output-R- ray. IR montant a la surface +c solswad---output-R- ray. solaire net absorbe a la surface (aerosol dir) +c topswad---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol dir) +c solswai---output-R- ray. solaire net absorbe a la surface (aerosol ind) +c topswai---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol ind) +c +c ATTENTION: swai and swad have to be interpreted in the following manner: +c --------- +c ok_ade=F & ok_aie=F -both are zero +c ok_ade=T & ok_aie=F -aerosol direct forcing is F_{AD} = topsw-topswad +c indirect is zero +c ok_ade=F & ok_aie=T -aerosol indirect forcing is F_{AI} = topsw-topswai +c direct is zero +c ok_ade=T & ok_aie=T -aerosol indirect forcing is F_{AI} = topsw-topswai +c aerosol direct forcing is F_{AD} = topswai-topswad +c + +c====================================================================== +#include "dimensions.h" +#include "dimphy.h" +#include "raddim.h" +#include "YOETHF.h" +c + real rmu0(klon), fract(klon), dist +cIM real co2_ppm +cIM real solaire +#include "clesphys.h" +c + real paprs(klon,klev+1), pplay(klon,klev) + real albedo(klon), alblw(klon), tsol(klon) + real t(klon,klev), q(klon,klev), wo(klon,klev) + real cldfra(klon,klev), cldemi(klon,klev), cldtaupd(klon,klev) + real heat(klon,klev), cool(klon,klev) + real heat0(klon,klev), cool0(klon,klev) + real radsol(klon), topsw(klon), toplw(klon) + real solsw(klon), sollw(klon), albpla(klon) + real topsw0(klon), toplw0(klon), solsw0(klon), sollw0(klon) + real sollwdown(klon) +cccIM + REAL*8 ZFSUP(KDLON,KFLEV+1) + REAL*8 ZFSDN(KDLON,KFLEV+1) + REAL*8 ZFSUP0(KDLON,KFLEV+1) + REAL*8 ZFSDN0(KDLON,KFLEV+1) +cIM +cIM +cIM real sollwdownclr(klon) !LWdnSFCclr +cIM real toplwdown(klon) !LWdnTOA +cIM real toplwdownclr(klon) !LWdnTOAclr + REAL*8 ZFLUP(KDLON,KFLEV+1) + REAL*8 ZFLDN(KDLON,KFLEV+1) + REAL*8 ZFLUP0(KDLON,KFLEV+1) + REAL*8 ZFLDN0(KDLON,KFLEV+1) +c + REAL*8 zx_alpha1, zx_alpha2 +c +#include "YOMCST.h" +c + INTEGER k, kk, i, j, iof, nb_gr + EXTERNAL lw, sw +c +cIM ctes ds clesphys.h REAL*8 RCO2, RCH4, RN2O, RCFC11, RCFC12 + REAL*8 PSCT +c + REAL*8 PALBD(kdlon,2), PALBP(kdlon,2) + REAL*8 PEMIS(kdlon), PDT0(kdlon), PVIEW(kdlon) + REAL*8 PPSOL(kdlon), PDP(kdlon,klev) + REAL*8 PTL(kdlon,kflev+1), PPMB(kdlon,kflev+1) + REAL*8 PTAVE(kdlon,kflev) + REAL*8 PWV(kdlon,kflev), PQS(kdlon,kflev), POZON(kdlon,kflev) + REAL*8 PAER(kdlon,kflev,5) + REAL*8 PCLDLD(kdlon,kflev) + REAL*8 PCLDLU(kdlon,kflev) + REAL*8 PCLDSW(kdlon,kflev) + REAL*8 PTAU(kdlon,2,kflev) + REAL*8 POMEGA(kdlon,2,kflev) + REAL*8 PCG(kdlon,2,kflev) +c + REAL*8 zfract(kdlon), zrmu0(kdlon), zdist +c + REAL*8 zheat(kdlon,kflev), zcool(kdlon,kflev) + REAL*8 zheat0(kdlon,kflev), zcool0(kdlon,kflev) + REAL*8 ztopsw(kdlon), ztoplw(kdlon) + REAL*8 zsolsw(kdlon), zsollw(kdlon), zalbpla(kdlon) +cIM BEG + REAL*8 zsollwdown(kdlon) +cIM REAL*8 zsollwdown(kdlon), zsollwdownclr(kdlon) +cIM REAL*8 ztoplwdown(kdlon), ztoplwdownclr(kdlon) +cIM END + REAL*8 ztopsw0(kdlon), ztoplw0(kdlon) + REAL*8 zsolsw0(kdlon), zsollw0(kdlon) + REAL*8 zznormcp +cIM 080304 REAL swdn(klon,2),swdn0(klon,2),swup(klon,2),swup0(klon,2) + REAL swdn(klon,kflev+1),swdn0(klon,kflev+1) + REAL swup(klon,kflev+1),swup0(klon,kflev+1) +cIM BEG + REAL lwdn(klon,kflev+1),lwdn0(klon,kflev+1) + REAL lwup(klon,kflev+1),lwup0(klon,kflev+1) +cIM END +c-OB +cjq the following quantities are needed for the aerosol radiative forcings + + real topswad(klon), solswad(klon) ! output: aerosol direct forcing at TOA and surface + real topswai(klon), solswai(klon) ! output: aerosol indirect forcing atTOA and surface + real tau_ae(klon,klev,2), piz_ae(klon,klev,2), cg_ae(klon,klev,2) ! aerosol optical properties (see aeropt.F) + real cldtaupi(klon,klev) ! cloud optical thickness for pre-industrial aerosol concentrations + ! (i.e., with a smaller droplet concentrationand thus larger droplet radii) + logical ok_ade, ok_aie ! switches whether to use aerosol direct (indirect) effects or not + real*8 tauae(kdlon,kflev,2) ! aer opt properties + real*8 pizae(kdlon,kflev,2) + real*8 cgae(kdlon,kflev,2) + REAL*8 PTAUA(kdlon,2,kflev) ! present-day value of cloud opt thickness (PTAU is pre-industrial value), local use + REAL*8 POMEGAA(kdlon,2,kflev) ! dito for single scatt albedo + REAL*8 ztopswad(kdlon), zsolswad(kdlon) ! Aerosol direct forcing at TOAand surface + REAL*8 ztopswai(kdlon), zsolswai(kdlon) ! dito, indirect +cjq-end + +c +c------------------------------------------- + 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 +c------------------------------------------- + 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 +c + zdist = dist +c +cIM anciennes valeurs +c RCO2 = co2_ppm * 1.0e-06 * 44.011/28.97 +c +cIM : on met RCO2, RCH4, RN2O, RCFC11 et RCFC12 dans clesphys.h /lecture ds conf_phys.F90 +c RCH4 = 1.65E-06* 16.043/28.97 +c RN2O = 306.E-09* 44.013/28.97 +c RCFC11 = 280.E-12* 137.3686/28.97 +c RCFC12 = 484.E-12* 120.9140/28.97 +cIM anciennes valeurs +c RCH4 = 1.72E-06* 16.043/28.97 +c RN2O = 310.E-09* 44.013/28.97 +c +c PRINT*,'IMradlwsw : solaire, co2= ', solaire, co2_ppm + PSCT = solaire/zdist/zdist +c + DO 99999 j = 1, nb_gr + iof = kdlon*(j-1) +c + DO i = 1, kdlon + zfract(i) = fract(iof+i) + zrmu0(i) = rmu0(iof+i) + PALBD(i,1) = albedo(iof+i) +! PALBD(i,2) = albedo(iof+i) + PALBD(i,2) = alblw(iof+i) + PALBP(i,1) = albedo(iof+i) +! PALBP(i,2) = albedo(iof+i) + PALBP(i,2) = alblw(iof+i) +cIM cf. JLD pour etre en accord avec ORCHIDEE il faut mettre PEMIS(i) = 0.96 + 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) +c wo: cm.atm (epaisseur en cm dans la situation standard) +c POZON: kg/kg + POZON(i,k) = MAX(wo(iof+i,k),1.0e-12)*RG/46.6968 + . /(paprs(iof+i,k)-paprs(iof+i,k+1)) + . *(paprs(iof+i,1)/101325.0) + 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 +c-OB +cjq Introduced for aerosol indirect forcings. +cjq The following values use the cloud optical thickness calculated from +cjq present-day aerosol concentrations whereas the quantities without the +cjq "A" at the end are for pre-industial (natural-only) aerosol concentrations +cjq + 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)) +cjq-end + ENDDO + ENDDO +c + DO k = 1, kflev+1 + DO i = 1, kdlon + PPMB(i,k) = paprs(iof+i,k)/100.0 + ENDDO + ENDDO +c + DO kk = 1, 5 + DO k = 1, kflev + DO i = 1, kdlon + PAER(i,k,kk) = 1.0E-15 + ENDDO + ENDDO + ENDDO +c-OB + DO k = 1, kflev + DO i = 1, kdlon + tauae(i,k,1)=tau_ae(iof+i,k,1) + pizae(i,k,1)=piz_ae(iof+i,k,1) + cgae(i,k,1) =cg_ae(iof+i,k,1) + tauae(i,k,2)=tau_ae(iof+i,k,2) + pizae(i,k,2)=piz_ae(iof+i,k,2) + cgae(i,k,2) =cg_ae(iof+i,k,2) + ENDDO + ENDDO +c +c====================================================================== +cIM ctes ds clesphys.h CALL LW(RCO2,RCH4,RN2O,RCFC11,RCFC12, + CALL LW( + . PPMB, PDP, + . PPSOL,PDT0,PEMIS, + . PTL, PTAVE, PWV, POZON, PAER, + . PCLDLD,PCLDLU, + . PVIEW, + . zcool, zcool0, + . ztoplw,zsollw,ztoplw0,zsollw0, + . zsollwdown, +cIM . zsollwdown,zsollwdownclr, +cIM . ztoplwdown,ztoplwdownclr) + . ZFLUP, ZFLDN, ZFLUP0,ZFLDN0) +cIM ctes ds clesphys.h CALL SW(PSCT, RCO2, zrmu0, zfract, + CALL SW(PSCT, zrmu0, zfract, + S PPMB, PDP, + S PPSOL, PALBD, PALBP, + S PTAVE, PWV, PQS, POZON, PAER, + S PCLDSW, PTAU, POMEGA, PCG, + S zheat, zheat0, + S zalbpla,ztopsw,zsolsw,ztopsw0,zsolsw0, + S ZFSUP,ZFSDN,ZFSUP0,ZFSDN0, + S tauae, pizae, cgae, ! aerosol optical properties + s PTAUA, POMEGAA, + s ztopswad,zsolswad,ztopswai,zsolswai, ! diagnosed aerosol forcing + J ok_ade, ok_aie) ! apply aerosol effects or not? + +c====================================================================== + 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) +cIM +cIM sollwdownclr(iof+i) = zsollwdownclr(i) +cIM BEG +cIM toplwdown(iof+i) = ztoplwdown(i) +cIM toplwdownclr(iof+i) = ztoplwdownclr(i) +cIM END +cIM 110304 BEG + 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 +cIM 110304 END + 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) +cIM 080304 BEG + 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 !k=1, kflev+1 +cIM 080304 END +c swdn0 ( iof+i,1) = ZFSDN0 ( i,1 ) +c swdn0 ( iof+i,2) = ZFSDN0 ( i,kflev + 1 ) +c swdn ( iof+i,1) = ZFSDN ( i,1 ) +c swdn ( iof+i,2) = ZFSDN ( i,kflev + 1 ) +c swup0 ( iof+i,1) = ZFSUP0 ( i,1 ) +c swup0 ( iof+i,2) = ZFSUP0 ( i,kflev + 1 ) +c swup ( iof+i,1) = ZFSUP ( i,1 ) +c swup ( iof+i,2) = ZFSUP ( i,kflev + 1 ) + ENDDO +cjq-transform the aerosol forcings, if they have +cjq to be calculated + IF (ok_ade) THEN + DO i = 1, kdlon + topswad(iof+i) = ztopswad(i) + solswad(iof+i) = zsolswad(i) + ENDDO + ELSE + DO i = 1, kdlon + topswad(iof+i) = 0.0 + solswad(iof+i) = 0.0 + ENDDO + ENDIF + IF (ok_aie) THEN + DO i = 1, kdlon + topswai(iof+i) = ztopswai(i) + solswai(iof+i) = zsolswai(i) + ENDDO + ELSE + DO i = 1, kdlon + topswai(iof+i) = 0.0 + solswai(iof+i) = 0.0 + ENDDO + ENDIF +cjq-end + DO k = 1, kflev +c DO i = 1, kdlon +c heat(iof+i,k) = zheat(i,k) +c cool(iof+i,k) = zcool(i,k) +c heat0(iof+i,k) = zheat0(i,k) +c cool0(iof+i,k) = zcool0(i,k) +c ENDDO + DO i = 1, kdlon +C scale factor to take into account the difference between +C dry air and watter vapour scpecific 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 +c +99999 CONTINUE + RETURN + END +cIM ctes ds clesphys.h SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC, + SUBROUTINE SW(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 ) + + IMPLICIT none + +#include "dimensions.h" +#include "dimphy.h" +#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*8 PSCT ! constante solaire (valeur conseillee: 1370) +cIM ctes ds clesphys.h REAL*8 RCO2 ! concentration CO2 (IPCC: 353.E-06*44.011/28.97) +#include "clesphys.h" +C + REAL*8 PPSOL(KDLON) ! SURFACE PRESSURE (PA) + REAL*8 PDP(KDLON,KFLEV) ! LAYER THICKNESS (PA) + REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB) +C + REAL*8 PRMU0(KDLON) ! COSINE OF ZENITHAL ANGLE + REAL*8 PFRAC(KDLON) ! fraction de la journee +C + REAL*8 PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K) + REAL*8 PWV(KDLON,KFLEV) ! SPECIFIC HUMIDITY (KG/KG) + REAL*8 PQS(KDLON,KFLEV) ! SATURATED WATER VAPOUR (KG/KG) + REAL*8 POZON(KDLON,KFLEV) ! OZONE CONCENTRATION (KG/KG) + REAL*8 PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS +C + REAL*8 PALBD(KDLON,2) ! albedo du sol (lumiere diffuse) + REAL*8 PALBP(KDLON,2) ! albedo du sol (lumiere parallele) +C + REAL*8 PCLDSW(KDLON,KFLEV) ! CLOUD FRACTION + REAL*8 PTAU(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS + REAL*8 PCG(KDLON,2,KFLEV) ! ASYMETRY FACTOR + REAL*8 POMEGA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO +C + REAL*8 PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY) + REAL*8 PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky + REAL*8 PALBPLA(KDLON) ! PLANETARY ALBEDO + REAL*8 PTOPSW(KDLON) ! SHORTWAVE FLUX AT T.O.A. + REAL*8 PSOLSW(KDLON) ! SHORTWAVE FLUX AT SURFACE + REAL*8 PTOPSW0(KDLON) ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY) + REAL*8 PSOLSW0(KDLON) ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY) +C +C* LOCAL VARIABLES: +C + REAL*8 ZOZ(KDLON,KFLEV) + REAL*8 ZAKI(KDLON,2) + REAL*8 ZCLD(KDLON,KFLEV) + REAL*8 ZCLEAR(KDLON) + REAL*8 ZDSIG(KDLON,KFLEV) + REAL*8 ZFACT(KDLON) + REAL*8 ZFD(KDLON,KFLEV+1) + REAL*8 ZFDOWN(KDLON,KFLEV+1) + REAL*8 ZFU(KDLON,KFLEV+1) + REAL*8 ZFUP(KDLON,KFLEV+1) + REAL*8 ZRMU(KDLON) + REAL*8 ZSEC(KDLON) + REAL*8 ZUD(KDLON,5,KFLEV+1) + REAL*8 ZCLDSW0(KDLON,KFLEV) +c + REAL*8 ZFSUP(KDLON,KFLEV+1) + REAL*8 ZFSDN(KDLON,KFLEV+1) + REAL*8 ZFSUP0(KDLON,KFLEV+1) + REAL*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./ +cjq-Introduced for aerosol forcings + real*8 flag_aer + logical ok_ade, ok_aie ! use aerosol forcings or not? + real*8 tauae(kdlon,kflev,2) ! aerosol optical properties + real*8 pizae(kdlon,kflev,2) ! (see aeropt.F) + real*8 cgae(kdlon,kflev,2) ! -"- + REAL*8 PTAUA(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS (pre-industrial value) + REAL*8 POMEGAA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO + REAL*8 PTOPSWAD(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR) + REAL*8 PSOLSWAD(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR) + REAL*8 PTOPSWAI(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND) + REAL*8 PSOLSWAI(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND) +cjq - Fluxes including aerosol effects + REAL*8 ZFSUPAD(KDLON,KFLEV+1) + REAL*8 ZFSDNAD(KDLON,KFLEV+1) + REAL*8 ZFSUPAI(KDLON,KFLEV+1) + REAL*8 ZFSDNAI(KDLON,KFLEV+1) + SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes +cjq-end + +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 + 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 +C +C +c clear-sky: +cIM ctes ds clesphys.h CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL, + CALL SWU(PSCT,ZCLDSW0,PPMB,PPSOL, + S PRMU0,PFRAC,PTAVE,PWV, + S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S(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(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(PSCT,PCLDSW,PPMB,PPSOL, + S PRMU0,PFRAC,PTAVE,PWV, + S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S(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(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(PSCT,PCLDSW,PPMB,PPSOL, + S PRMU0,PFRAC,PTAVE,PWV, + S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S(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(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(PSCT,PCLDSW,PPMB,PPSOL, + S PRMU0,PFRAC,PTAVE,PWV, + S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S(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(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 (PSCT,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC, + S PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT, + S PRMU,PSEC,PUD) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#include "raddim.h" +#include "radepsi.h" +#include "radopt.h" +#include "YOMCST.h" +C +C* ARGUMENTS: +C + REAL*8 PSCT +cIM ctes ds clesphys.h REAL*8 RCO2 +#include "clesphys.h" + REAL*8 PCLDSW(KDLON,KFLEV) + REAL*8 PPMB(KDLON,KFLEV+1) + REAL*8 PPSOL(KDLON) + REAL*8 PRMU0(KDLON) + REAL*8 PFRAC(KDLON) + REAL*8 PTAVE(KDLON,KFLEV) + REAL*8 PWV(KDLON,KFLEV) +C + REAL*8 PAKI(KDLON,2) + REAL*8 PCLD(KDLON,KFLEV) + REAL*8 PCLEAR(KDLON) + REAL*8 PDSIG(KDLON,KFLEV) + REAL*8 PFACT(KDLON) + REAL*8 PRMU(KDLON) + REAL*8 PSEC(KDLON) + REAL*8 PUD(KDLON,5,KFLEV+1) +C +C* LOCAL VARIABLES: +C + INTEGER IIND(2) + REAL*8 ZC1J(KDLON,KFLEV+1) + REAL*8 ZCLEAR(KDLON) + REAL*8 ZCLOUD(KDLON) + REAL*8 ZN175(KDLON) + REAL*8 ZN190(KDLON) + REAL*8 ZO175(KDLON) + REAL*8 ZO190(KDLON) + REAL*8 ZSIGN(KDLON) + REAL*8 ZR(KDLON,2) + REAL*8 ZSIGO(KDLON) + REAL*8 ZUD(KDLON,2) + REAL*8 ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW + INTEGER jl, jk, jkp1, jkl, jklp1, ja +C +C* Prescribed Data: +c + REAL*8 ZPDH2O,ZPDUMG + SAVE ZPDH2O,ZPDUMG + REAL*8 ZPRH2O,ZPRUMG + SAVE ZPRH2O,ZPRUMG + REAL*8 RTDH2O,RTDUMG + SAVE RTDH2O,RTDUMG + REAL*8 RTH2O ,RTUMG + SAVE RTH2O ,RTUMG + DATA ZPDH2O,ZPDUMG / 0.8 , 0.75 / + DATA ZPRH2O,ZPRUMG / 30000., 30000. / + DATA RTDH2O,RTDUMG / 0.40 , 0.375 / + DATA RTH2O ,RTUMG / 240. , 240. / +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(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 ( 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) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 flag_aer + real*8 tauae(kdlon,kflev,2) + real*8 pizae(kdlon,kflev,2) + real*8 cgae(kdlon,kflev,2) + REAL*8 PAER(KDLON,KFLEV,5) + REAL*8 PALBD(KDLON,2) + REAL*8 PALBP(KDLON,2) + REAL*8 PCG(KDLON,2,KFLEV) + REAL*8 PCLD(KDLON,KFLEV) + REAL*8 PCLDSW(KDLON,KFLEV) + REAL*8 PCLEAR(KDLON) + REAL*8 PDSIG(KDLON,KFLEV) + REAL*8 POMEGA(KDLON,2,KFLEV) + REAL*8 POZ(KDLON,KFLEV) + REAL*8 PRMU(KDLON) + REAL*8 PSEC(KDLON) + REAL*8 PTAU(KDLON,2,KFLEV) + REAL*8 PUD(KDLON,5,KFLEV+1) +C + REAL*8 PFD(KDLON,KFLEV+1) + REAL*8 PFU(KDLON,KFLEV+1) +C +C* LOCAL VARIABLES: +C + INTEGER IIND(4) +C + REAL*8 ZCGAZ(KDLON,KFLEV) + REAL*8 ZDIFF(KDLON) + REAL*8 ZDIRF(KDLON) + REAL*8 ZPIZAZ(KDLON,KFLEV) + REAL*8 ZRAYL(KDLON) + REAL*8 ZRAY1(KDLON,KFLEV+1) + REAL*8 ZRAY2(KDLON,KFLEV+1) + REAL*8 ZREFZ(KDLON,2,KFLEV+1) + REAL*8 ZRJ(KDLON,6,KFLEV+1) + REAL*8 ZRJ0(KDLON,6,KFLEV+1) + REAL*8 ZRK(KDLON,6,KFLEV+1) + REAL*8 ZRK0(KDLON,6,KFLEV+1) + REAL*8 ZRMUE(KDLON,KFLEV+1) + REAL*8 ZRMU0(KDLON,KFLEV+1) + REAL*8 ZR(KDLON,4) + REAL*8 ZTAUAZ(KDLON,KFLEV) + REAL*8 ZTRA1(KDLON,KFLEV+1) + REAL*8 ZTRA2(KDLON,KFLEV+1) + REAL*8 ZW(KDLON,4) +C + INTEGER jl, jk, k, jaj, ikm1, ikl +c +c Prescribed Data: +c + REAL*8 RSUN(2) + SAVE RSUN + REAL*8 RRAY(2,6) + SAVE RRAY + DATA RSUN(1) / 0.441676 / + DATA RSUN(2) / 0.558324 / + DATA (RRAY(1,K),K=1,6) / + S .428937E-01, .890743E+00,-.288555E+01, + S .522744E+01,-.469173E+01, .161645E+01/ + DATA (RRAY(2,K),K=1,6) / + S .697200E-02, .173297E-01,-.850903E-01, + S .248261E+00,-.302031E+00, .129662E+00/ +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 ( 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 ( 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(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(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 ( 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 ) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 flag_aer + real*8 tauae(kdlon,kflev,2) + real*8 pizae(kdlon,kflev,2) + real*8 cgae(kdlon,kflev,2) + REAL*8 PAER(KDLON,KFLEV,5) + REAL*8 PAKI(KDLON,2) + REAL*8 PALBD(KDLON,2) + REAL*8 PALBP(KDLON,2) + REAL*8 PCG(KDLON,2,KFLEV) + REAL*8 PCLD(KDLON,KFLEV) + REAL*8 PCLDSW(KDLON,KFLEV) + REAL*8 PCLEAR(KDLON) + REAL*8 PDSIG(KDLON,KFLEV) + REAL*8 POMEGA(KDLON,2,KFLEV) + REAL*8 POZ(KDLON,KFLEV) + REAL*8 PQS(KDLON,KFLEV) + REAL*8 PRMU(KDLON) + REAL*8 PSEC(KDLON) + REAL*8 PTAU(KDLON,2,KFLEV) + REAL*8 PUD(KDLON,5,KFLEV+1) + REAL*8 PWV(KDLON,KFLEV) +C + REAL*8 PFDOWN(KDLON,KFLEV+1) + REAL*8 PFUP(KDLON,KFLEV+1) +C +C* LOCAL VARIABLES: +C + INTEGER IIND2(2), IIND3(3) + REAL*8 ZCGAZ(KDLON,KFLEV) + REAL*8 ZFD(KDLON,KFLEV+1) + REAL*8 ZFU(KDLON,KFLEV+1) + REAL*8 ZG(KDLON) + REAL*8 ZGG(KDLON) + REAL*8 ZPIZAZ(KDLON,KFLEV) + REAL*8 ZRAYL(KDLON) + REAL*8 ZRAY1(KDLON,KFLEV+1) + REAL*8 ZRAY2(KDLON,KFLEV+1) + REAL*8 ZREF(KDLON) + REAL*8 ZREFZ(KDLON,2,KFLEV+1) + REAL*8 ZRE1(KDLON) + REAL*8 ZRE2(KDLON) + REAL*8 ZRJ(KDLON,6,KFLEV+1) + REAL*8 ZRJ0(KDLON,6,KFLEV+1) + REAL*8 ZRK(KDLON,6,KFLEV+1) + REAL*8 ZRK0(KDLON,6,KFLEV+1) + REAL*8 ZRL(KDLON,8) + REAL*8 ZRMUE(KDLON,KFLEV+1) + REAL*8 ZRMU0(KDLON,KFLEV+1) + REAL*8 ZRMUZ(KDLON) + REAL*8 ZRNEB(KDLON) + REAL*8 ZRUEF(KDLON,8) + REAL*8 ZR1(KDLON) + REAL*8 ZR2(KDLON,2) + REAL*8 ZR3(KDLON,3) + REAL*8 ZR4(KDLON) + REAL*8 ZR21(KDLON) + REAL*8 ZR22(KDLON) + REAL*8 ZS(KDLON) + REAL*8 ZTAUAZ(KDLON,KFLEV) + REAL*8 ZTO1(KDLON) + REAL*8 ZTR(KDLON,2,KFLEV+1) + REAL*8 ZTRA1(KDLON,KFLEV+1) + REAL*8 ZTRA2(KDLON,KFLEV+1) + REAL*8 ZTR1(KDLON) + REAL*8 ZTR2(KDLON) + REAL*8 ZW(KDLON) + REAL*8 ZW1(KDLON) + REAL*8 ZW2(KDLON,2) + REAL*8 ZW3(KDLON,3) + REAL*8 ZW4(KDLON) + REAL*8 ZW5(KDLON) +C + INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1 + INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs + REAL*8 ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11 +C +C* Prescribed Data: +C + REAL*8 RSUN(2) + SAVE RSUN + REAL*8 RRAY(2,6) + SAVE RRAY + DATA RSUN(1) / 0.441676 / + DATA RSUN(2) / 0.558324 / + DATA (RRAY(1,K),K=1,6) / + S .428937E-01, .890743E+00,-.288555E+01, + S .522744E+01,-.469173E+01, .161645E+01/ + DATA (RRAY(2,K),K=1,6) / + S .697200E-02, .173297E-01,-.850903E-01, + S .248261E+00,-.302031E+00, .129662E+00/ +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 ( 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 ( 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(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(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(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(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(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(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 ( 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 ) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 flag_aer + real*8 tauae(kdlon,kflev,2) + real*8 pizae(kdlon,kflev,2) + real*8 cgae(kdlon,kflev,2) + REAL*8 PAER(KDLON,KFLEV,5) + REAL*8 PALBP(KDLON,2) + REAL*8 PDSIG(KDLON,KFLEV) + REAL*8 PRAYL(KDLON) + REAL*8 PSEC(KDLON) +C + REAL*8 PCGAZ(KDLON,KFLEV) + REAL*8 PPIZAZ(KDLON,KFLEV) + REAL*8 PRAY1(KDLON,KFLEV+1) + REAL*8 PRAY2(KDLON,KFLEV+1) + REAL*8 PREFZ(KDLON,2,KFLEV+1) + REAL*8 PRJ(KDLON,6,KFLEV+1) + REAL*8 PRK(KDLON,6,KFLEV+1) + REAL*8 PRMU0(KDLON,KFLEV+1) + REAL*8 PTAUAZ(KDLON,KFLEV) + REAL*8 PTRA1(KDLON,KFLEV+1) + REAL*8 PTRA2(KDLON,KFLEV+1) +C +C* LOCAL VARIABLES: +C + REAL*8 ZC0I(KDLON,KFLEV+1) + REAL*8 ZCLE0(KDLON,KFLEV) + REAL*8 ZCLEAR(KDLON) + REAL*8 ZR21(KDLON) + REAL*8 ZR23(KDLON) + REAL*8 ZSS0(KDLON) + REAL*8 ZSCAT(KDLON) + REAL*8 ZTR(KDLON,2,KFLEV+1) +C + INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in + REAL*8 ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE + REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1 + REAL*8 ZBMU0, ZBMU1, ZRE11 +C +C* Prescribed Data for Aerosols: +C + REAL*8 TAUA(2,5), RPIZA(2,5), RCGA(2,5) + SAVE TAUA, RPIZA, RCGA + DATA ((TAUA(IN,JA),JA=1,5),IN=1,2) / + S .730719, .912819, .725059, .745405, .682188 , + S .730719, .912819, .725059, .745405, .682188 / + DATA ((RPIZA(IN,JA),JA=1,5),IN=1,2) / + S .872212, .982545, .623143, .944887, .997975 , + S .872212, .982545, .623143, .944887, .997975 / + DATA ((RCGA (IN,JA),JA=1,5),IN=1,2) / + S .647596, .739002, .580845, .662657, .624246 , + S .647596, .739002, .580845, .662657, .624246 / +C ------------------------------------------------------------------ +C +C* 1. OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH +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 + 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 ( KNU + S , PALBD , PCG , PCLD , PDSIG, POMEGA, PRAYL + S , PSEC , PTAU + S , PCGAZ , PPIZAZ, PRAY1, PRAY2, PREFZ , PRJ , PRK , PRMUE + S , PTAUAZ, PTRA1 , PTRA2 ) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 PALBD(KDLON,2) + REAL*8 PCG(KDLON,2,KFLEV) + REAL*8 PCLD(KDLON,KFLEV) + REAL*8 PDSIG(KDLON,KFLEV) + REAL*8 POMEGA(KDLON,2,KFLEV) + REAL*8 PRAYL(KDLON) + REAL*8 PSEC(KDLON) + REAL*8 PTAU(KDLON,2,KFLEV) +C + REAL*8 PRAY1(KDLON,KFLEV+1) + REAL*8 PRAY2(KDLON,KFLEV+1) + REAL*8 PREFZ(KDLON,2,KFLEV+1) + REAL*8 PRJ(KDLON,6,KFLEV+1) + REAL*8 PRK(KDLON,6,KFLEV+1) + REAL*8 PRMUE(KDLON,KFLEV+1) + REAL*8 PCGAZ(KDLON,KFLEV) + REAL*8 PPIZAZ(KDLON,KFLEV) + REAL*8 PTAUAZ(KDLON,KFLEV) + REAL*8 PTRA1(KDLON,KFLEV+1) + REAL*8 PTRA2(KDLON,KFLEV+1) +C +C* LOCAL VARIABLES: +C + REAL*8 ZC1I(KDLON,KFLEV+1) + REAL*8 ZCLEQ(KDLON,KFLEV) + REAL*8 ZCLEAR(KDLON) + REAL*8 ZCLOUD(KDLON) + REAL*8 ZGG(KDLON) + REAL*8 ZREF(KDLON) + REAL*8 ZRE1(KDLON) + REAL*8 ZRE2(KDLON) + REAL*8 ZRMUZ(KDLON) + REAL*8 ZRNEB(KDLON) + REAL*8 ZR21(KDLON) + REAL*8 ZR22(KDLON) + REAL*8 ZR23(KDLON) + REAL*8 ZSS1(KDLON) + REAL*8 ZTO1(KDLON) + REAL*8 ZTR(KDLON,2,KFLEV+1) + REAL*8 ZTR1(KDLON) + REAL*8 ZTR2(KDLON) + REAL*8 ZW(KDLON) +C + INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj + REAL*8 ZFACOA, ZFACOC, ZCORAE, ZCORCD + REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1 + REAL*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(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 (PGG,PREF,PRMUZ,PTO1,PW, + S PRE1,PRE2,PTR1,PTR2) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 PGG(KDLON) ! ASSYMETRY FACTOR + REAL*8 PREF(KDLON) ! REFLECTIVITY OF THE UNDERLYING LAYER + REAL*8 PRMUZ(KDLON) ! COSINE OF SOLAR ZENITH ANGLE + REAL*8 PTO1(KDLON) ! OPTICAL THICKNESS + REAL*8 PW(KDLON) ! SINGLE SCATTERING ALBEDO + REAL*8 PRE1(KDLON) ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION) + REAL*8 PRE2(KDLON) ! LAYER REFLECTIVITY + REAL*8 PTR1(KDLON) ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION) + REAL*8 PTR2(KDLON) ! LAYER TRANSMISSIVITY +C +C* LOCAL VARIABLES: +C + INTEGER jl + REAL*8 ZFF, ZGP, ZTOP, ZWCP, ZDT, ZX1, ZWM + REAL*8 ZRM2, ZRK, ZX2, ZRP, ZALPHA, ZBETA, ZARG + REAL*8 ZEXMU0, ZARG2, ZEXKP, ZEXKM, ZXP2P, ZXM2P, ZAP2B, ZAM2B + REAL*8 ZA11, ZA12, ZA13, ZA21, ZA22, ZA23 + REAL*8 ZDENA, ZC1A, ZC2A, ZRI0A, ZRI1A + REAL*8 ZRI0B, ZRI1B + REAL*8 ZB21, ZB22, ZB23, ZDENB, ZC1B, ZC2B + REAL*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 +CMAF ZARG=MIN(ZTOP/PRMUZ(JL),200.) + ZARG=MIN(ZTOP/PRMUZ(JL),2.0d+2) + ZEXMU0=EXP(-ZARG) +CMAF ZARG2=MIN(ZRK*ZTOP,200.) + ZARG2=MIN(ZRK*ZTOP,2.0d+2) + 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 (KNU,KA,PU,PTR) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 PU(KDLON) ! ABSORBER AMOUNT +C + REAL*8 PTR(KDLON) ! TRANSMISSION FUNCTION +C +C* LOCAL VARIABLES: +C + REAL*8 ZR1(KDLON), ZR2(KDLON) + INTEGER jl, i,j +C +C* Prescribed Data: +C + REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3) + SAVE APAD, BPAD, D + DATA ((APAD(1,I,J),I=1,3),J=1,7) / + S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04, + S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01, + S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00, + S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02, + S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02, + S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02, + S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 / + DATA ((APAD(2,I,J),I=1,3),J=1,7) / + S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03, + S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02, + S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00, + S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00, + S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00, + S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00, + S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 / +C + DATA ((BPAD(1,I,J),I=1,3),J=1,7) / + S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04, + S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01, + S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00, + S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02, + S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02, + S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02, + S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 / + DATA ((BPAD(2,I,J),I=1,3),J=1,7) / + S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03, + S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02, + S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01, + S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00, + S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00, + S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00, + S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 / +c + DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 / + DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 / +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(KNU,KABS,KIND, PU, PTR) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 PU(KDLON,KABS) ! ABSORBER AMOUNT +C + REAL*8 PTR(KDLON,KABS) ! TRANSMISSION FUNCTION +C +C* LOCAL VARIABLES: +C + REAL*8 ZR1(KDLON) + REAL*8 ZR2(KDLON) + REAL*8 ZU(KDLON) + INTEGER jl, ja, i, j, ia +C +C* Prescribed Data: +C + REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3) + SAVE APAD, BPAD, D + DATA ((APAD(1,I,J),I=1,3),J=1,7) / + S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04, + S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01, + S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00, + S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02, + S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02, + S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02, + S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 / + DATA ((APAD(2,I,J),I=1,3),J=1,7) / + S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03, + S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02, + S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00, + S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00, + S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00, + S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00, + S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 / +C + DATA ((BPAD(1,I,J),I=1,3),J=1,7) / + S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04, + S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01, + S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00, + S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02, + S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02, + S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02, + S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 / + DATA ((BPAD(2,I,J),I=1,3),J=1,7) / + S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03, + S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02, + S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01, + S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00, + S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00, + S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00, + S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 / +c + DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 / + DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 / +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( + . 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) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 RCO2 ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97) +c REAL*8 RCH4 ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97) +c REAL*8 RN2O ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97) +c REAL*8 RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12* 137.3686/28.97) +c REAL*8 RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12* 120.9140/28.97) +#include "clesphys.h" + REAL*8 PCLDLD(KDLON,KFLEV) ! DOWNWARD EFFECTIVE CLOUD COVER + REAL*8 PCLDLU(KDLON,KFLEV) ! UPWARD EFFECTIVE CLOUD COVER + REAL*8 PDP(KDLON,KFLEV) ! LAYER PRESSURE THICKNESS (Pa) + REAL*8 PDT0(KDLON) ! SURFACE TEMPERATURE DISCONTINUITY (K) + REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY + REAL*8 PPMB(KDLON,KFLEV+1) ! HALF LEVEL PRESSURE (mb) + REAL*8 PPSOL(KDLON) ! SURFACE PRESSURE (Pa) + REAL*8 POZON(KDLON,KFLEV) ! O3 CONCENTRATION (kg/kg) + REAL*8 PTL(KDLON,KFLEV+1) ! HALF LEVEL TEMPERATURE (K) + REAL*8 PAER(KDLON,KFLEV,5) ! OPTICAL THICKNESS OF THE AEROSOLS + REAL*8 PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K) + REAL*8 PVIEW(KDLON) ! COSECANT OF VIEWING ANGLE + REAL*8 PWV(KDLON,KFLEV) ! SPECIFIC HUMIDITY (kg/kg) +C + REAL*8 PCOLR(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day) + REAL*8 PCOLR0(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day) clear-sky + REAL*8 PTOPLW(KDLON) ! LONGWAVE FLUX AT T.O.A. + REAL*8 PSOLLW(KDLON) ! LONGWAVE FLUX AT SURFACE + REAL*8 PTOPLW0(KDLON) ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY) + REAL*8 PSOLLW0(KDLON) ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY) +c Rajout LF + real*8 psollwdown(kdlon) ! LONGWAVE downwards flux at surface +c Rajout IM +cIM real*8 psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at surface +cIM real*8 ptoplwdown(kdlon) ! LONGWAVE downwards flux at T.O.A. +cIM real*8 ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at T.O.A. +cIM + REAL*8 plwup(KDLON,KFLEV+1) ! LW up total sky + REAL*8 plwup0(KDLON,KFLEV+1) ! LW up clear sky + REAL*8 plwdn(KDLON,KFLEV+1) ! LW down total sky + REAL*8 plwdn0(KDLON,KFLEV+1) ! LW down clear sky +C------------------------------------------------------------------------- + REAL*8 ZABCU(KDLON,NUA,3*KFLEV+1) + REAL*8 ZOZ(KDLON,KFLEV) +c + REAL*8 ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2:down) + REAL*8 ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES + REAL*8 ZBINT(KDLON,KFLEV+1) ! Intermediate variable + REAL*8 ZBSUI(KDLON) ! Intermediate variable + REAL*8 ZCTS(KDLON,KFLEV) ! Intermediate variable + REAL*8 ZCNTRB(KDLON,KFLEV+1,KFLEV+1) ! Intermediate variable + SAVE 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 + 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" + appel1er=.FALSE. + ENDIF +C + IF (MOD(itaplw0,lw0pas).EQ.0) THEN + DO k = 1, KFLEV ! convertir ozone de kg/kg en pa/pa + DO i = 1, KDLON + ZOZ(i,k) = POZON(i,k)*PDP(i,k) * 28.9644/47.9942 + ENDDO + ENDDO +cIM ctes ds clesphys.h CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12, + CALL LWU( + S PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU) + CALL LWBV(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(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) +cIM +cIM psollwdownclr(i) = -ZFLUC(i,2,1) +cIM ptoplwdown(i) = ZFLUX(i,2,KFLEV+1) +cIM ptoplwdownclr(i) = ZFLUC(i,2,KFLEV+1) +cIM +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( + S PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV, + S PABCU) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 RCO2 +c REAL*8 RCH4, RN2O, RCFC11, RCFC12 +#include "clesphys.h" + REAL*8 PAER(KDLON,KFLEV,5) + REAL*8 PDP(KDLON,KFLEV) + REAL*8 PPMB(KDLON,KFLEV+1) + REAL*8 PPSOL(KDLON) + REAL*8 POZ(KDLON,KFLEV) + REAL*8 PTAVE(KDLON,KFLEV) + REAL*8 PVIEW(KDLON) + REAL*8 PWV(KDLON,KFLEV) +C + REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS +C +C----------------------------------------------------------------------- +C* LOCAL VARIABLES: + REAL*8 ZABLY(KDLON,NUA,3*KFLEV+1) + REAL*8 ZDUC(KDLON,3*KFLEV+1) + REAL*8 ZPHIO(KDLON) + REAL*8 ZPSC2(KDLON) + REAL*8 ZPSC3(KDLON) + REAL*8 ZPSH1(KDLON) + REAL*8 ZPSH2(KDLON) + REAL*8 ZPSH3(KDLON) + REAL*8 ZPSH4(KDLON) + REAL*8 ZPSH5(KDLON) + REAL*8 ZPSH6(KDLON) + REAL*8 ZPSIO(KDLON) + REAL*8 ZTCON(KDLON) + REAL*8 ZPHM6(KDLON) + REAL*8 ZPSM6(KDLON) + REAL*8 ZPHN6(KDLON) + REAL*8 ZPSN6(KDLON) + REAL*8 ZSSIG(KDLON,3*KFLEV+1) + REAL*8 ZTAVI(KDLON) + REAL*8 ZUAER(KDLON,Ninter) + REAL*8 ZXOZ(KDLON) + REAL*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*8 zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup + REAL*8 zfppw, ztx, ztx2, zzably + REAL*8 zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3 + REAL*8 zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6 + REAL*8 zcac8, zcbc8 + REAL*8 zalup, zdiff +c + REAL*8 PVGCO2, PVGH2O, PVGO3 +C + REAL*8 R10E ! DECIMAL/NATURAL LOG.FACTOR + PARAMETER (R10E=0.4342945) +c +c Used Data Block: +c + REAL*8 TREF + SAVE TREF + REAL*8 RT1(2) + SAVE RT1 + REAL*8 RAER(5,5) + SAVE RAER + REAL*8 AT(8,3), BT(8,3) + SAVE AT, BT + REAL*8 OCT(4) + SAVE OCT + DATA TREF /250.0/ + DATA (RT1(IG1),IG1=1,2) / -0.577350269, +0.577350269 / + DATA RAER / .038520, .037196, .040532, .054934, .038520 + 1 , .12613 , .18313 , .10357 , .064106, .126130 + 2 , .012579, .013649, .018652, .025181, .012579 + 3 , .011890, .016142, .021105, .028908, .011890 + 4 , .013792, .026810, .052203, .066338, .013792 / + DATA (AT(1,IR),IR=1,3) / + S 0.298199E-02,-.394023E-03,0.319566E-04 / + DATA (BT(1,IR),IR=1,3) / + S-0.106432E-04,0.660324E-06,0.174356E-06 / + DATA (AT(2,IR),IR=1,3) / + S 0.143676E-01,0.366501E-02,-.160822E-02 / + DATA (BT(2,IR),IR=1,3) / + S-0.553979E-04,-.101701E-04,0.920868E-05 / + DATA (AT(3,IR),IR=1,3) / + S 0.197861E-01,0.315541E-02,-.174547E-02 / + DATA (BT(3,IR),IR=1,3) / + S-0.877012E-04,0.513302E-04,0.523138E-06 / + DATA (AT(4,IR),IR=1,3) / + S 0.289560E-01,-.208807E-02,-.121943E-02 / + DATA (BT(4,IR),IR=1,3) / + S-0.165960E-03,0.157704E-03,-.146427E-04 / + DATA (AT(5,IR),IR=1,3) / + S 0.103800E-01,0.436296E-02,-.161431E-02 / + DATA (BT(5,IR),IR=1,3) / + S -.276744E-04,-.327381E-04,0.127646E-04 / + DATA (AT(6,IR),IR=1,3) / + S 0.868859E-02,-.972752E-03,0.000000E-00 / + DATA (BT(6,IR),IR=1,3) / + S -.278412E-04,-.713940E-06,0.117469E-05 / + DATA (AT(7,IR),IR=1,3) / + S 0.250073E-03,0.455875E-03,0.109242E-03 / + DATA (BT(7,IR),IR=1,3) / + S 0.199846E-05,-.216313E-05,0.175991E-06 / + DATA (AT(8,IR),IR=1,3) / + S 0.307423E-01,0.110879E-02,-.322172E-03 / + DATA (BT(8,IR),IR=1,3) / + S-0.108482E-03,0.258096E-05,-.814575E-06 / +c + DATA OCT /-.326E-03, -.102E-05, .137E-02, -.535E-05/ +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) +CMAF ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0.), 6.0) + ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0.d+0), 6.d+0) + 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 ) +CMAF ZUP = MAX( 0.0 , 5.0 + 0.5 * ZALUP ) + ZUP = MAX( 0.d+0 , 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(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU, + S PFLUC,PBINT,PBSUI,PCTS,PCNTRB) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 PDP(KDLON,KFLEV) + REAL*8 PDT0(KDLON) + REAL*8 PEMIS(KDLON) + REAL*8 PPMB(KDLON,KFLEV+1) + REAL*8 PTL(KDLON,KFLEV+1) + REAL*8 PTAVE(KDLON,KFLEV) +C + REAL*8 PFLUC(KDLON,2,KFLEV+1) +C + REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) + REAL*8 PBINT(KDLON,KFLEV+1) + REAL*8 PBSUI(KDLON) + REAL*8 PCTS(KDLON,KFLEV) + REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) +C +C------------------------------------------------------------------------- +C +C* LOCAL VARIABLES: + REAL*8 ZB(KDLON,Ninter,KFLEV+1) + REAL*8 ZBSUR(KDLON,Ninter) + REAL*8 ZBTOP(KDLON,Ninter) + REAL*8 ZDBSL(KDLON,Ninter,KFLEV*2) + REAL*8 ZGA(KDLON,8,2,KFLEV) + REAL*8 ZGB(KDLON,8,2,KFLEV) + REAL*8 ZGASUR(KDLON,8,2) + REAL*8 ZGBSUR(KDLON,8,2) + REAL*8 ZGATOP(KDLON,8,2) + REAL*8 ZGBTOP(KDLON,8,2) +C + INTEGER nuaer, ntraer +C ------------------------------------------------------------------ +C* COMPUTES PLANCK FUNCTIONS: + CALL LWB(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(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(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC, + R PBINT,PBSUIN,PCTS,PCNTRB, + S PFLUX) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES + REAL*8 PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION + REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION + REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE + REAL*8 PCTS(KDLON,KFLEV) ! CLEAR-SKY LAYER COOLING-TO-SPACE +c + REAL*8 PCLDLD(KDLON,KFLEV) + REAL*8 PCLDLU(KDLON,KFLEV) + REAL*8 PEMIS(KDLON) +C + REAL*8 PFLUX(KDLON,2,KFLEV+1) +C----------------------------------------------------------------------- +C* LOCAL VARIABLES: + INTEGER IMX(KDLON), IMXP(KDLON) +C + REAL*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*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*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(PDT0,PTAVE,PTL + S , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL + S , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 PDT0(KDLON) + REAL*8 PTAVE(KDLON,KFLEV) + REAL*8 PTL(KDLON,KFLEV+1) +C + REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION + REAL*8 PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION + REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION + REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION + REAL*8 PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION + REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT + REAL*8 PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS + REAL*8 PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS + REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS + REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS + REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS + REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS +C +C------------------------------------------------------------------------- +C* LOCAL VARIABLES: + INTEGER INDB(KDLON),INDS(KDLON) + REAL*8 ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1) + REAL*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*8 zdsto1, zdstox, zdst1, zdstx +c +C* Quelques parametres: + REAL*8 TSTAND + PARAMETER (TSTAND=250.0) + REAL*8 TSTP + PARAMETER (TSTP=12.5) + INTEGER MXIXT + PARAMETER (MXIXT=10) +C +C* Used Data Block: + REAL*8 TINTP(11) + SAVE TINTP + REAL*8 GA(11,16,3), GB(11,16,3) + SAVE GA, GB + REAL*8 XP(6,6) + SAVE XP +c + DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250., + 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 + DATA (GA( 1, 1,IC),IC=1,3) / + S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/ + DATA (GB( 1, 1,IC),IC=1,3) / + S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/ + DATA (GA( 1, 2,IC),IC=1,3) / + S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/ + DATA (GB( 1, 2,IC),IC=1,3) / + 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 + DATA (GA( 2, 1,IC),IC=1,3) / + S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/ + DATA (GB( 2, 1,IC),IC=1,3) / + S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/ + DATA (GA( 2, 2,IC),IC=1,3) / + S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/ + DATA (GB( 2, 2,IC),IC=1,3) / + 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 + DATA (GA( 3, 1,IC),IC=1,3) / + S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/ + DATA (GB( 3, 1,IC),IC=1,3) / + S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/ + DATA (GA( 3, 2,IC),IC=1,3) / + S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/ + DATA (GB( 3, 2,IC),IC=1,3) / + 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 + DATA (GA( 4, 1,IC),IC=1,3) / + S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/ + DATA (GB( 4, 1,IC),IC=1,3) / + S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/ + DATA (GA( 4, 2,IC),IC=1,3) / + S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/ + DATA (GB( 4, 2,IC),IC=1,3) / + 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 + DATA (GA( 5, 1,IC),IC=1,3) / + S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/ + DATA (GB( 5, 1,IC),IC=1,3) / + S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/ + DATA (GA( 5, 2,IC),IC=1,3) / + S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/ + DATA (GB( 5, 2,IC),IC=1,3) / + 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 + DATA (GA( 6, 1,IC),IC=1,3) / + S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/ + DATA (GB( 6, 1,IC),IC=1,3) / + S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/ + DATA (GA( 6, 2,IC),IC=1,3) / + S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/ + DATA (GB( 6, 2,IC),IC=1,3) / + 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 + DATA (GA( 7, 1,IC),IC=1,3) / + S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/ + DATA (GB( 7, 1,IC),IC=1,3) / + S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/ + DATA (GA( 7, 2,IC),IC=1,3) / + S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/ + DATA (GB( 7, 2,IC),IC=1,3) / + 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 + DATA (GA( 8, 1,IC),IC=1,3) / + S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/ + DATA (GB( 8, 1,IC),IC=1,3) / + S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/ + DATA (GA( 8, 2,IC),IC=1,3) / + S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/ + DATA (GB( 8, 2,IC),IC=1,3) / + 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 + DATA (GA( 9, 1,IC),IC=1,3) / + S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/ + DATA (GB( 9, 1,IC),IC=1,3) / + S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/ + DATA (GA( 9, 2,IC),IC=1,3) / + S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/ + DATA (GB( 9, 2,IC),IC=1,3) / + 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 + DATA (GA(10, 1,IC),IC=1,3) / + S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/ + DATA (GB(10, 1,IC),IC=1,3) / + S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/ + DATA (GA(10, 2,IC),IC=1,3) / + S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/ + DATA (GB(10, 2,IC),IC=1,3) / + 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 + DATA (GA(11, 1,IC),IC=1,3) / + S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/ + DATA (GB(11, 1,IC),IC=1,3) / + S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/ + DATA (GA(11, 2,IC),IC=1,3) / + S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/ + DATA (GB(11, 2,IC),IC=1,3) / + 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 + DATA (GA( 1, 3,IC),IC=1,3) / + S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/ + DATA (GB( 1, 3,IC),IC=1,3) / + S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/ + DATA (GA( 1, 4,IC),IC=1,3) / + S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/ + DATA (GB( 1, 4,IC),IC=1,3) / + 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 + DATA (GA( 2, 3,IC),IC=1,3) / + S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/ + DATA (GB( 2, 3,IC),IC=1,3) / + S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/ + DATA (GA( 2, 4,IC),IC=1,3) / + S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/ + DATA (GB( 2, 4,IC),IC=1,3) / + 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 + DATA (GA( 3, 3,IC),IC=1,3) / + S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/ + DATA (GB( 3, 3,IC),IC=1,3) / + S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/ + DATA (GA( 3, 4,IC),IC=1,3) / + S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/ + DATA (GB( 3, 4,IC),IC=1,3) / + 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 + DATA (GA( 4, 3,IC),IC=1,3) / + S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/ + DATA (GB( 4, 3,IC),IC=1,3) / + S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/ + DATA (GA( 4, 4,IC),IC=1,3) / + S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/ + DATA (GB( 4, 4,IC),IC=1,3) / + 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 + DATA (GA( 5, 3,IC),IC=1,3) / + S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/ + DATA (GB( 5, 3,IC),IC=1,3) / + S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/ + DATA (GA( 5, 4,IC),IC=1,3) / + S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/ + DATA (GB( 5, 4,IC),IC=1,3) / + 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 + DATA (GA( 6, 3,IC),IC=1,3) / + S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/ + DATA (GB( 6, 3,IC),IC=1,3) / + S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/ + DATA (GA( 6, 4,IC),IC=1,3) / + S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/ + DATA (GB( 6, 4,IC),IC=1,3) / + 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 + DATA (GA( 7, 3,IC),IC=1,3) / + S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/ + DATA (GB( 7, 3,IC),IC=1,3) / + S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/ + DATA (GA( 7, 4,IC),IC=1,3) / + S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/ + DATA (GB( 7, 4,IC),IC=1,3) / + 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 + DATA (GA( 8, 3,IC),IC=1,3) / + S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/ + DATA (GB( 8, 3,IC),IC=1,3) / + S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/ + DATA (GA( 8, 4,IC),IC=1,3) / + S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/ + DATA (GB( 8, 4,IC),IC=1,3) / + 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 + DATA (GA( 9, 3,IC),IC=1,3) / + S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/ + DATA (GB( 9, 3,IC),IC=1,3) / + S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/ + DATA (GA( 9, 4,IC),IC=1,3) / + S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/ + DATA (GB( 9, 4,IC),IC=1,3) / + 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 + DATA (GA(10, 3,IC),IC=1,3) / + S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/ + DATA (GB(10, 3,IC),IC=1,3) / + S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/ + DATA (GA(10, 4,IC),IC=1,3) / + S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/ + DATA (GB(10, 4,IC),IC=1,3) / + 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 + DATA (GA(11, 3,IC),IC=1,3) / + S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/ + DATA (GB(11, 3,IC),IC=1,3) / + S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/ + DATA (GA(11, 4,IC),IC=1,3) / + S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/ + DATA (GB(11, 4,IC),IC=1,3) / + 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 + DATA (GA( 1, 7,IC),IC=1,3) / + S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/ + DATA (GB( 1, 7,IC),IC=1,3) / + S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/ + DATA (GA( 1, 8,IC),IC=1,3) / + S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/ + DATA (GB( 1, 8,IC),IC=1,3) / + 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 + DATA (GA( 2, 7,IC),IC=1,3) / + S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/ + DATA (GB( 2, 7,IC),IC=1,3) / + S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/ + DATA (GA( 2, 8,IC),IC=1,3) / + S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/ + DATA (GB( 2, 8,IC),IC=1,3) / + 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 + DATA (GA( 3, 7,IC),IC=1,3) / + S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/ + DATA (GB( 3, 7,IC),IC=1,3) / + S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/ + DATA (GA( 3, 8,IC),IC=1,3) / + S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/ + DATA (GB( 3, 8,IC),IC=1,3) / + 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 + DATA (GA( 4, 7,IC),IC=1,3) / + S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/ + DATA (GB( 4, 7,IC),IC=1,3) / + S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/ + DATA (GA( 4, 8,IC),IC=1,3) / + S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/ + DATA (GB( 4, 8,IC),IC=1,3) / + 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 + DATA (GA( 5, 7,IC),IC=1,3) / + S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/ + DATA (GB( 5, 7,IC),IC=1,3) / + S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/ + DATA (GA( 5, 8,IC),IC=1,3) / + S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/ + DATA (GB( 5, 8,IC),IC=1,3) / + 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 + DATA (GA( 6, 7,IC),IC=1,3) / + S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/ + DATA (GB( 6, 7,IC),IC=1,3) / + S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/ + DATA (GA( 6, 8,IC),IC=1,3) / + S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/ + DATA (GB( 6, 8,IC),IC=1,3) / + 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 + DATA (GA( 7, 7,IC),IC=1,3) / + S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/ + DATA (GB( 7, 7,IC),IC=1,3) / + S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/ + DATA (GA( 7, 8,IC),IC=1,3) / + S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/ + DATA (GB( 7, 8,IC),IC=1,3) / + 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 + DATA (GA( 8, 7,IC),IC=1,3) / + S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/ + DATA (GB( 8, 7,IC),IC=1,3) / + S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/ + DATA (GA( 8, 8,IC),IC=1,3) / + S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/ + DATA (GB( 8, 8,IC),IC=1,3) / + 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 + DATA (GA( 9, 7,IC),IC=1,3) / + S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/ + DATA (GB( 9, 7,IC),IC=1,3) / + S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/ + DATA (GA( 9, 8,IC),IC=1,3) / + S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/ + DATA (GB( 9, 8,IC),IC=1,3) / + 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 + DATA (GA(10, 7,IC),IC=1,3) / + S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/ + DATA (GB(10, 7,IC),IC=1,3) / + S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/ + DATA (GA(10, 8,IC),IC=1,3) / + S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/ + DATA (GB(10, 8,IC),IC=1,3) / + 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 + DATA (GA(11, 7,IC),IC=1,3) / + S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/ + DATA (GB(11, 7,IC),IC=1,3) / + S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/ + DATA (GA(11, 8,IC),IC=1,3) / + S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/ + DATA (GB(11, 8,IC),IC=1,3) / + 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 + DATA (GA( 1, 9,IC),IC=1,3) / + S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/ + DATA (GB( 1, 9,IC),IC=1,3) / + S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/ + DATA (GA( 1,10,IC),IC=1,3) / + S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/ + DATA (GB( 1,10,IC),IC=1,3) / + 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 + DATA (GA( 2, 9,IC),IC=1,3) / + S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/ + DATA (GB( 2, 9,IC),IC=1,3) / + S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/ + DATA (GA( 2,10,IC),IC=1,3) / + S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/ + DATA (GB( 2,10,IC),IC=1,3) / + 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 + DATA (GA( 3, 9,IC),IC=1,3) / + S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/ + DATA (GB( 3, 9,IC),IC=1,3) / + S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/ + DATA (GA( 3,10,IC),IC=1,3) / + S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/ + DATA (GB( 3,10,IC),IC=1,3) / + 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 + DATA (GA( 4, 9,IC),IC=1,3) / + S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/ + DATA (GB( 4, 9,IC),IC=1,3) / + S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/ + DATA (GA( 4,10,IC),IC=1,3) / + S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/ + DATA (GB( 4,10,IC),IC=1,3) / + 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 + DATA (GA( 5, 9,IC),IC=1,3) / + S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/ + DATA (GB( 5, 9,IC),IC=1,3) / + S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/ + DATA (GA( 5,10,IC),IC=1,3) / + S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/ + DATA (GB( 5,10,IC),IC=1,3) / + 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 + DATA (GA( 6, 9,IC),IC=1,3) / + S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/ + DATA (GB( 6, 9,IC),IC=1,3) / + S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/ + DATA (GA( 6,10,IC),IC=1,3) / + S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/ + DATA (GB( 6,10,IC),IC=1,3) / + 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 + DATA (GA( 7, 9,IC),IC=1,3) / + S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/ + DATA (GB( 7, 9,IC),IC=1,3) / + S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/ + DATA (GA( 7,10,IC),IC=1,3) / + S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/ + DATA (GB( 7,10,IC),IC=1,3) / + 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 + DATA (GA( 8, 9,IC),IC=1,3) / + S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/ + DATA (GB( 8, 9,IC),IC=1,3) / + S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/ + DATA (GA( 8,10,IC),IC=1,3) / + S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/ + DATA (GB( 8,10,IC),IC=1,3) / + 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 + DATA (GA( 9, 9,IC),IC=1,3) / + S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/ + DATA (GB( 9, 9,IC),IC=1,3) / + S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/ + DATA (GA( 9,10,IC),IC=1,3) / + S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/ + DATA (GB( 9,10,IC),IC=1,3) / + 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 + DATA (GA(10, 9,IC),IC=1,3) / + S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/ + DATA (GB(10, 9,IC),IC=1,3) / + S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/ + DATA (GA(10,10,IC),IC=1,3) / + S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/ + DATA (GB(10,10,IC),IC=1,3) / + 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 + DATA (GA(11, 9,IC),IC=1,3) / + S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/ + DATA (GB(11, 9,IC),IC=1,3) / + S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/ + DATA (GA(11,10,IC),IC=1,3) / + S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/ + DATA (GB(11,10,IC),IC=1,3) / + 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 + DATA (GA( 1, 5,IC),IC=1,3) / + S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/ + DATA (GB( 1, 5,IC),IC=1,3) / + S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/ + DATA (GA( 1, 6,IC),IC=1,3) / + S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/ + DATA (GB( 1, 6,IC),IC=1,3) / + 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 + DATA (GA( 2, 5,IC),IC=1,3) / + S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/ + DATA (GB( 2, 5,IC),IC=1,3) / + S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/ + DATA (GA( 2, 6,IC),IC=1,3) / + S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/ + DATA (GB( 2, 6,IC),IC=1,3) / + 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 + DATA (GA( 3, 5,IC),IC=1,3) / + S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/ + DATA (GB( 3, 5,IC),IC=1,3) / + S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/ + DATA (GA( 3, 6,IC),IC=1,3) / + S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/ + DATA (GB( 3, 6,IC),IC=1,3) / + 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 + DATA (GA( 4, 5,IC),IC=1,3) / + S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/ + DATA (GB( 4, 5,IC),IC=1,3) / + S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/ + DATA (GA( 4, 6,IC),IC=1,3) / + S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/ + DATA (GB( 4, 6,IC),IC=1,3) / + 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 + DATA (GA( 5, 5,IC),IC=1,3) / + S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/ + DATA (GB( 5, 5,IC),IC=1,3) / + S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/ + DATA (GA( 5, 6,IC),IC=1,3) / + S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/ + DATA (GB( 5, 6,IC),IC=1,3) / + 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 + DATA (GA( 6, 5,IC),IC=1,3) / + S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/ + DATA (GB( 6, 5,IC),IC=1,3) / + S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/ + DATA (GA( 6, 6,IC),IC=1,3) / + S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/ + DATA (GB( 6, 6,IC),IC=1,3) / + 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 + DATA (GA( 7, 5,IC),IC=1,3) / + S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/ + DATA (GB( 7, 5,IC),IC=1,3) / + S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/ + DATA (GA( 7, 6,IC),IC=1,3) / + S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/ + DATA (GB( 7, 6,IC),IC=1,3) / + 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 + DATA (GA( 8, 5,IC),IC=1,3) / + S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/ + DATA (GB( 8, 5,IC),IC=1,3) / + S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/ + DATA (GA( 8, 6,IC),IC=1,3) / + S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/ + DATA (GB( 8, 6,IC),IC=1,3) / + 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 + DATA (GA( 9, 5,IC),IC=1,3) / + S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/ + DATA (GB( 9, 5,IC),IC=1,3) / + S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/ + DATA (GA( 9, 6,IC),IC=1,3) / + S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/ + DATA (GB( 9, 6,IC),IC=1,3) / + 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 + DATA (GA(10, 5,IC),IC=1,3) / + S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/ + DATA (GB(10, 5,IC),IC=1,3) / + S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/ + DATA (GA(10, 6,IC),IC=1,3) / + S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/ + DATA (GB(10, 6,IC),IC=1,3) / + 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 + DATA (GA(11, 5,IC),IC=1,3) / + S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/ + DATA (GB(11, 5,IC),IC=1,3) / + S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/ + DATA (GA(11, 6,IC),IC=1,3) / + S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/ + DATA (GB(11, 6,IC),IC=1,3) / + 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 + DATA (GA( 1,11,IC),IC=1,3) / + S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/ + DATA (GB( 1,11,IC),IC=1,3) / + S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/ + DATA (GA( 1,12,IC),IC=1,3) / + S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/ + DATA (GB( 1,12,IC),IC=1,3) / + 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 + DATA (GA( 2,11,IC),IC=1,3) / + S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/ + DATA (GB( 2,11,IC),IC=1,3) / + S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/ + DATA (GA( 2,12,IC),IC=1,3) / + S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/ + DATA (GB( 2,12,IC),IC=1,3) / + 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 + DATA (GA( 3,11,IC),IC=1,3) / + S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/ + DATA (GB( 3,11,IC),IC=1,3) / + S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/ + DATA (GA( 3,12,IC),IC=1,3) / + S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/ + DATA (GB( 3,12,IC),IC=1,3) / + 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 + DATA (GA( 4,11,IC),IC=1,3) / + S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/ + DATA (GB( 4,11,IC),IC=1,3) / + S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/ + DATA (GA( 4,12,IC),IC=1,3) / + S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/ + DATA (GB( 4,12,IC),IC=1,3) / + 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 + DATA (GA( 5,11,IC),IC=1,3) / + S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/ + DATA (GB( 5,11,IC),IC=1,3) / + S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/ + DATA (GA( 5,12,IC),IC=1,3) / + S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/ + DATA (GB( 5,12,IC),IC=1,3) / + 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 + DATA (GA( 6,11,IC),IC=1,3) / + S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/ + DATA (GB( 6,11,IC),IC=1,3) / + S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/ + DATA (GA( 6,12,IC),IC=1,3) / + S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/ + DATA (GB( 6,12,IC),IC=1,3) / + 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 + DATA (GA( 7,11,IC),IC=1,3) / + S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/ + DATA (GB( 7,11,IC),IC=1,3) / + S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/ + DATA (GA( 7,12,IC),IC=1,3) / + S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/ + DATA (GB( 7,12,IC),IC=1,3) / + 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 + DATA (GA( 8,11,IC),IC=1,3) / + S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/ + DATA (GB( 8,11,IC),IC=1,3) / + S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/ + DATA (GA( 8,12,IC),IC=1,3) / + S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/ + DATA (GB( 8,12,IC),IC=1,3) / + 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 + DATA (GA( 9,11,IC),IC=1,3) / + S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/ + DATA (GB( 9,11,IC),IC=1,3) / + S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/ + DATA (GA( 9,12,IC),IC=1,3) / + S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/ + DATA (GB( 9,12,IC),IC=1,3) / + 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 + DATA (GA(10,11,IC),IC=1,3) / + S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/ + DATA (GB(10,11,IC),IC=1,3) / + S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/ + DATA (GA(10,12,IC),IC=1,3) / + S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/ + DATA (GB(10,12,IC),IC=1,3) / + 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 + DATA (GA(11,11,IC),IC=1,3) / + S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/ + DATA (GB(11,11,IC),IC=1,3) / + S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/ + DATA (GA(11,12,IC),IC=1,3) / + S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/ + DATA (GB(11,12,IC),IC=1,3) / + 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 + DATA (GA( 1,13,IC),IC=1,3) / + S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/ + DATA (GB( 1,13,IC),IC=1,3) / + S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/ + DATA (GA( 1,14,IC),IC=1,3) / + S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/ + DATA (GB( 1,14,IC),IC=1,3) / + 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 + DATA (GA( 2,13,IC),IC=1,3) / + S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/ + DATA (GB( 2,13,IC),IC=1,3) / + S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/ + DATA (GA( 2,14,IC),IC=1,3) / + S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/ + DATA (GB( 2,14,IC),IC=1,3) / + 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 + DATA (GA( 3,13,IC),IC=1,3) / + S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/ + DATA (GB( 3,13,IC),IC=1,3) / + S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/ + DATA (GA( 3,14,IC),IC=1,3) / + S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/ + DATA (GB( 3,14,IC),IC=1,3) / + 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 + DATA (GA( 4,13,IC),IC=1,3) / + S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/ + DATA (GB( 4,13,IC),IC=1,3) / + S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/ + DATA (GA( 4,14,IC),IC=1,3) / + S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/ + DATA (GB( 4,14,IC),IC=1,3) / + 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 + DATA (GA( 5,13,IC),IC=1,3) / + S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/ + DATA (GB( 5,13,IC),IC=1,3) / + S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/ + DATA (GA( 5,14,IC),IC=1,3) / + S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/ + DATA (GB( 5,14,IC),IC=1,3) / + 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 + DATA (GA( 6,13,IC),IC=1,3) / + S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/ + DATA (GB( 6,13,IC),IC=1,3) / + S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/ + DATA (GA( 6,14,IC),IC=1,3) / + S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/ + DATA (GB( 6,14,IC),IC=1,3) / + 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 + DATA (GA( 7,13,IC),IC=1,3) / + S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/ + DATA (GB( 7,13,IC),IC=1,3) / + S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/ + DATA (GA( 7,14,IC),IC=1,3) / + S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/ + DATA (GB( 7,14,IC),IC=1,3) / + 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 + DATA (GA( 8,13,IC),IC=1,3) / + S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/ + DATA (GB( 8,13,IC),IC=1,3) / + S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/ + DATA (GA( 8,14,IC),IC=1,3) / + S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/ + DATA (GB( 8,14,IC),IC=1,3) / + 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 + DATA (GA( 9,13,IC),IC=1,3) / + S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/ + DATA (GB( 9,13,IC),IC=1,3) / + S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/ + DATA (GA( 9,14,IC),IC=1,3) / + S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/ + DATA (GB( 9,14,IC),IC=1,3) / + 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 + DATA (GA(10,13,IC),IC=1,3) / + S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/ + DATA (GB(10,13,IC),IC=1,3) / + S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/ + DATA (GA(10,14,IC),IC=1,3) / + S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/ + DATA (GB(10,14,IC),IC=1,3) / + 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 + DATA (GA(11,13,IC),IC=1,3) / + S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/ + DATA (GB(11,13,IC),IC=1,3) / + S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/ + DATA (GA(11,14,IC),IC=1,3) / + S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/ + DATA (GB(11,14,IC),IC=1,3) / + 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 + DATA (GA( 1,15,IC),IC=1,3) / + S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/ + DATA (GB( 1,15,IC),IC=1,3) / + S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/ + DATA (GA( 1,16,IC),IC=1,3) / + S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/ + DATA (GB( 1,16,IC),IC=1,3) / + 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 + DATA (GA( 2,15,IC),IC=1,3) / + S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/ + DATA (GB( 2,15,IC),IC=1,3) / + S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/ + DATA (GA( 2,16,IC),IC=1,3) / + S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/ + DATA (GB( 2,16,IC),IC=1,3) / + 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 + DATA (GA( 3,15,IC),IC=1,3) / + S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/ + DATA (GB( 3,15,IC),IC=1,3) / + S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/ + DATA (GA( 3,16,IC),IC=1,3) / + S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/ + DATA (GB( 3,16,IC),IC=1,3) / + 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 + DATA (GA( 4,15,IC),IC=1,3) / + S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/ + DATA (GB( 4,15,IC),IC=1,3) / + S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/ + DATA (GA( 4,16,IC),IC=1,3) / + S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/ + DATA (GB( 4,16,IC),IC=1,3) / + 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 + DATA (GA( 5,15,IC),IC=1,3) / + S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/ + DATA (GB( 5,15,IC),IC=1,3) / + S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/ + DATA (GA( 5,16,IC),IC=1,3) / + S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/ + DATA (GB( 5,16,IC),IC=1,3) / + 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 + DATA (GA( 6,15,IC),IC=1,3) / + S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/ + DATA (GB( 6,15,IC),IC=1,3) / + S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/ + DATA (GA( 6,16,IC),IC=1,3) / + S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/ + DATA (GB( 6,16,IC),IC=1,3) / + 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 + DATA (GA( 7,15,IC),IC=1,3) / + S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/ + DATA (GB( 7,15,IC),IC=1,3) / + S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/ + DATA (GA( 7,16,IC),IC=1,3) / + S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/ + DATA (GB( 7,16,IC),IC=1,3) / + 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 + DATA (GA( 8,15,IC),IC=1,3) / + S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/ + DATA (GB( 8,15,IC),IC=1,3) / + S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/ + DATA (GA( 8,16,IC),IC=1,3) / + S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/ + DATA (GB( 8,16,IC),IC=1,3) / + 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 + DATA (GA( 9,15,IC),IC=1,3) / + S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/ + DATA (GB( 9,15,IC),IC=1,3) / + S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/ + DATA (GA( 9,16,IC),IC=1,3) / + S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/ + DATA (GB( 9,16,IC),IC=1,3) / + 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 + DATA (GA(10,15,IC),IC=1,3) / + S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/ + DATA (GB(10,15,IC),IC=1,3) / + S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/ + DATA (GA(10,16,IC),IC=1,3) / + S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/ + DATA (GB(10,16,IC),IC=1,3) / + 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 + DATA (GA(11,15,IC),IC=1,3) / + S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/ + DATA (GB(11,15,IC),IC=1,3) / + S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/ + DATA (GA(11,16,IC),IC=1,3) / + S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/ + DATA (GB(11,16,IC),IC=1,3) / + S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/ + +C ------------------------------------------------------------------ + DATA (( XP( J,K),J=1,6), K=1,6) / + S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03, + S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03, + S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03, + S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02, + S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03, + S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02, + S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03, + S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02, + S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02, + S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01, + S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03, + S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 / +C +C +C* 1.0 PLANCK FUNCTIONS AND GRADIENTS +C ------------------------------ +C + 100 CONTINUE +C + 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(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) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS + REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS + REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS + REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION + REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION + REAL*8 PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION + REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT + REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY + REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB) + REAL*8 PTAVE(KDLON,KFLEV) ! TEMPERATURE + REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL*8 PGASUR(KDLON,8,2) ! PADE APPROXIMANTS + REAL*8 PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS + REAL*8 PGATOP(KDLON,8,2) ! PADE APPROXIMANTS + REAL*8 PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS +C + REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX + REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM + REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES +C----------------------------------------------------------------------- +C LOCAL VARIABLES: + REAL*8 ZADJD(KDLON,KFLEV+1) + REAL*8 ZADJU(KDLON,KFLEV+1) + REAL*8 ZDBDT(KDLON,Ninter,KFLEV) + REAL*8 ZDISD(KDLON,KFLEV+1) + REAL*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(KUAER,KTRAER + R , PABCU,PDBSL,PGA,PGB + S , ZADJD,ZADJU,PCNTRB,ZDBDT) +C* CONTRIBUTION FROM DISTANT LAYERS +C + CALL LWVD(KUAER,KTRAER + R , PABCU,ZDBDT,PGA,PGB + S , PCNTRB,ZDISD,ZDISU) +C +C* EXCHANGE WITH THE BOUNDARIES +C + CALL LWVB(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(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) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS + REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS + REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS + REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS + REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS + REAL*8 PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION + REAL*8 PBSUI(KDLON) ! SURFACE PLANCK FUNCTION + REAL*8 PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION + REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS + REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS + REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY + REAL*8 PPMB(KDLON,KFLEV+1) ! PRESSURE MB + REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS + REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS + REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS + REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS +C + REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES + REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM +C +C* LOCAL VARIABLES: +C + REAL*8 ZBGND(KDLON) + REAL*8 ZFD(KDLON) + REAL*8 ZFN10(KDLON) + REAL*8 ZFU(KDLON) + REAL*8 ZTT(KDLON,NTRA) + REAL*8 ZTT1(KDLON,NTRA) + REAL*8 ZTT2(KDLON,NTRA) + REAL*8 ZUU(KDLON,NUA) + REAL*8 ZCNSOL(KDLON) + REAL*8 ZCNTOP(KDLON) +C + INTEGER jk, jl, ja + INTEGER jstra, jstru + INTEGER ind1, ind2, ind3, ind4, in, jlim + REAL*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(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(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(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(KUAER,KTRAER + S , PABCU,PDBDT + R , PGA,PGB + S , PCNTRB,PDISD,PDISU) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS + REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT + REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS +C + REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX + REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS + REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS +C +C* LOCAL VARIABLES: +C + REAL*8 ZGLAYD(KDLON) + REAL*8 ZGLAYU(KDLON) + REAL*8 ZTT(KDLON,NTRA) + REAL*8 ZTT1(KDLON,NTRA) + REAL*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*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(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(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ) + 2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1) + ELSE + CALL LWTTM(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(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(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL) + 2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1) + ELSE + CALL LWTTM(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(KUAER,KTRAER + R , PABCU,PDBSL,PGA,PGB + S , PADJD,PADJU,PCNTRB,PDBDT) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS + REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT + REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS +C + REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS + REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS + REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX + REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT +C +C* LOCAL ARRAYS: +C + REAL*8 ZGLAYD(KDLON) + REAL*8 ZGLAYU(KDLON) + REAL*8 ZTT(KDLON,NTRA) + REAL*8 ZTT1(KDLON,NTRA) + REAL*8 ZTT2(KDLON,NTRA) + REAL*8 ZUU(KDLON,NUA) +C + INTEGER jk, jl, ja, im12, ind, inu, ixu, jg + INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu + REAL*8 zwtr +c +C* Data Block: +c + REAL*8 WG1(2) + SAVE WG1 + DATA (WG1(jk),jk=1,2) /1.0, 1.0/ +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(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(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(PGA,PGB,PUU, PTT) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 O1H, O2H + PARAMETER (O1H=2230.) + PARAMETER (O2H=100.) + REAL*8 RPIALF0 + PARAMETER (RPIALF0=2.0) +C +C* ARGUMENTS: +C + REAL*8 PUU(KDLON,NUA) + REAL*8 PTT(KDLON,NTRA) + REAL*8 PGA(KDLON,8,2) + REAL*8 PGB(KDLON,8,2) +C +C* LOCAL VARIABLES: +C + REAL*8 zz, zxd, zxn + REAL*8 zpu, zpu10, zpu11, zpu12, zpu13 + REAL*8 zeu, zeu10, zeu11, zeu12, zeu13 + REAL*8 zx, zy, zsq1, zsq2, zvxy, zuxy + REAL*8 zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o + REAL*8 zsqn21, zodn21, zsqh42, zodh42 + REAL*8 zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12 + REAL*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 + 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(PGA,PGB,PUU1,PUU2, PTT) + IMPLICIT none +#include "dimensions.h" +#include "dimphy.h" +#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*8 O1H, O2H + PARAMETER (O1H=2230.) + PARAMETER (O2H=100.) + REAL*8 RPIALF0 + PARAMETER (RPIALF0=2.0) +C +C* ARGUMENTS: +C + REAL*8 PGA(KDLON,8,2) ! PADE APPROXIMANTS + REAL*8 PGB(KDLON,8,2) ! PADE APPROXIMANTS + REAL*8 PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1 + REAL*8 PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2 + REAL*8 PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS +C +C* LOCAL VARIABLES: +C + INTEGER ja, jl + REAL*8 zz, zxd, zxn + REAL*8 zpu, zpu10, zpu11, zpu12, zpu13 + REAL*8 zeu, zeu10, zeu11, zeu12, zeu13 + REAL*8 zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2 + REAL*8 zxch4, zych4, zsqh41, zodh41 + REAL*8 zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42 + REAL*8 zsqn22, zodn22, za11, zttf11, za12, zttf12 + REAL*8 zuu11, zuu12 +C ------------------------------------------------------------------ +C +C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION +C ----------------------------------------------- +C + 100 CONTINUE +C +C + 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/trunk/libf/phylmd/radopt.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/radopt.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/radopt.h (revision 524) @@ -0,0 +1,9 @@ +! +! $Header$ +! + LOGICAL LEVOIGT + PARAMETER (LEVOIGT=.FALSE.) + INTEGER NOVLP + PARAMETER (NOVLP=1) + INTEGER KAER + PARAMETER (KAER=0) Index: /LMDZ4/trunk/libf/phylmd/ran0_vec.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/ran0_vec.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/ran0_vec.F (revision 524) @@ -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/trunk/libf/phylmd/read_pstoke.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/read_pstoke.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/read_pstoke.F (revision 524) @@ -0,0 +1,433 @@ +! +! $Header$ +! +c +c + subroutine read_pstoke(irec, + . zrec,zklono,zklevo,airefi,phisfi, + . t,mfu,mfd,en_u,de_u,en_d,de_d,coefh, + . frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf) + + + 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" +#include "dimphy.h" + + integer*4 klono,klevo,imo,jmo + parameter (imo=iim/2,jmo=(jjm+1)/2) + parameter(klono=(jmo-1)*imo+2,klevo=llm) + REAL*4 phisfi(klono) + REAL*4 phisfi2(imo,jmo+1),airefi2(imo,jmo+1) + + REAL*4 mfu(klono,klevo), mfd(klono,klevo) + REAL*4 en_u(klono,klevo), de_u(klono,klevo) + REAL*4 en_d(klono,klevo), de_d(klono,klevo) + REAL*4 coefh(klono,klevo) + + REAL*4 mfu2(imo,jmo+1,klevo), mfd2(imo,jmo+1,klevo) + REAL*4 en_u2(imo,jmo+1,klevo), de_u2(imo,jmo+1,klevo) + REAL*4 en_d2(imo,jmo+1,klevo), de_d2(imo,jmo+1,klevo) + REAL*4 coefh2(imo,jmo+1,klevo) + + REAL*4 pl(klevo) + integer irec + integer*4 xid,yid,zid,tid + real zrec,zklono,zklevo,zim,zjm + integer*4 ncrec,ncklono,ncklevo,ncim,ncjm + + real*4 airefi(klono) + character namedim + +c !! attention !! +c attention il y a aussi le pb de def klono +c dim de phis?? + + + REAL*4 frac_impa(klono,klevo), frac_nucl(klono,klevo) + REAL*4 frac_impa2(imo,jmo+1,klevo), + . frac_nucl2(imo,jmo+1,klevo) + REAL*4 pyu1(klono), pyv1(klono) + REAL*4 pyu12(imo,jmo+1), pyv12(imo,jmo+1) + REAL*4 ftsol(klono,nbsrf) + REAL*4 psrf(klono,nbsrf) + REAL*4 ftsol1(klono),ftsol2(klono),ftsol3(klono),ftsol4(klono) + REAL*4 psrf1(klono),psrf2(klono),psrf3(klono),psrf4(klono) + REAL*4 ftsol12(imo,jmo+1),ftsol22(imo,jmo+1), + . ftsol32(imo,jmo+1), + . ftsol42(imo,jmo+1) + REAL*4 psrf12(imo,jmo+1),psrf22(imo,jmo+1),psrf32(imo,jmo+1), + . psrf42(imo,jmo+1) + REAL*4 t(klono,klevo) + REAL*4 t2(imo,jmo+1) + integer ncidp + save ncidp + integer varidt + integer varidmfu, varidmfd, varidps, varidenu, variddeu + integer varidend,varidded,varidch,varidfi,varidfn + 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 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 + + ncidp=NCOPN('phystoke.nc',NCNOWRIT,rcode) + + varidps=NCVID(ncidp,'phis',rcode) + print*,'ncidp,varidps',ncidp,varidps + + varidpl=NCVID(ncidp,'sig_s',rcode) + print*,'ncidp,varidpl',ncidp,varidpl + + varidai=NCVID(ncidp,'aire',rcode) + print*,'ncidp,varidai',ncidp,varidai + + varidt=NCVID(ncidp,'t',rcode) + print*,'ncidp,varidt',ncidp,varidt + varidmfu=NCVID(ncidp,'mfu',rcode) + print*,'ncidp,varidmfu',ncidp,varidmfu + + varidmfd=NCVID(ncidp,'mfd',rcode) + print*,'ncidp,varidmfd',ncidp,varidmfd + + varidenu=NCVID(ncidp,'en_u',rcode) + print*,'ncidp,varidenu',ncidp,varidenu + + variddeu=NCVID(ncidp,'de_u',rcode) + print*,'ncidp,variddeu',ncidp,variddeu + + varidend=NCVID(ncidp,'en_d',rcode) + print*,'ncidp,varidend',ncidp,varidend + + varidded=NCVID(ncidp,'de_d',rcode) + print*,'ncidp,varidded',ncidp,varidded + + varidch=NCVID(ncidp,'coefh',rcode) + print*,'ncidp,varidch',ncidp,varidch + + varidfi=NCVID(ncidp,'frac_impa',rcode) + print*,'ncidp,varidfi',ncidp,varidfi + + varidfn=NCVID(ncidp,'frac_nucl',rcode) + print*,'ncidp,varidfn',ncidp,varidfn + + varidyu1=NCVID(ncidp,'pyu1',rcode) + print*,'ncidp,varidyu1',ncidp,varidyu1 + + varidyv1=NCVID(ncidp,'pyv1',rcode) + print*,'ncidp,varidyv1',ncidp,varidyv1 + + varidfts1=NCVID(ncidp,'ftsol1',rcode) + print*,'ncidp,varidfts1',ncidp,varidfts1 + + varidfts2=NCVID(ncidp,'ftsol2',rcode) + print*,'ncidp,varidfts2',ncidp,varidfts2 + + varidfts3=NCVID(ncidp,'ftsol3',rcode) + print*,'ncidp,varidfts3',ncidp,varidfts3 + + varidfts4=NCVID(ncidp,'ftsol4',rcode) + print*,'ncidp,varidfts4',ncidp,varidfts4 + + varidpsr1=NCVID(ncidp,'psrf1',rcode) + print*,'ncidp,varidpsr1',ncidp,varidpsr1 + + varidpsr2=NCVID(ncidp,'psrf2',rcode) + print*,'ncidp,varidpsr2',ncidp,varidpsr2 + + varidpsr3=NCVID(ncidp,'psrf3',rcode) + print*,'ncidp,varidpsr3',ncidp,varidpsr3 + + varidpsr4=NCVID(ncidp,'psrf4',rcode) + 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 + + status=NF_GET_VARA_REAL(ncidp,varidpl,1,zklevo,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 phis + status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*1,phisfi2) +c call dump2d(iip1-1,jjp1,phisfi2,'PHISNC') + call gr_ecrit_fi(1,klono,imo,jmo+1,phisfi2,phisfi) + +c aire + status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2) +c call correctbid(iim,jjp1*1,airefi2) +c call dump2d(iip1-1,jjp1,airefi2,'AIRENC') + 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 frac_impa + + status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*klevo,frac_impa2) +c call dump2d(iip1-1,jjp1,frac_impa2,'FINC COUCHE 1') + call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_impa2,frac_impa) + +c frac_nucl + + status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*klevo,frac_nucl2) +c call dump2d(iip1-1,jjp1,frac_nucl2,'FINC COUCHE 1') + call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_nucl2,frac_nucl) + +c abder t + status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2) + call gr_ecrit_fi(klevo,klono,imo,jmo+1,t2,t) + +c mfu + status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*klevo,mfu2) +c call dump2d(iip1-1,jjp1,mfu2,'MFUNC COUCHE 1') + call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfu2,mfu) + +c mfd + status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*klevo,mfd2) +c call dump2d(iip1-1,jjp1,mfd2,'MFDNC COUCHE 1') + call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfd2,mfd) + +c en_u + status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*klevo,en_u2) +c call dump2d(iip1-1,jjp1,en_u2,'ENUNC COUCHE 1') + call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_u2,en_u) + +c de_u + status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*klevo,de_u2) +c call dump2d(iip1-1,jjp1,de_u2,'DEUNC COUCHE 1') + call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_u2,de_u) + +c en_d + status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*klevo,en_d2) +c call dump2d(iip1-1,jjp1,en_d2,'ENDNC COUCHE 1') + call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_d2,en_d) + +c de_d + status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*klevo,de_d2) +c call dump2d(iip1-1,jjp1,de_d2,'DEDNC COUCHE 1') + call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_d2,de_d) + +c coefh + status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*klevo,coefh2) +c call dump2d(iip1-1,jjp1,coefh2,'CHNC COUCHE 1') + call gr_ecrit_fi(klevo,klono,imo,jmo+1,coefh2,coefh) + + start(3)=irec + start(4)=0 + count(3)=1 + count(4)=0 + +c pyu1 + status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*1,pyu12) +c call dump2d(iip1-1,jjp1,pyu12,'PYU1NC') + call gr_ecrit_fi(1,klono,imo,jmo+1,pyu12,pyu1) + +c pyv1 + status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*1,pyv12) +c call dump2d(iip1-1,jjp1,pyv12,'PYV1NC') + call gr_ecrit_fi(1,klono,imo,jmo+1,pyv12,pyv1) + +c ftsol1 + status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*1,ftsol12) +c call dump2d(iip1-1,jjp1,ftsol12,'FTS1NC') + call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol12,ftsol1) + +c ftsol2 + status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*1,ftsol22) +c call dump2d(iip1-1,jjp1,ftsol22,'FTS2NC') + call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol22,ftsol2) + +c ftsol3 + status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*1,ftsol32) +c call dump2d(iip1-1,jjp1,ftsol32,'FTS3NC') + call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol32,ftsol3) + +c ftsol4 + status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*1,ftsol42) +c call dump2d(iip1-1,jjp1,ftsol42,'FTS4NC') + call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol42,ftsol4) + +c psrf1 + status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*1,psrf12) +c call dump2d(iip1-1,jjp1,psrf12,'PSRF1NC') + call gr_ecrit_fi(1,klono,imo,jmo+1,psrf12,psrf1) + +c psrf2 + status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*1,psrf22) +c call dump2d(iip1-1,jjp1,psrf22,'PSRF2NC') + call gr_ecrit_fi(1,klono,imo,jmo+1,psrf22,psrf2) + +c psrf3 + status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*1,psrf32) +c call dump2d(iip1-1,jjp1,psrf32,'PSRF3NC') + call gr_ecrit_fi(1,klono,imo,jmo+1,psrf32,psrf3) + +c psrf4 + status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42) +c print*,'WARNING!!! Correction bidon pour palier a un ' +c print*,'probleme dans la creation des fichiers nc' +c call correctbid(iim,jjp1*1,psrf42) +c call dump2d(iip1-1,jjp1,psrf42,'PSRF4NC') + 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/trunk/libf/phylmd/read_pstoke0.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/read_pstoke0.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/read_pstoke0.F (revision 524) @@ -0,0 +1,360 @@ +! +! $Header$ +! +c +c + subroutine read_pstoke0(irec, + . zrec,zkon,zkev,airefi,phisfi, + . t,mfu,mfd,en_u,de_u,en_d,de_d,coefh, + . frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf) + + + 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" +#include "dimphy.h" + + integer*4 kon,kev,zkon,zkev + parameter(kon=iim*(jjm-1)+2,kev=llm) + REAL*4 phisfi(kon) + REAL*4 phisfi2(iim,jjm+1),airefi2(iim,jjm+1) + + REAL*4 mfu(kon,kev), mfd(kon,kev) + REAL*4 en_u(kon,kev), de_u(kon,kev) + REAL*4 en_d(kon,kev), de_d(kon,kev) + REAL*4 coefh(kon,kev) + REAL*4 t(kon,kev) + + REAL*4 mfu2(iim,jjm+1,kev), mfd2(iim,jjm+1,kev) + REAL*4 en_u2(iim,jjm+1,kev), de_u2(iim,jjm+1,kev) + REAL*4 en_d2(iim,jjm+1,kev), de_d2(iim,jjm+1,kev) + REAL*4 coefh2(iim,jjm+1,kev) + REAL*4 t2(iim,jjm+1,kev) + + REAL*4 pl(kev) + integer irec + integer*4 xid,yid,zid,tid + integer*4 zrec,zim,zjm + integer*4 ncrec,nckon,nckev,ncim,ncjm + + real*4 airefi(kon) + character namedim + +c !! attention !! +c attention il y a aussi le pb de def kon +c dim de phis?? + + REAL*4 frac_impa(kon,kev), frac_nucl(kon,kev) + REAL*4 frac_impa2(iim,jjm+1,kev), + . frac_nucl2(iim,jjm+1,kev) + REAL*4 pyu1(kon), pyv1(kon) + REAL*4 pyu12(iim,jjm+1), pyv12(iim,jjm+1) + REAL*4 ftsol(kon,nbsrf) + REAL*4 psrf(kon,nbsrf) + REAL*4 ftsol1(kon),ftsol2(kon),ftsol3(kon),ftsol4(kon) + REAL*4 psrf1(kon),psrf2(kon),psrf3(kon),psrf4(kon) + REAL*4 ftsol12(iim,jjm+1),ftsol22(iim,jjm+1), + . ftsol32(iim,jjm+1), + . ftsol42(iim,jjm+1) + REAL*4 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 + 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 + 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 + + ncidp=NCOPN('phystoke.nc',NCNOWRIT,rcode) + + varidps=NCVID(ncidp,'phis',rcode) + print*,'ncidp,varidps',ncidp,varidps + + varidpl=NCVID(ncidp,'sig_s',rcode) + print*,'ncidp,varidpl',ncidp,varidpl + + varidai=NCVID(ncidp,'aire',rcode) + print*,'ncidp,varidai',ncidp,varidai + + varidmfu=NCVID(ncidp,'mfu',rcode) + print*,'ncidp,varidmfu',ncidp,varidmfu + + varidt=NCVID(ncidp,'t',rcode) + print*,'ncidp,varidt',ncidp,varidt + + varidmfd=NCVID(ncidp,'mfd',rcode) + print*,'ncidp,varidmfd',ncidp,varidmfd + + varidenu=NCVID(ncidp,'en_u',rcode) + print*,'ncidp,varidenu',ncidp,varidenu + + variddeu=NCVID(ncidp,'de_u',rcode) + print*,'ncidp,variddeu',ncidp,variddeu + + varidend=NCVID(ncidp,'en_d',rcode) + print*,'ncidp,varidend',ncidp,varidend + + varidded=NCVID(ncidp,'de_d',rcode) + print*,'ncidp,varidded',ncidp,varidded + + varidch=NCVID(ncidp,'coefh',rcode) + print*,'ncidp,varidch',ncidp,varidch + + varidfi=NCVID(ncidp,'frac_impa',rcode) + print*,'ncidp,varidfi',ncidp,varidfi + + varidfn=NCVID(ncidp,'frac_nucl',rcode) + print*,'ncidp,varidfn',ncidp,varidfn + + varidyu1=NCVID(ncidp,'pyu1',rcode) + print*,'ncidp,varidyu1',ncidp,varidyu1 + + varidyv1=NCVID(ncidp,'pyv1',rcode) + print*,'ncidp,varidyv1',ncidp,varidyv1 + + varidfts1=NCVID(ncidp,'ftsol1',rcode) + print*,'ncidp,varidfts1',ncidp,varidfts1 + + varidfts2=NCVID(ncidp,'ftsol2',rcode) + print*,'ncidp,varidfts2',ncidp,varidfts2 + + varidfts3=NCVID(ncidp,'ftsol3',rcode) + print*,'ncidp,varidfts3',ncidp,varidfts3 + + varidfts4=NCVID(ncidp,'ftsol4',rcode) + print*,'ncidp,varidfts4',ncidp,varidfts4 + + varidpsr1=NCVID(ncidp,'psrf1',rcode) + print*,'ncidp,varidpsr1',ncidp,varidpsr1 + + varidpsr2=NCVID(ncidp,'psrf2',rcode) + print*,'ncidp,varidpsr2',ncidp,varidpsr2 + + varidpsr3=NCVID(ncidp,'psrf3',rcode) + print*,'ncidp,varidpsr3',ncidp,varidpsr3 + + varidpsr4=NCVID(ncidp,'psrf4',rcode) + 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 phis + status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2) + call gr_ecrit_fi(1,kon,iim,jjm+1,phisfi2,phisfi) + +c aire + status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2) + 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 frac_impa + + status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2) + call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_impa2,frac_impa) + +c frac_nucl + + status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2) + call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_nucl2,frac_nucl) + +c abder t + status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2) + call gr_ecrit_fi(kev,kon,iim,jjm+1,t2,t) + +c mfu + status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2) + call gr_ecrit_fi(kev,kon,iim,jjm+1,mfu2,mfu) + +c mfd + status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2) + call gr_ecrit_fi(kev,kon,iim,jjm+1,mfd2,mfd) + +c en_u + status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2) + call gr_ecrit_fi(kev,kon,iim,jjm+1,en_u2,en_u) + +c de_u + status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2) + call gr_ecrit_fi(kev,kon,iim,jjm+1,de_u2,de_u) + +c en_d + status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2) + call gr_ecrit_fi(kev,kon,iim,jjm+1,en_d2,en_d) + +c de_d + status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2) + call gr_ecrit_fi(kev,kon,iim,jjm+1,de_d2,de_d) + +c coefh + print*,'LECTURE de coefh a irec =',irec + status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2) + call gr_ecrit_fi(kev,kon,iim,jjm+1,coefh2,coefh) + + start(3)=irec + start(4)=0 + count(3)=1 + count(4)=0 + +c pyu1 + print*,'LECTURE de yu1 a irec =',irec + status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12) + call gr_ecrit_fi(1,kon,iim,jjm+1,pyu12,pyu1) + +c pyv1 + print*,'LECTURE de yv1 a irec =',irec + status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12) + call gr_ecrit_fi(1,kon,iim,jjm+1,pyv12,pyv1) + +c ftsol1 + print*,'LECTURE de ftsol1 a irec =',irec + status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12) + call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol12,ftsol1) + +c ftsol2 + print*,'LECTURE de ftsol2 a irec =',irec + status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22) + call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol22,ftsol2) + +c ftsol3 + print*,'LECTURE de ftsol3 a irec =',irec + status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32) + call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol32,ftsol3) + +c ftsol4 + status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42) + call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol42,ftsol4) + +c psrf1 + status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12) +c call dump2d(iip1-1,jjm+1,psrf12,'PSRF1NC') + call gr_ecrit_fi(1,kon,iim,jjm+1,psrf12,psrf1) + +c psrf2 + status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22) +c call dump2d(iip1-1,jjm+1,psrf22,'PSRF2NC') + call gr_ecrit_fi(1,kon,iim,jjm+1,psrf22,psrf2) + +c psrf3 + status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32) + call gr_ecrit_fi(1,kon,iim,jjm+1,psrf32,psrf3) + +c psrf4 + status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42) + 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) + 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/trunk/libf/phylmd/readsulfate.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/readsulfate.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/readsulfate.F (revision 524) @@ -0,0 +1,579 @@ +! +! $Header$ +! + SUBROUTINE readsulfate (r_day, first, sulfate) + + IMPLICIT none + +c Content: +c -------- +c This routine reads in monthly mean values of sulfate aerosols and +c returns a linearly interpolated dayly-mean field. +c +c +c Author: +c ------- +c Johannes Quaas (quaas@lmd.jussieu.fr) +c 26/04/01 +c +c Modifications: +c -------------- +c 21/06/01: Make integrations of more than one year possible ;-) +c ATTENTION!! runs are supposed to start with Jan, 1. 1930 +c (rday=1) +c +c 27/06/01: Correction: The model always has 360 days per year! +c 27/06/01: SO4 concentration rather than mixing ratio +c 27/06/01: 10yr-mean-values to interpolate +c 20/08/01: Correct the error through integer-values in interpolations +c 21/08/01: Introduce flag to read in just one decade +c +c Include-files: +c -------------- +#include "YOMCST.h" +#include "chem.h" +#include "dimensions.h" +#include "dimphy.h" +#include "temps.h" +c +c Input: +c ------ + REAL*8 r_day ! Day of integration + LOGICAL first ! First timestep + ! (and therefore initialization necessary) +c +c Output: +c ------- + REAL*8 sulfate (klon, klev) ! Mass of sulfate (monthly mean data, + ! from file) [ug SO4/m3] +c +c Local Variables: +c ---------------- + INTEGER i, ig, k, it + INTEGER j, iday, ny, iyr + parameter (ny=jjm+1) + + INTEGER ismaller + INTEGER idec1, idec2 ! The two decadal data read ini + CHARACTER*4 cyear + + INTEGER im, day1, day2, im2 + REAL*8 so4_1(iim, jjm+1, klev, 12) + REAL*8 so4_2(iim, jjm+1, klev, 12) ! The sulfate distributions + + REAL*8 so4(klon, klev, 12) ! SO4 in right dimension + SAVE so4 + REAL*8 so4_out(klon, klev) + SAVE so4_out + + LOGICAL lnewday + LOGICAL lonlyone + PARAMETER (lonlyone=.FALSE.) + + iday = INT(r_day) + + ! Get the year of the run + iyr = iday/360 + + ! Get the day of the actual year: + iday = iday-iyr*360 + + ! 0.02 is about 0.5/24, namly less than half an hour + lnewday = (r_day-FLOAT(iday).LT.0.02) + +! --------------------------------------------- +! All has to be done only, if a new day begins! +! --------------------------------------------- + + IF (lnewday.OR.first) THEN + + im = iday/30 +1 ! the actual month + ! annee_ref is the initial year (defined in temps.h) + iyr = iyr + annee_ref + + ! Do I have to read new data? (Is this the first day of a year?) + IF (first.OR.iday.EQ.1.) THEN + ! Initialize values + DO it=1,12 + DO k=1,klev + DO i=1,klon + so4(i,k,it)=0. + ENDDO + ENDDO + ENDDO + + ! Read in data: + ! a) from actual 10-yr-period + + idec1 = (iyr-1900)/10 + IF (idec1.LT.10) THEN + cyear='19'//char(idec1+48)//'0' + ELSE + cyear='20'//char(idec1-10+48)//'0' + ENDIF + CALL getso4fromfile(cyear, so4_1) + + + ! If to read two decades: + IF (.NOT.lonlyone) THEN + idec2=idec1+1 + + ! b) from the next following one + IF (idec2.LT.10) THEN + cyear='19'//char(idec2+48)//'0' + ELSE + cyear='20'//char(idec2-10+48)//'0' + ENDIF + CALL getso4fromfile(cyear, so4_2) + + ! Interpolate linarily to the actual year: + DO it=1,12 + DO k=1,klev + DO j=1,jjm + DO i=1,iim + so4_1(i,j,k,it)=so4_1(i,j,k,it) + . - FLOAT(iyr-1900-10*idec1)/10. + . * (so4_1(i,j,k,it) - so4_2(i,j,k,it)) + ENDDO + ENDDO + ENDDO + ENDDO + + ENDIF !lonlyone + + ! Transform the horizontal 2D-field into the physics-field + ! (Also the levels and the latitudes have to be inversed) + + DO it=1,12 + DO k=1, klev + ! a) at the poles, use the zonal mean: + DO i=1,iim + ! North pole + so4(1,k,it)=so4(1,k,it)+so4_1(i,jjm+1,klev+1-k,it) + ! South pole + so4(klon,k,it)=so4(klon,k,it)+so4_1(i,1,klev+1-k,it) + ENDDO + so4(1,k,it)=so4(1,k,it)/FLOAT(iim) + so4(klon,k,it)=so4(klon,k,it)/FLOAT(iim) + + ! b) the values between the poles: + ig=1 + DO j=2,jjm + DO i=1,iim + ig=ig+1 + if (ig.gt.klon) write (*,*) 'shit' + so4(ig,k,it) = so4_1(i,jjm+1-j,klev+1-k,it) + ENDDO + ENDDO + IF (ig.NE.klon-1) STOP 'Error in readsulfate (var conversion)' + ENDDO ! Loop over k (vertical) + ENDDO ! Loop over it (months) + + + ENDIF ! Had to read new data? + + + ! Interpolate to actual day: + IF (iday.LT.im*30-15) THEN + ! in the first half of the month use month before and actual month + im2=im-1 + day2 = im2*30-15 + day1 = im2*30+15 + IF (im2.LE.0) THEN + ! the month is january, thus the month before december + im2=12 + ENDIF + DO k=1,klev + DO i=1,klon + sulfate(i,k) = so4(i,k,im2) + . - FLOAT(iday-day2)/FLOAT(day1-day2) + . * (so4(i,k,im2) - so4(i,k,im)) + IF (sulfate(i,k).LT.0.) THEN + IF (iday-day2.LT.0.) write(*,*) 'iday-day2',iday-day2 + IF (so4(i,k,im2) - so4(i,k,im).LT.0.) + . write(*,*) 'so4(i,k,im2) - so4(i,k,im)', + . so4(i,k,im2) - so4(i,k,im) + IF (day1-day2.LT.0.) write(*,*) 'day1-day2',day1-day2 + stop 'sulfate' + endif + ENDDO + ENDDO + ELSE + ! the second half of the month + im2=im+1 + IF (im2.GT.12) THEN + ! the month is december, the following thus january + im2=1 + ENDIF + day2 = im*30-15 + day1 = im*30+15 + DO k=1,klev + DO i=1,klon + sulfate(i,k) = so4(i,k,im2) + . - FLOAT(iday-day2)/FLOAT(day1-day2) + . * (so4(i,k,im2) - so4(i,k,im)) + IF (sulfate(i,k).LT.0.) THEN + IF (iday-day2.LT.0.) write(*,*) 'iday-day2',iday-day2 + IF (so4(i,k,im2) - so4(i,k,im).LT.0.) + . write(*,*) 'so4(i,k,im2) - so4(i,k,im)', + . so4(i,k,im2) - so4(i,k,im) + IF (day1-day2.LT.0.) write(*,*) 'day1-day2',day1-day2 + stop 'sulfate' + endif + ENDDO + ENDDO + ENDIF + + + ! The sulfate concentration [molec cm-3] is read in. + ! Convert it into mass [ug SO4/m3] + ! masse_so4 in [g/mol], n_avogadro in [molec/mol] + DO k=1,klev + DO i=1,klon + sulfate(i,k) = sulfate(i,k)*masse_so4 + . /n_avogadro*1.e+12 + so4_out(i,k) = sulfate(i,k) + IF (so4_out(i,k).LT.0) + . stop 'WAS SOLL DER SCHEISS ? ' + ENDDO + ENDDO + ELSE ! if no new day, use old data: + DO k=1,klev + DO i=1,klon + sulfate(i,k) = so4_out(i,k) + IF (so4_out(i,k).LT.0) + . stop 'WAS SOLL DER SCHEISS ? ' + ENDDO + ENDDO + + + ENDIF ! Did I have to do anything (was it a new day?) + + RETURN + END + + + + + +c----------------------------------------------------------------------------- +c Read in /calculate pre-industrial values of sulfate +c----------------------------------------------------------------------------- + + SUBROUTINE readsulfate_preind (r_day, first, pi_sulfate) + + IMPLICIT none + +c Content: +c -------- +c This routine reads in monthly mean values of sulfate aerosols and +c returns a linearly interpolated dayly-mean field. +c +c It does so for the preindustriel values of the sulfate, to a large part +c analogous to the routine readsulfate above. +c +c Only Pb: Variables must be saved and don t have to be overwritten! +c +c Author: +c ------- +c Johannes Quaas (quaas@lmd.jussieu.fr) +c 26/06/01 +c +c Modifications: +c -------------- +c see above +c +c Include-files: +c -------------- +#include "YOMCST.h" +#include "chem.h" +#include "dimensions.h" +#include "dimphy.h" +#include "temps.h" +c +c Input: +c ------ + REAL*8 r_day ! Day of integration + LOGICAL first ! First timestep + ! (and therefore initialization necessary) +c +c Output: +c ------- + REAL*8 pi_sulfate (klon, klev) ! Number conc. sulfate (monthly mean data, + ! from file) +c +c Local Variables: +c ---------------- + INTEGER i, ig, k, it + INTEGER j, iday, ny, iyr + parameter (ny=jjm+1) + + INTEGER im, day1, day2, im2, ismaller + REAL*8 pi_so4_1(iim, jjm+1, klev, 12) + + REAL*8 pi_so4(klon, klev, 12) ! SO4 in right dimension + SAVE pi_so4 + REAL*8 pi_so4_out(klon, klev) + SAVE pi_so4_out + + CHARACTER*4 cyear + LOGICAL lnewday + + + + iday = INT(r_day) + + ! Get the year of the run + iyr = iday/360 + + ! Get the day of the actual year: + iday = iday-iyr*360 + + ! 0.02 is about 0.5/24, namly less than half an hour + lnewday = (r_day-FLOAT(iday).LT.0.02) + +! --------------------------------------------- +! All has to be done only, if a new day begins! +! --------------------------------------------- + + IF (lnewday.OR.first) THEN + + im = iday/30 +1 ! the actual month + + ! annee_ref is the initial year (defined in temps.h) + iyr = iyr + annee_ref + + + IF (first) THEN + cyear='.nat' + CALL getso4fromfile(cyear,pi_so4_1) + + ! Transform the horizontal 2D-field into the physics-field + ! (Also the levels and the latitudes have to be inversed) + + ! Initialize field + DO it=1,12 + DO k=1,klev + DO i=1,klon + pi_so4(i,k,it)=0. + ENDDO + ENDDO + ENDDO + + write (*,*) 'preind: finished reading', FLOAT(iim) + DO it=1,12 + DO k=1, klev + ! a) at the poles, use the zonal mean: + DO i=1,iim + ! North pole + pi_so4(1,k,it)=pi_so4(1,k,it)+pi_so4_1(i,jjm+1,klev+1-k,it) + ! South pole + pi_so4(klon,k,it)=pi_so4(klon,k,it)+pi_so4_1(i,1,klev+1-k,it) + ENDDO + pi_so4(1,k,it)=pi_so4(1,k,it)/FLOAT(iim) + pi_so4(klon,k,it)=pi_so4(klon,k,it)/FLOAT(iim) + + ! b) the values between the poles: + ig=1 + DO j=2,jjm + DO i=1,iim + ig=ig+1 + if (ig.gt.klon) write (*,*) 'shit' + pi_so4(ig,k,it) = pi_so4_1(i,jjm+1-j,klev+1-k,it) + ENDDO + ENDDO + IF (ig.NE.klon-1) STOP 'Error in readsulfate (var conversion)' + ENDDO ! Loop over k (vertical) + ENDDO ! Loop over it (months) + + ENDIF ! Had to read new data? + + + ! Interpolate to actual day: + IF (iday.LT.im*30-15) THEN + ! in the first half of the month use month before and actual month + im2=im-1 + day1 = im2*30+15 + day2 = im2*30-15 + IF (im2.LE.0) THEN + ! the month is january, thus the month before december + im2=12 + ENDIF + DO k=1,klev + DO i=1,klon + pi_sulfate(i,k) = pi_so4(i,k,im2) + . - FLOAT(iday-day2)/FLOAT(day1-day2) + . * (pi_so4(i,k,im2) - pi_so4(i,k,im)) + IF (pi_sulfate(i,k).LT.0.) THEN + IF (iday-day2.LT.0.) write(*,*) 'iday-day2',iday-day2 + IF (pi_so4(i,k,im2) - pi_so4(i,k,im).LT.0.) + . write(*,*) 'pi_so4(i,k,im2) - pi_so4(i,k,im)', + . pi_so4(i,k,im2) - pi_so4(i,k,im) + IF (day1-day2.LT.0.) write(*,*) 'day1-day2',day1-day2 + stop 'pi_sulfate' + endif + ENDDO + ENDDO + ELSE + ! the second half of the month + im2=im+1 + day1 = im*30+15 + IF (im2.GT.12) THEN + ! the month is december, the following thus january + im2=1 + ENDIF + day2 = im*30-15 + + DO k=1,klev + DO i=1,klon + pi_sulfate(i,k) = pi_so4(i,k,im2) + . - FLOAT(iday-day2)/FLOAT(day1-day2) + . * (pi_so4(i,k,im2) - pi_so4(i,k,im)) + IF (pi_sulfate(i,k).LT.0.) THEN + IF (iday-day2.LT.0.) write(*,*) 'iday-day2',iday-day2 + IF (pi_so4(i,k,im2) - pi_so4(i,k,im).LT.0.) + . write(*,*) 'pi_so4(i,k,im2) - pi_so4(i,k,im)', + . pi_so4(i,k,im2) - pi_so4(i,k,im) + IF (day1-day2.LT.0.) write(*,*) 'day1-day2',day1-day2 + stop 'pi_sulfate' + endif + ENDDO + ENDDO + ENDIF + + + ! The sulfate concentration [molec cm-3] is read in. + ! Convert it into mass [ug SO4/m3] + ! masse_so4 in [g/mol], n_avogadro in [molec/mol] + DO k=1,klev + DO i=1,klon + pi_sulfate(i,k) = pi_sulfate(i,k)*masse_so4 + . /n_avogadro*1.e+12 + pi_so4_out(i,k) = pi_sulfate(i,k) + ENDDO + ENDDO + + ELSE ! If no new day, use old data: + DO k=1,klev + DO i=1,klon + pi_sulfate(i,k) = pi_so4_out(i,k) + ENDDO + ENDDO + + + ENDIF ! Was this the beginning of a new day? + RETURN + END + + + + + + + + + + +c----------------------------------------------------------------------------- +c Routine for reading SO4 data from files +c----------------------------------------------------------------------------- + + + SUBROUTINE getso4fromfile (cyr, so4) +#include "netcdf.inc" +#include "dimensions.h" +#include "dimphy.h" + CHARACTER*15 fname + CHARACTER*4 cyr + + CHARACTER*6 cvar + INTEGER START(3), COUNT(3) + INTEGER STATUS, NCID, VARID + INTEGER imth, i, j, k, ny + PARAMETER (ny=jjm+1) + + + REAL*8 so4mth(iim, ny, klev) +c REAL*8 so4mth(klev, ny, iim) + REAL*8 so4(iim, ny, klev, 12) + + + fname = 'so4.run'//cyr//'.cdf' + + write (*,*) 'reading ', fname + STATUS = NF_OPEN (fname, NF_NOWRITE, NCID) + IF (STATUS .NE. NF_NOERR) write (*,*) 'err in open ',status + + DO imth=1, 12 + IF (imth.eq.1) THEN + cvar='SO4JAN' + ELSEIF (imth.eq.2) THEN + cvar='SO4FEB' + ELSEIF (imth.eq.3) THEN + cvar='SO4MAR' + ELSEIF (imth.eq.4) THEN + cvar='SO4APR' + ELSEIF (imth.eq.5) THEN + cvar='SO4MAY' + ELSEIF (imth.eq.6) THEN + cvar='SO4JUN' + ELSEIF (imth.eq.7) THEN + cvar='SO4JUL' + ELSEIF (imth.eq.8) THEN + cvar='SO4AUG' + ELSEIF (imth.eq.9) THEN + cvar='SO4SEP' + ELSEIF (imth.eq.10) THEN + cvar='SO4OCT' + ELSEIF (imth.eq.11) THEN + cvar='SO4NOV' + ELSEIF (imth.eq.12) THEN + cvar='SO4DEC' + ENDIF + start(1)=1 + start(2)=1 + start(3)=1 + count(1)=iim + count(2)=ny + count(3)=klev +c write(*,*) 'here i am' + STATUS = NF_INQ_VARID (NCID, cvar, VARID) + write (*,*) ncid,imth,cvar, varid +c STATUS = NF_INQ_VARID (NCID, VARMONTHS(i), VARID(i)) + IF (STATUS .NE. NF_NOERR) write (*,*) 'err in read ',status + STATUS = NF_GET_VARA_DOUBLE + . (NCID, VARID, START,COUNT, so4mth) + IF (STATUS .NE. NF_NOERR) write (*,*) 'err in read data',status + + DO k=1,klev + DO j=1,jjm+1 + DO i=1,iim + IF (so4mth(i,j,k).LT.0.) then + write(*,*) 'this is shit' + write(*,*) 'so4(',i,j,k,') =',so4mth(i,j,k) + endif + so4(i,j,k,imth)=so4mth(i,j,k) +c so4(i,j,k,imth)=so4mth(k,j,i) + ENDDO + ENDDO + ENDDO + ENDDO + + STATUS = NF_CLOSE(NCID) + END ! subroutine getso4fromfile + + + + + + + + + + + + + + + + Index: /LMDZ4/trunk/libf/phylmd/regdim.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/regdim.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/regdim.h (revision 524) @@ -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/trunk/libf/phylmd/screenc.F90 =================================================================== --- /LMDZ4/trunk/libf/phylmd/screenc.F90 (revision 524) +++ /LMDZ4/trunk/libf/phylmd/screenc.F90 (revision 524) @@ -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.inc +! 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.inc" +! +! 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/trunk/libf/phylmd/screenp.F90 =================================================================== --- /LMDZ4/trunk/libf/phylmd/screenp.F90 (revision 524) +++ /LMDZ4/trunk/libf/phylmd/screenp.F90 (revision 524) @@ -0,0 +1,108 @@ +! +! $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.inc +! 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) THEN + delu(i) = (ustar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) + & + min(5.0, 5.0 *(zref - rugos(i))/lmon(i))) + delte(i) = (testar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) + & + min(5.0, 5.0 * (zref - rugos(i))/lmon(i))) + delq(i) = (qstar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) + & + min(5.0, 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/trunk/libf/phylmd/soil.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/soil.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/soil.F (revision 524) @@ -0,0 +1,253 @@ +! +! $Header$ +! + SUBROUTINE soil(ptimestep, indice, knon, snow, ptsrf, ptsoil, + s pcapcal, pfluxgrd) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: Frederic Hourdin 30/01/92 +c ------- +c +c objet: computation of : the soil temperature evolution +c ------ the surfacic heat capacity "Capcal" +c the surface conduction flux pcapcal +c +c +c Method: implicit time integration +c ------- +c Consecutive ground temperatures are related by: +c T(k+1) = C(k) + D(k)*T(k) (1) +c the coefficients C and D are computed at the t-dt time-step. +c Routine structure: +c 1)new temperatures are computed using (1) +c 2)C and D coefficients are computed from the new temperature +c profile for the t+dt time-step +c 3)the coefficients A and B are computed where the diffusive +c fluxes at the t+dt time-step is given by +c Fdiff = A + B Ts(t+dt) +c or Fdiff = F0 + Capcal (Ts(t+dt)-Ts(t))/dt +c with F0 = A + B (Ts(t)) +c Capcal = B*dt +c +c Interface: +c ---------- +c +c Arguments: +c ---------- +c ptimestep physical timestep (s) +c indice sub-surface index +c snow(klon,nbsrf) snow +c ptsrf(klon) surface temperature at time-step t (K) +c ptsoil(klon,nsoilmx) temperature inside the ground (K) +c pcapcal(klon) surfacic specific heat (W*m-2*s*K-1) +c pfluxgrd(klon) surface diffusive flux from ground (Wm-2) +c +c======================================================================= +c declarations: +c ------------- + +#include "dimensions.h" +#include "YOMCST.h" +#include "dimphy.h" +#include "dimsoil.h" +#include "indicesol.h" + +c----------------------------------------------------------------------- +c arguments +c --------- + + REAL ptimestep + INTEGER indice, knon + REAL ptsrf(klon),ptsoil(klon,nsoilmx),snow(klon) + REAL pcapcal(klon),pfluxgrd(klon) + +c----------------------------------------------------------------------- +c local arrays +c ------------ + + INTEGER ig,jk +c$$$ REAL zdz2(nsoilmx),z1(klon) + REAL zdz2(nsoilmx),z1(klon,nbsrf) + REAL min_period,dalph_soil + REAL ztherm_i(klon) + +c local saved variables: +c ---------------------- + REAL dz1(nsoilmx),dz2(nsoilmx) +c$$$ REAL zc(klon,nsoilmx),zd(klon,nsoilmx) + REAL zc(klon,nsoilmx,nbsrf),zd(klon,nsoilmx,nbsrf) + REAL lambda + SAVE dz1,dz2,zc,zd,lambda + LOGICAL firstcall, firstsurf(nbsrf) + SAVE firstcall, firstsurf + REAL isol,isno,iice + SAVE isol,isno,iice + + DATA firstcall/.true./ + DATA firstsurf/.TRUE.,.TRUE.,.TRUE.,.TRUE./ + + DATA isol,isno,iice/2000.,2000.,2000./ + +c----------------------------------------------------------------------- +c Depthts: +c -------- + + REAL fz,rk,fz1,rk1,rk2 + fz(rk)=fz1*(dalph_soil**rk-1.)/(dalph_soil-1.) + pfluxgrd(:) = 0. +c calcul de l'inertie thermique a partir de la variable rnat. +c on initialise a iice meme au-dessus d'un point de mer au cas +c ou le point de mer devienne point de glace au pas suivant +c on corrige si on a un point de terre avec ou sans glace +c + IF (indice.EQ.is_sic) THEN + DO ig = 1, knon + ztherm_i(ig) = iice + IF (snow(ig).GT.0.0) ztherm_i(ig) = isno + ENDDO + ELSE IF (indice.EQ.is_lic) THEN + DO ig = 1, knon + ztherm_i(ig) = iice + IF (snow(ig).GT.0.0) ztherm_i(ig) = isno + ENDDO + ELSE IF (indice.EQ.is_ter) THEN + DO ig = 1, knon + ztherm_i(ig) = isol + IF (snow(ig).GT.0.0) ztherm_i(ig) = isno + ENDDO + ELSE IF (indice.EQ.is_oce) THEN + DO ig = 1, knon + ztherm_i(ig) = iice + ENDDO + ELSE + PRINT*, "valeur d indice non prevue", indice + CALL abort + ENDIF + + +c$$$ IF (firstcall) THEN + IF (firstsurf(indice)) THEN + +c----------------------------------------------------------------------- +c ground levels +c grnd=z/l where l is the skin depth of the diurnal cycle: +c -------------------------------------------------------- + + min_period=1800. ! en secondes + dalph_soil=2. ! rapport entre les epaisseurs de 2 couches succ. + + OPEN(99,file='soil.def',status='old',form='formatted',err=9999) + READ(99,*) min_period + READ(99,*) dalph_soil + PRINT*,'Discretization for the soil model' + PRINT*,'First level e-folding depth',min_period, + s ' dalph',dalph_soil + CLOSE(99) +9999 CONTINUE + +c 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 +C PB + firstsurf(indice) = .FALSE. +c$$$ firstcall =.false. + +c Initialisations: +c ---------------- + + ELSE !--not firstcall +c----------------------------------------------------------------------- +c Computation of the soil temperatures using the Cgrd and Dgrd +c coefficient computed at the previous time-step: +c ----------------------------------------------- + +c surface temperature + DO ig=1,knon + ptsoil(ig,1)=(lambda*zc(ig,1,indice)+ptsrf(ig))/ + s (lambda*(1.-zd(ig,1,indice))+1.) + ENDDO + +c other temperatures + DO jk=1,nsoilmx-1 + DO ig=1,knon + ptsoil(ig,jk+1)=zc(ig,jk,indice)+zd(ig,jk,indice) + $ *ptsoil(ig,jk) + ENDDO + ENDDO + + ENDIF !--not firstcall +c----------------------------------------------------------------------- +c Computation of the Cgrd and Dgrd coefficient for the next step: +c --------------------------------------------------------------- + +c$$$ PB ajout pour cas glace de mer + IF (indice .EQ. is_sic) THEN + DO ig = 1 , knon + ptsoil(ig,nsoilmx) = RTT - 1.8 + END DO + ENDIF + + DO jk=1,nsoilmx + zdz2(jk)=dz2(jk)/ptimestep + ENDDO + + DO ig=1,knon + z1(ig,indice)=zdz2(nsoilmx)+dz1(nsoilmx-1) + zc(ig,nsoilmx-1,indice)= + $ zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1(ig,indice) + zd(ig,nsoilmx-1,indice)=dz1(nsoilmx-1)/z1(ig,indice) + ENDDO + + DO jk=nsoilmx-1,2,-1 + DO ig=1,knon + z1(ig,indice)=1./(zdz2(jk)+dz1(jk-1)+dz1(jk) + $ *(1.-zd(ig,jk,indice))) + zc(ig,jk-1,indice)= + s (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*zc(ig,jk,indice)) + $ *z1(ig,indice) + zd(ig,jk-1,indice)=dz1(jk-1)*z1(ig,indice) + ENDDO + ENDDO + +c----------------------------------------------------------------------- +c computation of the surface diffusive flux from ground and +c calorific capacity of the ground: +c --------------------------------- + + DO ig=1,knon + pfluxgrd(ig)=ztherm_i(ig)*dz1(1)* + s (zc(ig,1,indice)+(zd(ig,1,indice)-1.)*ptsoil(ig,1)) + pcapcal(ig)=ztherm_i(ig)* + s (dz2(1)+ptimestep*(1.-zd(ig,1,indice))*dz1(1)) + z1(ig,indice)=lambda*(1.-zd(ig,1,indice))+1. + pcapcal(ig)=pcapcal(ig)/z1(ig,indice) + pfluxgrd(ig) = pfluxgrd(ig) + s + pcapcal(ig) * (ptsoil(ig,1) * z1(ig,indice) + $ - lambda * zc(ig,1,indice) + $ - ptsrf(ig)) + s /ptimestep + ENDDO + + RETURN + END Index: /LMDZ4/trunk/libf/phylmd/stdlevvar.F90 =================================================================== --- /LMDZ4/trunk/libf/phylmd/stdlevvar.F90 (revision 524) +++ /LMDZ4/trunk/libf/phylmd/stdlevvar.F90 (revision 524) @@ -0,0 +1,261 @@ +! +! $Header$ +! + SUBROUTINE stdlevvar(klon, knon, nsrf, zxli, & + & u1, v1, t1, q1, z1, & + & ts1, qsurf, rugos, psol, pat1, & + & t_2m, q_2m, u_10m) + 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 +!------------------------------------------------------------------------- +! +! 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.inc +! 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 +! + 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, u_10m +!------------------------------------------------------------------------- +#include "YOMCST.inc" +!IM PLUS +#include "YOETHF.inc" +! +! 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) :: ustar, 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) +!IM cf FH : on prend le max : pour eviter le plantage sur SUN + zdte(i) = max(zdte(i),1.e-10) + zdq(i) = max(q1(i),0.0) - max(qsurf(i),0.0) +! + 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) + ENDDO +! + RETURN + END subroutine stdlevvar Index: /LMDZ4/trunk/libf/phylmd/suphec.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/suphec.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/suphec.F (revision 524) @@ -0,0 +1,207 @@ +! +! $Header$ +! + SUBROUTINE suphec +C +#include "YOMCST.h" +#include "YOETHF.h" +cIM cf. JLD + LOGICAL firstcall + SAVE firstcall + DATA firstcall /.TRUE./ + IF (firstcall) THEN + PRINT*, 'suphec initialise les constantes du GCM' + firstcall = .FALSE. + ELSE + PRINT*, 'suphec 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 + 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='('' 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/trunk/libf/phylmd/tilft43.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/tilft43.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/tilft43.F (revision 524) @@ -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/trunk/libf/phylmd/tlift.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/tlift.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/tlift.F (revision 524) @@ -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/trunk/libf/phylmd/transp.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/transp.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/transp.F (revision 524) @@ -0,0 +1,47 @@ +! +! $Header$ +! + SUBROUTINE transp (paprs,tsol, + e t, q, u, v, geom, + s vtran_e, vtran_q, utran_e, utran_q) +c + 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 +#include "dimensions.h" +#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/trunk/libf/phylmd/wrgradsfi.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/wrgradsfi.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/wrgradsfi.F (revision 524) @@ -0,0 +1,32 @@ +! +! $Header$ +! + subroutine wrgradsfi(if,nl,fieldfi,name,titlevar) + implicit none + +c Declarations + +#include "dimensions.h" +#include "dimphy.h" + +c arguments + integer if,nl + real fieldfi(klon,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 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' + + return + end Index: /LMDZ4/trunk/libf/phylmd/write_histISCCP.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/write_histISCCP.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/write_histISCCP.h (revision 524) @@ -0,0 +1,30 @@ +! +! $Header$ +! + IF (ok_isccp) THEN +c + ndex2d = 0 + ndex3d = 0 +c + itau_w = itau_phy + itap +c + DO k=1,kmaxm1 + zx_tmp_fi3d(1:klon, 1:lmaxm1)=fq_isccp(1:klon,k,1:lmaxm1)*100. + CALL gr_fi_ecrit(lmaxm1,klon,iim,jjmp1,zx_tmp_fi3d, + . zx_tmp_3d) +c +cIM: champ 3d : (lon,lat,pres) pour un tau fixe +c + CALL histwrite(nid_isccp,"cldISCCP_"//taulev(k),itau_w, + . zx_tmp_3d,iim*jjmp1*lmaxm1,ndex3d) + ENDDO !k +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1,nbsunlit(1,:),zx_tmp_2d) + CALL histwrite(nid_isccp,"nsunlit",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + if (ok_sync) then + call histsync(nid_isccp) + endif + + ENDIF !ok_isccp Index: /LMDZ4/trunk/libf/phylmd/write_histREGDYN.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/write_histREGDYN.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/write_histREGDYN.h (revision 524) @@ -0,0 +1,69 @@ +! +! $Header$ +! + if (ok_regdyn) then + +c Comprendre comment marche el i=nint(zout/zsto) +c + ndex2d = 0 + ndex3d = 0 +c +c itap = 0 +c zsto = dtime * REAL(NINT(86400./dtime*ecrit_regdyn)) +c zout = dtime * ecrit_mth + +c zsto = dtime +c zout = dtime * ecrit_mth +c zsto = dtime * REAL(NINT(86400./dtime*ecrit_regdyn)) + itau_w = itau_phy + itap + + 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 Index: /LMDZ4/trunk/libf/phylmd/write_histday.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/write_histday.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/write_histday.h (revision 524) @@ -0,0 +1,453 @@ +! +! $Header$ +! + IF (ok_journe) THEN +c + ndex2d = 0 + ndex3d = 0 +c +c Champs 2D: +c + zsto = dtime + zout = dtime * FLOAT(ecrit_day) + itau_w = itau_phy + itap + + i = NINT(zout/zsto) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d) +c + IF(lev_histday.GE.1) THEN +c + CALL histwrite(nid_day,"phis",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + varname = 'phis' + vartitle= 'Surface geop. height' + varunits= '-' +c + i = NINT(zout/zsto) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d) + CALL histwrite(nid_day,"aire",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + varname = 'aire' + vartitle= 'Grid area' + varunits= '-' +c + DO i=1, klon + zx_tmp_fi2d(i)=pctsrf(i,is_ter)+pctsrf(i,is_lic) + ENDDO +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"contfracATM",itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,pctsrf_new(:,is_ter),zx_tmp_2d) + CALL histwrite(nid_day,"contfracOR",itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d) + CALL histwrite(nid_day,"tsol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +C + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d) + CALL histwrite(nid_day,"t2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c En attendant un eventuel debugage. + + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d) + CALL histwrite(nid_day,"t2m_min",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d) + CALL histwrite(nid_day,"t2m_max",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"plul",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = rain_con(i) + snow_con(i) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"pluc",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_lsc,zx_tmp_2d) + CALL histwrite(nid_day,"snowl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + IF(1.EQ.0) THEN + CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_con,zx_tmp_2d) + CALL histwrite(nid_day,"snowc",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + ENDIF +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfluxlat,zx_tmp_2d) + CALL histwrite(nid_day,"flat",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = pctsrf(i,is_sic) + ENDDO +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"sicf",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zq2m,zx_tmp_2d) + CALL histwrite(nid_day,"q2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zu10m,zx_tmp_2d) + CALL histwrite(nid_day,"u10m",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zv10m,zx_tmp_2d) + CALL histwrite(nid_day,"v10m",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + DO i=1, klon + zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i)) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"wind10m",itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"wind10max",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + DO i=1, klon + zx_tmp_fi2d(i) = paprs(i,1) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"psol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i=1, klon + zx_tmp_fi2d(i) = (rain_fall(i) + snow_fall(i)) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"precip",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d) + CALL histwrite(nid_day,"snowf",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d) + CALL histwrite(nid_day,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d) + CALL histwrite(nid_day,"evap",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d) + CALL histwrite(nid_day,"tops",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d) + CALL histwrite(nid_day,"topl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d) + CALL histwrite(nid_day,"sols",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d) + CALL histwrite(nid_day,"soll",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d) + CALL histwrite(nid_day,"cldl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d) + CALL histwrite(nid_day,"cldm",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d) + CALL histwrite(nid_day,"cldh",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d) + CALL histwrite(nid_day,"cldt",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d) + CALL histwrite(nid_day,"cldq",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, prw,zx_tmp_2d) + CALL histwrite(nid_day,"prw",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) + +c Ecriture de champs dynamiques sur des niveaux de pression + DO k=1, nlevENS +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, ulev(:,k),zx_tmp_2d) + CALL histwrite(nid_day,"u"//clev(k),itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, vlev(:,k),zx_tmp_2d) + CALL histwrite(nid_day,"v"//clev(k),itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + ENDDO !nlevENS +c + DO k=1, nlevENS + IF(clev(k).EQ."500") THEN +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, wlev(:,indENS(k)),zx_tmp_2d) + CALL histwrite(nid_day,"w500",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c DO i=1, klon +c print*,' ind, phi 500hPa',i,indENS(k),philev(:,indENS(k)) +c print*,' ind, phi 500hPa',i,indENS(k) +c ENDDO +c +cBAD CALL gr_fi_ecrit(1, klon,iim,jjmp1, philev(:,indENS(k)),zx_tmp_2d) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, philev(:,k),zx_tmp_2d) + CALL histwrite(nid_day,"phi500",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + ENDIF !clev(k).EQ.500 + ENDDO !k=1, nlevENS +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d) + CALL histwrite(nid_day,"slp",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + + CALL gr_fi_ecrit(1,klon,iim,jjmp1,cape,zx_tmp_2d) + CALL histwrite(nid_day,"cape_max",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d) + CALL histwrite(nid_day,"solldown",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + DO i=1, klon + zx_tmp_fi2d(i)=-1*sens(i) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"sens",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = swdn(1 : klon, 1) + + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day, "SWdnSFC",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + ENDIF !lev_histday.GE.1 +c + IF(lev_histday.GE.2) THEN +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d) + CALL histwrite(nid_day,"bils",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d) + CALL histwrite(nid_day,"fder",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + ENDIF !lev_histday.GE.2 +c + IF(lev_histday.GE.3) THEN +c================================================================= +c ECRITURE DES CHAMPS 3D +c================================================================= + +c +c Champs 3D: +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d) + CALL histwrite(nid_day,"temp",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d) + CALL histwrite(nid_day,"ovap",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d) + CALL histwrite(nid_day,"geop",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d) + CALL histwrite(nid_day,"vitu",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d) + CALL histwrite(nid_day,"vitv",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d) + CALL histwrite(nid_day,"vitw",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d) + CALL histwrite(nid_day,"pres",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + ENDIF !lev_histday.GE.3 +c================================================================= +c FIN ECRITURE DES CHAMPS 3D +c================================================================= + IF(lev_histday.ge.4) THEN +c================================================================= +c +c ECRITURE DES CHAMPS SUR LES SOUS SURFACES +c +c================================================================= + zx_tmp_fi2d(1 : klon) = swup( 1 : klon, klevp1 ) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day, "SWupTOA",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = swup( 1 : klon, 1 ) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day, "SWupSFC",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = swdn( 1 : klon, klevp1 ) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day, "SWdnTOA",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = swup0( 1 : klon, klevp1 ) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day, "SWupTOAclr",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = swup0( 1 : klon, 1 ) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day, "SWupSFCclr",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = swdn0( 1 : klon, klevp1 ) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day, "SWdnTOAclr",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = swdn0( 1 : klon, 1 ) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day, "SWdnSFCclr",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_ter) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d ,zx_tmp_2d) + CALL histwrite(nid_day,"tter",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_lic) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"tlic",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_oce) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"toce",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_sic) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"tsic",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"t2mter",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_ter) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"t2mter_min",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_ter) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"t2mter_max",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_lic) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"t2mlic",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_oce) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"t2moce",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_sic) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"t2msic",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_ter) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"u10mter",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_ter) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"v10mter",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_lic) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"u10mlic",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_lic) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"v10mlic",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_oce) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"u10moce",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_oce) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"v10moce",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_sic) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"u10msic",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +C + zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_sic) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"v10msic",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +C + DO nsrf = 1, nbsrf +C + zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_day,"pourc_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_day,"tsol_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_day,"sens_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_day,"lat_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_day,"taux_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_day,"tauy_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_day,"albe_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_day,"rugs_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + END DO +c================================================================= +c FIN ECRITURE DES CHAMPS SUR LES SOUS SURFACES +c================================================================= + ENDIF !lev_histday.GE.4 +c +c================================================================= +c================================================================= +c================================================================= +c + if (ok_sync) then + call histsync(nid_day) + endif + + ENDIF Index: /LMDZ4/trunk/libf/phylmd/write_histhf.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/write_histhf.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/write_histhf.h (revision 524) @@ -0,0 +1,167 @@ +! +! $Header$ +! + if (ok_hf) then + +c Comprendre comment marche el i=nint(zout/zsto) +c +c print*,'ACRITURE HF !!! ACRITURE HF !!! ACRITURE HF !!! ' + ndex2d = 0 + ndex3d = 0 +c + zsto = dtime + zout = dtime * ecrit_hf + itau_w = itau_phy + itap +c + IF(lev_histhf.GE.1) THEN +c +c i = NINT(zout/zsto) +c CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d) +c CALL histwrite(nid_hf,"phis",i,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c i = NINT(zout/zsto) +c CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d) +c CALL histwrite(nid_hf,"aire",i,zx_tmp_2d,iim*jjmp1,ndex2d) +C + CALL gr_fi_ecrit(1, klon,iim,jjmp1, paire_ter, zx_tmp_2d) + CALL histwrite(nid_hf,"aireTER",itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i=1, klon + zx_tmp_fi2d(i)=pctsrf(i,is_ter)+pctsrf(i,is_lic) + ENDDO +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_hf,"contfracATM",itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,pctsrf_new(:,is_ter),zx_tmp_2d) + CALL histwrite(nid_hf,"contfracOR",itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m,zx_tmp_2d) + CALL histwrite(nid_hf,"t2m",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m,zx_tmp_2d) + CALL histwrite(nid_hf,"q2m",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = paprs(i,1) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_hf,"psol",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_hf,"rain",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c ENSEMBLES BEG + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d) + CALL histwrite(nid_hf,"tsol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d) + CALL histwrite(nid_hf,"slp",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m,zx_tmp_2d) + CALL histwrite(nid_hf,"u10m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m,zx_tmp_2d) + CALL histwrite(nid_hf,"v10m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i=1, klon + zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i)) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_hf,"wind10m",itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + DO k=1, nlevENS + IF(clev(k).EQ."500") THEN + CALL gr_fi_ecrit(1, klon,iim,jjmp1, philev(:,k),zx_tmp_2d) + CALL histwrite(nid_hf,"phi"//clev(k),itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) + ENDIF !clev(k).EQ."500" + ENDDO +c + ENDIF !lev_histhf.GE.1 +c + IF(lev_histhf.GE.2) THEN +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d) + CALL histwrite(nid_hf,"cldt",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, is_ter) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_hf,"SWdownOR",itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d) + CALL histwrite(nid_hf,"LWdownOR",itau_w,zx_tmp_2d,iim*jjmp1, + $ ndex2d) +c +c + ENDIF !lev_histhf.GE.2 +c + IF(lev_histhf.GE.3) THEN +c + DO k=1, nlevENS +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, tlev(:,k),zx_tmp_2d) + CALL histwrite(nid_hf,"t"//clev(k),itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + IF(clev(k).NE."500") THEN !clev(k).NE."500" + CALL gr_fi_ecrit(1, klon,iim,jjmp1, philev(:,k),zx_tmp_2d) + CALL histwrite(nid_hf,"phi"//clev(k),itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) + ENDIF !clev(k).NE."500" +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, qlev(:,k),zx_tmp_2d) + CALL histwrite(nid_hf,"q"//clev(k),itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + IF(1.EQ.0) THEN + CALL gr_fi_ecrit(1, klon,iim,jjmp1, rhlev(:,k),zx_tmp_2d) + CALL histwrite(nid_hf,"rh"//clev(k),itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) + ENDIF !1.EQ.0 +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, ulev(:,k),zx_tmp_2d) + CALL histwrite(nid_hf,"u"//clev(k),itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, vlev(:,k),zx_tmp_2d) + CALL histwrite(nid_hf,"v"//clev(k),itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + ENDDO !nlevENS +c + IF(1.EQ.0) THEN + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d) + CALL histwrite(nid_hf,"cdrm",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d) + CALL histwrite(nid_hf,"cdrh",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + ENDIF !(1.EQ.0) THEN +c + ENDIF !lev_histhf.GE.3 +c + IF(lev_histhf.GE.4) THEN +c +#define histhf3d +#ifdef histhf3d +#include "write_histhf3d.h" +#endif +c + ENDIF !lev_histhf.GE.4 +c + if (ok_sync) then + call histsync(nid_hf) + endif + + endif Index: /LMDZ4/trunk/libf/phylmd/write_histhf3d.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/write_histhf3d.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/write_histhf3d.h (revision 524) @@ -0,0 +1,42 @@ +! +! $Header$ +! +c if (ok_hf) then + +c Comprendre comment marche el i=nint(zout/zsto) +c +c print*,'ACRITURE HF !!! ACRITURE HF !!! ACRITURE HF !!! ' + ndex2d = 0 + ndex3d = 0 +c + zsto = dtime + zout = dtime * ecrit_hf + itau_w = itau_phy + itap +c +c IF(lev_histhf.GE.1) THEN +c +c Champs 3D: +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d) + CALL histwrite(nid_hf3d,"temp",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d) + CALL histwrite(nid_hf3d,"ovap",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d) + CALL histwrite(nid_hf3d,"vitu",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d) + CALL histwrite(nid_hf3d,"vitv",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c +c ENDIF !lev_histhf.GE.1 +c + if (ok_sync) then + call histsync(nid_hf3d) + endif + +c endif Index: /LMDZ4/trunk/libf/phylmd/write_histins.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/write_histins.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/write_histins.h (revision 524) @@ -0,0 +1,203 @@ +! +! $Header$ +! + IF (ok_instan) THEN +c + ndex2d = 0 + ndex3d = 0 +c +c Champs 2D: +c + zsto = dtime * ecrit_ins + zout = dtime * ecrit_ins + itau_w = itau_phy + itap + + i = NINT(zout/zsto) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d) + CALL histwrite(nid_ins,"phis",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + i = NINT(zout/zsto) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d) + CALL histwrite(nid_ins,"aire",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + + DO i = 1, klon + zx_tmp_fi2d(i) = paprs(i,1) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_ins,"psol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_ins,"precip",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_ins,"plul",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = rain_con(i) + snow_con(i) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_ins,"pluc",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d) + CALL histwrite(nid_ins,"tsol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +cccIM + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m, zx_tmp_2d) + CALL histwrite(nid_ins,"t2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m, zx_tmp_2d) + CALL histwrite(nid_ins,"q2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m, zx_tmp_2d) + CALL histwrite(nid_ins,"u10m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +C + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m, zx_tmp_2d) + CALL histwrite(nid_ins,"v10m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d) + CALL histwrite(nid_ins,"snow",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d) + CALL histwrite(nid_ins,"cdrm",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d) + CALL histwrite(nid_ins,"cdrh",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d) + CALL histwrite(nid_ins,"topl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d) + CALL histwrite(nid_ins,"evap",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d) + CALL histwrite(nid_ins,"sols",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d) + CALL histwrite(nid_ins,"soll",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d) + CALL histwrite(nid_ins,"solldown",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d) + CALL histwrite(nid_ins,"bils",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1:klon)=-1*sens(1:klon) +c CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_ins,"sens",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d) + CALL histwrite(nid_ins,"fder",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_oce),zx_tmp_2d) + CALL histwrite(nid_ins,"dtsvdfo",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_ter),zx_tmp_2d) + CALL histwrite(nid_ins,"dtsvdft",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_lic),zx_tmp_2d) + CALL histwrite(nid_ins,"dtsvdfg",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_sic),zx_tmp_2d) + CALL histwrite(nid_ins,"dtsvdfi",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) + + DO nsrf = 1, nbsrf +CXXX + zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_ins,"pourc_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_ins,"sens_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_ins,"lat_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_ins,"tsol_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_ins,"taux_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_ins,"tauy_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_ins,"rugs_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_ins,"albe_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + END DO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol,zx_tmp_2d) + CALL histwrite(nid_ins,"albs",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsollw,zx_tmp_2d) + CALL histwrite(nid_ins,"albslw",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d) + CALL histwrite(nid_ins,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxrugs,zx_tmp_2d) + CALL histwrite(nid_ins,"rugs",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c Champs 3D: +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d) + CALL histwrite(nid_ins,"temp",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d) + CALL histwrite(nid_ins,"vitu",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d) + CALL histwrite(nid_ins,"vitv",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d) + CALL histwrite(nid_ins,"geop",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d) + CALL histwrite(nid_ins,"pres",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d) + CALL histwrite(nid_ins,"dtvdf",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d) + CALL histwrite(nid_ins,"dqvdf",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) + +c + if (ok_sync) then + call histsync(nid_ins) + endif + ENDIF Index: /LMDZ4/trunk/libf/phylmd/write_histmth.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/write_histmth.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/write_histmth.h (revision 524) @@ -0,0 +1,782 @@ +! +! $Header$ +! + IF (ok_mensuel) THEN +c + ndex2d = 0 + ndex3d = 0 + + zsto = dtime + zout = dtime * ecrit_mth + itau_w = itau_phy + itap + + i = NINT(zout/zsto) +c + IF(lev_histmth.GE.1) THEN +c +c Champs 2D: +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d) + CALL histwrite(nid_mth,"phis",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +C + i = NINT(zout/zsto) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d) + CALL histwrite(nid_mth,"aire",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, is_ter) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"pourc_"//clnsurf(is_ter),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d) + CALL histwrite(nid_mth,"slp",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d) + CALL histwrite(nid_mth,"tsol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m,zx_tmp_2d) + CALL histwrite(nid_mth,"t2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c ENSEMBLES BEG + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d) + CALL histwrite(nid_mth,"t2m_min",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d) + CALL histwrite(nid_mth,"t2m_max",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c +c CALL gr_fi_ecrit(1,klon,iim,jjmp1,ftsoil(:,1,is_ter),zx_tmp_2d) +c CALL gr_fi_ecrit(1,klon,iim,jjmp1,ftsol(:,is_ter),zx_tmp_2d) +c CALL gr_fi_ecrit(1,klon,iim,jjmp1,ztsol,zx_tmp_2d) +c CALL histwrite(nid_mth,"tsoil",itau_w,zx_tmp_2d, +c . iim*jjmp1,ndex2d) +c + DO i=1, klon + zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i)) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth,"wind10m",itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = pctsrf(i,is_sic) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth,"sicf",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d) +c CALL histwrite(nid_mth,"temp",itau_w,zx_tmp_3d, +c . iim*jjmp1*klev,ndex3d) +c +c ENSEMBLES END +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m,zx_tmp_2d) + CALL histwrite(nid_mth,"q2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m,zx_tmp_2d) + CALL histwrite(nid_mth,"u10m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +C + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m,zx_tmp_2d) + CALL histwrite(nid_mth,"v10m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +C + DO i = 1, klon + zx_tmp_fi2d(i) = paprs(i,1) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth,"psol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxqsurf,zx_tmp_2d) + CALL histwrite(nid_mth,"qsurf",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + if (.not. ok_veget) then + CALL gr_fi_ecrit(1, klon,iim,jjmp1, qsol,zx_tmp_2d) + CALL histwrite(nid_mth,"qsol",itau_w,zx_tmp_2d,iim*jjmp1 + $ ,ndex2d) + endif +c + DO i = 1, klon + zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth,"precip",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, nday_rain,zx_tmp_2d) + CALL histwrite(nid_mth,"ndayrain",itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth,"plul",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = rain_con(i) + snow_con(i) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth,"pluc",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d) + CALL histwrite(nid_mth,"snow",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d) + CALL histwrite(nid_mth,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c +cIM: 071003 +c zx_tmp_fi2d(1:klon)=evap(1:klon)*86400. +c CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d) + CALL histwrite(nid_mth,"evap",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d) + CALL histwrite(nid_mth,"tops",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw0,zx_tmp_2d) + CALL histwrite(nid_mth,"tops0",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d) + CALL histwrite(nid_mth,"topl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw0,zx_tmp_2d) + CALL histwrite(nid_mth,"topl0",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c zx_tmp_fi2d(1 : klon) = ZFSUP( 1 : klon, klevp1) +cIM 080304 zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, 2 ) + zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, klevp1 ) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth, "SWupTOA",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c +c +c zx_tmp_fi2d(1 : klon) = ZFSUP0( 1 : klon, klevp1) +cIM 080304 zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, 2 ) + zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, klevp1 ) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth, "SWupTOAclr",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c +c zx_tmp_fi2d(1 : klon) = ZFSDN( 1 : klon, klevp1) +cIM 080304 zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, 2 ) + zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, klevp1 ) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth, "SWdnTOA",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c +c zx_tmp_fi2d(1 : klon) = ZFSDN0( 1 : klon, klevp1) +cIM 080304 zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, 2 ) + zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, klevp1 ) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth, "SWdnTOAclr",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWup200,zx_tmp_2d) + CALL histwrite(nid_mth,"SWup200",itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWup200clr,zx_tmp_2d) + CALL histwrite(nid_mth,"SWup200clr",itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWdn200,zx_tmp_2d) + CALL histwrite(nid_mth,"SWdn200",itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWdn200clr,zx_tmp_2d) + CALL histwrite(nid_mth,"SWdn200clr",itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, LWup200,zx_tmp_2d) + CALL histwrite(nid_mth,"LWup200",itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, LWup200clr,zx_tmp_2d) + CALL histwrite(nid_mth,"LWup200clr",itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1:klon)=-1*LWdn200(1:klon) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth,"LWdn200",itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1:klon)=-1*LWdn200clr(1:klon) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth,"LWdn200clr",itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c +c200 END + CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d) + CALL histwrite(nid_mth,"sols",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw0,zx_tmp_2d) + CALL histwrite(nid_mth,"sols0",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d) + CALL histwrite(nid_mth,"soll",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw0,zx_tmp_2d) + CALL histwrite(nid_mth,"soll0",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c zx_tmp_fi2d(1 : klon) = ZFSUP( 1 : klon, 1) + zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, 1 ) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth, "SWupSFC",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c +c zx_tmp_fi2d(1 : klon) = ZFSUP0( 1 : klon, 1) + zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, 1 ) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth, "SWupSFCclr",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c +c zx_tmp_fi2d(1 : klon) = ZFSDN( 1 : klon, 1) + zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, 1 ) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth, "SWdnSFC",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c +c zx_tmp_fi2d(1 : klon) = ZFSDN0( 1 : klon, 1) + zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, 1 ) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth, "SWdnSFCclr",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1:klon)=sollw(1:klon)+sollwdown(1:klon) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_mth,"LWupSFC",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1:klon)=sollw0(1:klon)+sollwdownclr(1:klon) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_mth,"LWupSFCclr",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d) + CALL histwrite(nid_mth,"LWdnSFC",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + DO i=1, klon + sollwdownclr(i)=lwdn0(i,1) + ENDDO !i=1, klon +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdownclr,zx_tmp_2d) + CALL histwrite(nid_mth,"LWdnSFCclr",itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c +c +c effets des aerosols +c +c IF (ok_ade.OR.ok_aie) THEN + zx_tmp_fi2d(1:klon) = topswai(1:klon) - topswad(1:klon) +c CALL gr_fi_ecrit(1, klon,iim,jjmp1, topswad,zx_tmp_2d) + CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d ,zx_tmp_2d) + CALL histwrite(nid_mth,"topsad",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1:klon) = solswai(1:klon) - solswad(1:klon) +c CALL gr_fi_ecrit(1, klon,iim,jjmp1, solswad,zx_tmp_2d) + CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d ,zx_tmp_2d) + CALL histwrite(nid_mth,"solsad",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1:klon) = topsw(1:klon) - topswai(1:klon) +c CALL gr_fi_ecrit(1, klon,iim,jjmp1, topswai,zx_tmp_2d) + CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d ,zx_tmp_2d) + CALL histwrite(nid_mth,"topsai",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1:klon) = solsw(1:klon) - solswai(1:klon) +c CALL gr_fi_ecrit(1, klon,iim,jjmp1, solswai,zx_tmp_2d) + CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d ,zx_tmp_2d) + CALL histwrite(nid_mth,"solsai",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c endif +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d) + CALL histwrite(nid_mth,"bils",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1:klon)=-1*sens(1:klon) +c CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth,"sens",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d) + CALL histwrite(nid_mth,"fder",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c +c DO i = 1, klon +c zx_tmp_fi2d(i) = fluxu(i,1) +c ENDDO +c CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) +c CALL histwrite(nid_mth,"frtu",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c DO i = 1, klon +c zx_tmp_fi2d(i) = fluxv(i,1) +c ENDDO +c CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) +c CALL histwrite(nid_mth,"frtv",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxffonte,zx_tmp_2d) + CALL histwrite(nid_mth,"ffonte",itau_w,zx_tmp_2d,iim*jjmp1, + $ ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfqcalving,zx_tmp_2d) + CALL histwrite(nid_mth,"fqcalving",itau_w,zx_tmp_2d,iim*jjmp1, + $ ndex2d) +cIM: 171003 + DO nsrf = 1, nbsrf + zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"taux_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"tauy_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) + ENDDO +cIM: 171003 +c +cIM if ( lev_histday.gt.1 ) then + DO nsrf = 1, nbsrf +CYYY + IF(nsrf.GT.1) THEN + zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"pourc_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) + ENDIF !nsrf.GT.1 +C + zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"tsol_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"sens_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"lat_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fsollw( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"flw_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"fsw_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = wfbils( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"wbils_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + + END DO +cIM endif !lev_histday + +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d) + CALL histwrite(nid_mth,"cdrm",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d) + CALL histwrite(nid_mth,"cdrh",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d) + CALL histwrite(nid_mth,"cldl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d) + CALL histwrite(nid_mth,"cldm",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d) + CALL histwrite(nid_mth,"cldh",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d) + CALL histwrite(nid_mth,"cldt",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d) + CALL histwrite(nid_mth,"cldq",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1:klon) = flwp(1:klon) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth,"lwp",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1:klon) = fiwp(1:klon) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth,"iwp",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, ue,zx_tmp_2d) + CALL histwrite(nid_mth,"ue",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, ve,zx_tmp_2d) + CALL histwrite(nid_mth,"ve",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, uq,zx_tmp_2d) + CALL histwrite(nid_mth,"uq",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, vq,zx_tmp_2d) + CALL histwrite(nid_mth,"vq",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +cKE43 + IF (iflag_con.GE.3) THEN ! sb +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cape,zx_tmp_2d) + CALL histwrite(nid_mth,"cape",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1,pbase,zx_tmp_2d) + CALL histwrite(nid_mth,"pbase",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_pct,zx_tmp_2d) + CALL histwrite(nid_mth,"ptop",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_cbmf,zx_tmp_2d) + CALL histwrite(nid_mth,"fbase",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c34EK +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, prw,zx_tmp_2d) + CALL histwrite(nid_mth,"prw",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + ENDIF !iflag_con.GE.3 +c +c +c +c Champs interpolles sur des niveaux de pression + DO k=1, nlevENS +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, ulev(:,k),zx_tmp_2d) + CALL histwrite(nid_mth,"u"//clev(k),itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, vlev(:,k),zx_tmp_2d) + CALL histwrite(nid_mth,"v"//clev(k),itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, wlev(:,k),zx_tmp_2d) + CALL histwrite(nid_mth,"w"//clev(k),itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, philev(:,k),zx_tmp_2d) + CALL histwrite(nid_mth,"phi"//clev(k),itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + ENDDO !nlevENS + ENDIF !lev_histmth.GE.1 +c + IF(lev_histmth.GE.2) THEN +c +c Champs 3D: +C +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, flwc,zx_tmp_3d) + CALL histwrite(nid_mth,"lwcon",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, fiwc,zx_tmp_3d) + CALL histwrite(nid_mth,"iwcon",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d) + CALL histwrite(nid_mth,"temp",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c +c#ifdef histmthNMC +c#include "write_histmthNMC.h" +c#endif +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d) + CALL histwrite(nid_mth,"ovap",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c +cIM: 071003 +c zx_tmp_fi3d(1:klon,1:klev)=qx(1:klon,1:klev,ivap)/ +c . (1-qx(1:klon,1:klev,ivap)) +c CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_tmp_fi3d, zx_tmp_3d) +c CALL histwrite(nid_mth,"wvap",itau_w,zx_tmp_3d, +c . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d) + CALL histwrite(nid_mth,"geop",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d) + CALL histwrite(nid_mth,"vitu",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d) + CALL histwrite(nid_mth,"vitv",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d) + CALL histwrite(nid_mth,"vitw",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d) + CALL histwrite(nid_mth,"pres",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldfra, zx_tmp_3d) + CALL histwrite(nid_mth,"rneb",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, rnebcon, zx_tmp_3d) + CALL histwrite(nid_mth,"rnebcon",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_rh, zx_tmp_3d) + CALL histwrite(nid_mth,"rhum",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, wo, zx_tmp_3d) + CALL histwrite(nid_mth,"ozone",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c +cIM 22.03.04 BEG + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t, zx_tmp_3d) + CALL histwrite(nid_mth,"dtphy",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,ivap), + . zx_tmp_3d) + CALL histwrite(nid_mth,"dqphy",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +cIM 22.03.04 END +c + ENDIF !lev_histmth.GE.2 +c + IF(lev_histmth.GE.3) THEN +c + DO nsrf=1, nbsrf +c + zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"albe_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"rugs_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = agesno( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, agesno,zx_tmp_2d) + CALL histwrite(nid_mth,"ages_"//clnsurf(nsrf),itau_w + $ ,zx_tmp_2d,iim*jjmp1,ndex2d) +c + ENDDO !nsrf=1, nbsrf +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol,zx_tmp_2d) + CALL histwrite(nid_mth,"albs",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsollw,zx_tmp_2d) + CALL histwrite(nid_mth,"albslw",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + ENDIF !lev_histmth.GE.3 +c +c + IF(lev_histmth.GE.4) THEN +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, clwcon0, zx_tmp_3d) + CALL histwrite(nid_mth,"clwcon",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, Ma, zx_tmp_3d) + CALL histwrite(nid_mth,"Ma",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, upwd, zx_tmp_3d) + CALL histwrite(nid_mth,"upwd",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd, zx_tmp_3d) + CALL histwrite(nid_mth,"dnwd",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd0, zx_tmp_3d) + CALL histwrite(nid_mth,"dnwd0",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d) + CALL histwrite(nid_mth,"dtdyn",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d) + CALL histwrite(nid_mth,"dqdyn",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c +cIM: 101003 : K/30min ==> K/s + zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys + CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d) + CALL histwrite(nid_mth,"dtcon",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_con, zx_tmp_3d) + CALL histwrite(nid_mth,"dqcon",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c +cIM: 101003 : K/30min ==> K/s + zx_tmp_fi3d(1:klon,1:klev)=d_t_lsc(1:klon,1:klev)/pdtphys + CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d) + CALL histwrite(nid_mth,"dtlsc",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +cIM: 071003 +cIM: 101003 : K/30min ==> K/s + zx_tmp_fi3d(1:klon, 1:klev)=(d_t_lsc(1:klon,1:klev)+ + . d_t_eva(1:klon,1:klev))/pdtphys + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_tmp_fi3d, zx_tmp_3d) + CALL histwrite(nid_mth,"dtlschr",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_lsc, zx_tmp_3d) + CALL histwrite(nid_mth,"dqlsc",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c +cIM: 101003 : K/30min ==> K/s + zx_tmp_fi3d(1:klon,1:klev)=d_t_vdf(1:klon,1:klev)/pdtphys + CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d) + CALL histwrite(nid_mth,"dtvdf",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d) + CALL histwrite(nid_mth,"dqvdf",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c +cIM: 101003 : K/30min ==> K/s + zx_tmp_fi3d(1:klon,1:klev)=d_t_eva(1:klon,1:klev)/pdtphys + CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d) + CALL histwrite(nid_mth,"dteva",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_eva, zx_tmp_3d) + CALL histwrite(nid_mth,"dqeva",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + zpt_conv = 0. + where (ptconv) zpt_conv = 1. + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zpt_conv, zx_tmp_3d) + CALL histwrite(nid_mth,"ptconv",itau_w,zx_tmp_3d, + . iim*(jjmp1)*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, ratqs, zx_tmp_3d) + CALL histwrite(nid_mth,"ratqs",itau_w,zx_tmp_3d, + . iim*(jjmp1)*klev,ndex3d) +c +cIM: 101003 : K/30min ==> K/s + zx_tmp_fi3d(1:klon,1:klev)=d_t_ajs(1:klon,1:klev)/pdtphys + CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d) + CALL histwrite(nid_mth,"dtajs",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_ajs, zx_tmp_3d) + CALL histwrite(nid_mth,"dqajs",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c +cIM: 101003 : K/day ==> K/s +cIM: LMD_ARMIP3 zx_tmp_fi3d(1:klon,1:klev)=heat(1:klon,1:klev)*pdtphys/RDAY + zx_tmp_fi3d(1:klon,1:klev)=heat(1:klon,1:klev)/RDAY + CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d) + CALL histwrite(nid_mth,"dtswr",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c +cIM: 101003 : K/day ==> K/s +cIM: LMD_ARMIP3 zx_tmp_fi3d(1:klon,1:klev)=heat0(1:klon,1:klev)*pdtphys/RDAY + zx_tmp_fi3d(1:klon,1:klev)=heat0(1:klon,1:klev)/RDAY + CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d) + CALL histwrite(nid_mth,"dtsw0",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c +cIM: 101003 : K/day ==> K/s +cIM: LMD_ARMIP3 zx_tmp_fi3d(1:klon,1:klev)=-1.*cool(1:klon,1:klev)*pdtphys/RDAY + zx_tmp_fi3d(1:klon,1:klev)=-1.*cool(1:klon,1:klev)/RDAY + CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d) + CALL histwrite(nid_mth,"dtlwr",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c +cIM: 101003 : K/day ==> K/s +cIM: LMD_ARMIP3 zx_tmp_fi3d(1:klon,1:klev)=-1.*cool0(1:klon,1:klev)*pdtphys/RDAY + zx_tmp_fi3d(1:klon,1:klev)=-1.*cool0(1:klon,1:klev)/RDAY + CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d) + CALL histwrite(nid_mth,"dtlw0",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c +cIM: 101003 : deja en K/s + zx_tmp_fi3d(1:klon,1:klev)=d_t_ec(1:klon,1:klev) + CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d) + CALL histwrite(nid_mth,"dtec",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_vdf, zx_tmp_3d) + CALL histwrite(nid_mth,"duvdf",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_vdf, zx_tmp_3d) + CALL histwrite(nid_mth,"dvvdf",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + IF (ok_orodr) THEN + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_oro, zx_tmp_3d) + CALL histwrite(nid_mth,"duoro",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_oro, zx_tmp_3d) + CALL histwrite(nid_mth,"dvoro",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + ENDIF +C + IF (ok_orolf) THEN + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_lif, zx_tmp_3d) + CALL histwrite(nid_mth,"dulif",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_lif, zx_tmp_3d) + CALL histwrite(nid_mth,"dvlif",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) + ENDIF +C +c +c effets des aerosols +c +c IF (ok_ade.OR.ok_aie) THEN + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, re, zx_tmp_3d) + CALL histwrite(nid_mth,"re",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, fl, zx_tmp_3d) + CALL histwrite(nid_mth,"redenom",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldtau, zx_tmp_3d) + CALL histwrite(nid_mth,"tau",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldtaupi, zx_tmp_3d) + CALL histwrite(nid_mth,"taupi",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c endif +c + IF (nqmax.GE.3) THEN + DO iq=1,nqmax-2 + IF (iq.LE.99) THEN + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,iq+2), zx_tmp_3d) + WRITE(str2,'(i2.2)') iq + CALL histwrite(nid_mth,"trac"//str2,itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) + ELSE + PRINT*, "Trop de traceurs" + CALL abort + ENDIF + ENDDO + ENDIF +c + ENDIF !lev_histmth.GE.4 +c + if (ok_sync) then + call histsync(nid_mth) + endif + ENDIF Index: /LMDZ4/trunk/libf/phylmd/write_histmthNMC.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/write_histmthNMC.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/write_histmthNMC.h (revision 524) @@ -0,0 +1,62 @@ +! +! $Header$ +! +c IF (ok_mensuelNMC) THEN + IF (ok_mensuel) THEN +c + ndex2d = 0 + ndex3d = 0 +c +c Champs 2D: +c + + zsto = dtime + zout = dtime * ecrit_mth + itau_w = itau_phy + itap + + i = NINT(zout/zsto) +c +c Champs interpolles sur des niveaux de pression du NMC +c110304 BEG + DO k=1, nlevSTD +c + bb=clevSTD(k) +c + IF(k.GE.2) THEN + aa=clevSTD(k) + bb=aa(1:lnblnk1(aa)) + ENDIF +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, tlevSTD(:,k),zx_tmp_2d) + CALL histwrite(nid_nmc,"t"//bb,itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, philevSTD(:,k),zx_tmp_2d) + CALL histwrite(nid_nmc,"phi"//bb,itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, qlevSTD(:,k),zx_tmp_2d) + CALL histwrite(nid_nmc,"q"//bb,itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, rhlevSTD(:,k),zx_tmp_2d) + CALL histwrite(nid_nmc,"rh"//bb,itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, ulevSTD(:,k),zx_tmp_2d) + CALL histwrite(nid_nmc,"u"//bb,itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, vlevSTD(:,k),zx_tmp_2d) + CALL histwrite(nid_nmc,"v"//bb,itau_w,zx_tmp_2d, + $ iim*jjmp1,ndex2d) +c + ENDDO !k=1, nlevSTD +ccc +c110304 END +c + if (ok_sync) then + call histsync(nid_nmc) + endif + + ENDIF Index: /LMDZ4/trunk/libf/phylmd/write_histrac.h =================================================================== --- /LMDZ4/trunk/libf/phylmd/write_histrac.h (revision 524) +++ /LMDZ4/trunk/libf/phylmd/write_histrac.h (revision 524) @@ -0,0 +1,365 @@ +! +! $Header$ +! + ndex = 0 + ndex2d = 0 + ndex3d = 0 +c + zsto = pdtphys + zout = pdtphys * FLOAT(ecrit_tra) + itau_w = itau_phy + nstep + + + i = NINT(zout/zsto) + CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d) + CALL histwrite(nid_tra,"phis",itau_w,zx_tmp_2d,iim*(jjm+1),ndex2d) +C + CALL gr_fi_ecrit(1,klon,iim,jjm+1,airephy,zx_tmp_2d) + CALL histwrite(nid_tra,"aire",itau_w,zx_tmp_2d,iim*(jjm+1),ndex2d) +#ifdef INCA + CALL gr_fi_ecrit(1, klon,iim,jjm+1, ps,zx_tmp_2d) + CALL histwrite(nid_tra,"ps",itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjm+1, ptrop,zx_tmp_2d) + CALL histwrite(nid_tra,"ptrop",itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) + +C 3d FIELDS + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,t_seri, zx_tmp_3d) + CALL histwrite(nid_tra,"temp",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,u, zx_tmp_3d) + CALL histwrite(nid_tra,"u",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,v, zx_tmp_3d) + CALL histwrite(nid_tra,"v",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,sh, zx_tmp_3d) + CALL histwrite(nid_tra,"h2o",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pdel, zx_tmp_3d) + CALL histwrite(nid_tra,"pdel",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pplay, zx_tmp_3d) + CALL histwrite(nid_tra,"pmid",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + +#ifdef INCA_CH4 +#ifdef INCAINFO + DO it=1, phtcnt + WRITE(str2,'(i2.2)') it + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,jrates(1,1,it), + . zx_tmp_3d) + CALL histwrite(nid_tra,"j"//str2,itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + ENDDO + + DO it=1, hetcnt + WRITE(str2,'(i2.2)') it + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,hrates(1,1,it), + . zx_tmp_3d) + CALL histwrite(nid_tra,"w"//str2,itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + ENDDO + + DO it=1, extcnt + WRITE(str2,'(i2.2)') it + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,extflx(1,1,it), + . zx_tmp_3d) + CALL histwrite(nid_tra,"ext"//str2,itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + ENDDO + + DO it=1, nfs + WRITE(str2,'(i2.2)') it + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,invariants(1,1,it), + . zx_tmp_3d) + CALL histwrite(nid_tra,"INV"//str2,itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + ENDDO +#else + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,jrates(1,1,2), + . zx_tmp_3d) + CALL histwrite(nid_tra,"jO3",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,jrates(1,1,4), + . zx_tmp_3d) + CALL histwrite(nid_tra,"jNO2",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,jrates(1,1,13), + . zx_tmp_3d) + CALL histwrite(nid_tra,"jH2O2",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,hrates(1,1,1), + . zx_tmp_3d) + CALL histwrite(nid_tra,"wHNO3",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,krates(1,1,1), + . zx_tmp_3d) + CALL histwrite(nid_tra,"kN2O5",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,extflx(1,1,1), + . zx_tmp_3d) + CALL histwrite(nid_tra,"LghtNO",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) +#endif + DO it=1, grpcnt + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,nas(1,1,it),zx_tmp_3d) + zx_tmp_3d = zx_tmp_3d * dry_mass / nadv_mass(it) + CALL histwrite(nid_tra,grpsym(it),itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + ENDDO +#endif + +#ifdef INCA_AER + + it = id_CIDUSTM + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,scavcoef_st(1,1,it), + . zx_tmp_3d) + CALL histwrite(nid_tra,"scavcoef_st",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,scavcoef_cv(1,1,it), + . zx_tmp_3d) + CALL histwrite(nid_tra,"scavcoef_cv",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + + CALL gr_fi_ecrit(1, klon,iim,jjm+1,angst(1),zx_tmp_2d) + CALL histwrite(nid_tra2,"AngstroemComp",itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) + +#endif +#endif + + DO it=1,nqmax +C champs 2D +#ifdef INCA + IF ( prt_flag_ts(it) == 0 ) CYCLE + CALL gr_fi_ecrit(1, klon,iim,jjm+1, eflux(1,it),zx_tmp_2d) + CALL histwrite(nid_tra,"Emi_"//solsym(it),itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjm+1, dvel(1,it),zx_tmp_2d) + CALL histwrite(nid_tra,"Dep_"//solsym(it),itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) +#ifdef INCA_AER + call diag(airephy,tr_seri) + + IF ((it .ge. trmx) .and. (it .le. trnx)) then + CALL gr_fi_ecrit(1, klon,iim,jjm+1,sflux(1,it),zx_tmp_2d) + CALL histwrite(nid_tra2,"Sed_"//solsym(it),itau_w, + . zx_tmp_2d,iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjm+1,dflux(1,it),zx_tmp_2d) + CALL histwrite(nid_tra2,"Dry_"//solsym(it),itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) + CALL gr_fi_ecrit(1, klon,iim,jjm+1,wflux(1,it),zx_tmp_2d) + CALL histwrite(nid_tra2,"Wet_"//solsym(it),itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) + CALL gr_fi_ecrit(1, klon,iim,jjm+1,wsflux(1,it),zx_tmp_2d) + CALL histwrite(nid_tra2,"WetST_"//solsym(it),itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) + CALL gr_fi_ecrit(1, klon,iim,jjm+1,wcflux(1,it),zx_tmp_2d) + CALL histwrite(nid_tra2,"WetCV_"//solsym(it),itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(klev, klon,iim,jjm+1,eflux_alt(1,1,it),zx_tmp_3d) + CALL histwrite(nid_tra2,"Emi_alt_"//solsym(it),itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + + CALL gr_fi_ecrit(1, klon,iim,jjm+1,aload(1,it),zx_tmp_2d) + CALL histwrite(nid_tra2,"Load_"//solsym(it),itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) + CALL histwrite(nid_tra3,"Inst_Load_"//solsym(it),itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjm+1,sconc(1,it),zx_tmp_2d) + CALL histwrite(nid_tra2,"SConc_"//solsym(it),itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) + + do la=1,las + CALL gr_fi_ecrit(1, klon,iim,jjm+1,tausum(1,la,it),zx_tmp_2d) + CALL histwrite(nid_tra2,"OD_"//cla(la)//solsym(it),itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) + enddo + + CALL gr_fi_ecrit(klev, klon,iim,jjm+1,md(1,1,it),zx_tmp_3d) + CALL histwrite(nid_tra2,"MD_"//solsym(it),itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + + endif +#endif +C champs 3D + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,tr_seri(1,1,it),zx_tmp_3d) + + !Prefer vmr to mmr for transported species + if( adv_mass(it) /= 0. ) then +#ifdef INCA_AER + if (it .lt. trmx) then +#endif + zx_tmp_3d = zx_tmp_3d * dry_mass / adv_mass(it) +#ifdef INCA_AER + endif +#endif + else +#ifdef INCA_CH4 + if ( solsym(it) == 'OX' ) then + zx_tmp_3d = zx_tmp_3d * dry_mass / nadv_mass(id_o3) + end if +#endif + end if + + CALL histwrite(nid_tra,solsym(it),itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) +#else + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,tr_seri(1,1,it),zx_tmp_3d) + CALL histwrite(nid_tra,tnom(it+2),itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + if (lessivage) THEN + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,flestottr(1,1,it),zx_tmp_3d) + CALL histwrite(nid_tra,"fl"//tnom(it+2),itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + endif +#endif + ENDDO + +#ifdef INCA +#ifdef INCA_CH4 + CALL gr_fi_ecrit(1, klon,iim,jjm+1, o3_tr_col(1), zx_tmp_2d) + CALL histwrite(nid_tra,"O3_column",itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjm+1, co_tr_col(1), zx_tmp_2d) + CALL histwrite(nid_tra,"CO_column",itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjm+1, ch4_tr_col(1), zx_tmp_2d) + CALL histwrite(nid_tra,"CH4_column",itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjm+1, no2_tr_col(1), zx_tmp_2d) + CALL histwrite(nid_tra,"NO2_column",itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjm+1, o3_st_flx(1), zx_tmp_2d) + CALL histwrite(nid_tra,"O3_ste",itau_w,zx_tmp_2d, + . iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,o3_prod(1,1), + . zx_tmp_3d) + CALL histwrite(nid_tra,"O3_prod",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,o3_loss(1,1), + . zx_tmp_3d) + CALL histwrite(nid_tra,"O3_loss",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + +! ... Special section for daytime averaging +! CALL gr_fi_ecrit(klev,klon,iim,jjm+1,day_cnt(1,1), +! . zx_tmp_3d) +! CALL histwrite(nid_tra,"day_cnt",itau_w,zx_tmp_3d, +! . iim*(jjm+1)*klev,ndex3d) +! CALL gr_fi_ecrit(klev,klon,iim,jjm+1,no_daytime(1,1), +! . zx_tmp_3d) +! CALL histwrite(nid_tra,"NO_day",itau_w,zx_tmp_3d, +! . iim*(jjm+1)*klev,ndex3d) + +#endif +#else + +C abder + CALL gr_fi_ecrit(1,klon,iim,jjm+1,yu1,zx_tmp_2d) + CALL histwrite(nid_tra,"pyu1",itau_w,zx_tmp_2d, + s iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(1,klon,iim,jjm+1,yv1,zx_tmp_2d) + CALL histwrite(nid_tra,"pyv1",itau_w,zx_tmp_2d, + s iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol1,zx_tmp_2d) + CALL histwrite(nid_tra,"ftsol1",itau_w,zx_tmp_2d, + s iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol2,zx_tmp_2d) + CALL histwrite(nid_tra,"ftsol2",itau_w,zx_tmp_2d, + s iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol3,zx_tmp_2d) + CALL histwrite(nid_tra,"ftsol3",itau_w,zx_tmp_2d, + s iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol4,zx_tmp_2d) + CALL histwrite(nid_tra,"ftsol4",itau_w,zx_tmp_2d, + s iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf1,zx_tmp_2d) + CALL histwrite(nid_tra,"psrf1",itau_w,zx_tmp_2d, + s iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf2,zx_tmp_2d) + CALL histwrite(nid_tra,"psrf2",itau_w,zx_tmp_2d, + s iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf3,zx_tmp_2d) + CALL histwrite(nid_tra,"psrf3",itau_w,zx_tmp_2d, + s iim*(jjm+1),ndex2d) + + CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf4,zx_tmp_2d) + CALL histwrite(nid_tra,"psrf4",itau_w,zx_tmp_2d, + s iim*(jjm+1),ndex2d) + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pplay,zx_tmp_3d) + CALL histwrite(nid_tra,"pplay",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,t_seri,zx_tmp_3d) + CALL histwrite(nid_tra,"t",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pmfu,zx_tmp_3d) + CALL histwrite(nid_tra,"mfu",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pmfd,zx_tmp_3d) + CALL histwrite(nid_tra,"mfd",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pen_u,zx_tmp_3d) + CALL histwrite(nid_tra,"en_u",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pen_d,zx_tmp_3d) + CALL histwrite(nid_tra,"en_d",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pde_d,zx_tmp_3d) + CALL histwrite(nid_tra,"de_d",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pde_u,zx_tmp_3d) + CALL histwrite(nid_tra,"de_u",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + CALL gr_fi_ecrit(klev,klon,iim,jjm+1,coefh,zx_tmp_3d) + CALL histwrite(nid_tra,"coefh",itau_w,zx_tmp_3d, + . iim*(jjm+1)*klev,ndex3d) + + +c abder +#endif + + if (ok_sync) then + call histsync(nid_tra) +#ifdef INCA_AER + call histsync(nid_tra2) + call histsync(nid_tra3) +#endif + endif + + Index: /LMDZ4/trunk/libf/phylmd/zilch.F =================================================================== --- /LMDZ4/trunk/libf/phylmd/zilch.F (revision 524) +++ /LMDZ4/trunk/libf/phylmd/zilch.F (revision 524) @@ -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/trunk/makegcm =================================================================== --- /LMDZ4/trunk/makegcm (revision 524) +++ /LMDZ4/trunk/makegcm (revision 524) @@ -0,0 +1,951 @@ +#!/bin/csh +# +# $Header$ +# +#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. ' +set ntrac = 4 +set filtre=filtrez +set grille=reg +set couple=false +set veget=true +set psmile=false +set OPT_STACK='-Wf,-init stack=nan' +set OPT_STACK=' ' +set OPTIMI='-C debug -eC ' +set OPTIMI=' -ftrace ' +set io=ioipsl + +######################################################################## +# path a changer contenant les sources et les objets du modele +######################################################################## + +###### VERSION LMDZ.4 +# set LMDGCM=$HOME/LMDZ.4 +# + +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 + 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 +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 ) 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 + 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 opt_dep="" + +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" + set oplink="-Wl'-DSTACK=128 -f indef' -L$IOIPSLDIR -lioipsl -L$NCDFLIB -lnetcdf " + set mod_loc_dir=" " + set mod_suffix=" " +################# +else if $SUN then +################# + set optim=" -fast " + set optimbis=" " + set optim90=" -fast -fixed " + set optimtru90=" -fast -free " + set opt_link="-lf77compat -L$MODIPSLDIR -lsechiba -lparameters -lstomate -lioipsl -L$NCDFLIB -lnetcdf " + 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 +################# + set optim="-fast " + set optim90=" -fast " + set optimtru90=" -fast -c -Mfree -module $MODIPSLDIR " + set opt_link=" -Mfree -L /usr/local/pgi/linux86/lib -lpgf90 -lpgftnrtl -lpghpf -lpghpf2 -L$MODIPSLDIR -lsechiba -lparameters -lstomate -L$NCDFLIB -lnetcdf -lioipsl -Wl,-Bstatic -L/usr/lib/gcc-lib/i386-linux/2.95.2/" + 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=" " + set opt_link=" -C hopt -float0 -ew -P static -L$MODIPSLDIR -lioipsl $NCDFLIB -lnetcdf_i8r8_v " + set mod_loc_dir="." + set mod_suffix="mod" +################# +else if $XNEC then +################# + set optdbl='-dw -Wf\"-A dbl4\"' + set optim90=' -clear -float0 -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" +else if $X6NEC then + set optdbl='-dw -Wf\"-A dbl4\"' + set optim90=' -clear -float0 -size_t64 -Ep -DNC_DOUBLE -dw -Wf\"-A dbl4\" -R5 -Wf,"-pvctl loopcnt=40000 fullmsg noassume "' + set optimtru90=' -clear -f4 -float0 -size_t64 -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" +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 -n -e 's/[^0-9]/ /gp'` + set dim_=`echo $dim | sed -n -e 's/[^0-9]/_/gp'` +endif +set nomlib=${nomlib}${physique}_${dim_}_t${ntrac}_$grille +## M-A-F nomlib trop long sur CRAY pour ar +if ( $CRAY ) then + set nomlib=F90_${dim_}_t${ntrac} +endif +if ( $NEC || $XNEC || $X6NEC) then + set nomlib=F90_${dim_}_t${ntrac} +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 ' +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/nombre de traceur +######################################################################## + +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 $ntrac $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 + +######################################################################## +# utilisation des vraies routines de couplage si on est en couple +######################################################################## +if ( $couple == 'true' ) then + banner couple + pwd + if ( `diff $libf/phy$physique/oasis.F $libf/phy$physique/oasis.true | wc -w` ) then + \cp $libf/phy$physique/oasis.F $libf/phy$physique/oasis.dummy + \cp $libf/phy$physique/oasis.true $libf/phy$physique/oasis.F + endif +else + if ( `diff $libf/phy$physique/oasis.F $libf/phy$physique/oasis.dummy | wc -w` ) then + \cp $libf/phy$physique/oasis.F $libf/phy$physique/oasis.true + \cp $libf/phy$physique/oasis.dummy $libf/phy$physique/oasis.F + endif +endif +######################################################################## +# 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. +######################################################################## + +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 opt_link=" -Mfree -L /usr/local/pgi/linux86/lib -lpgf90 -lpgftnrtl -lpghpf -lpghpf2 -L$MODIPSLDIR $link_veget -L$NCDFLIB -lnetcdf -lioipsl -Wl,-Bstatic -L/usr/lib/gcc-lib/i386-linux/2.95.2/" +################# +else if $SUN then +################# + set f77=f90 + set f90=f90 + set opt_link="-lf77compat -L$MODIPSLDIR $link_veget -lioipsl -L$NCDFLIB -lnetcdf " +################# +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 + set opt_link="$opt_link -lsxioipsl -loasis2.4_mpi2 -float0 $optdbl -P static $NCDFLIB " + if ($psmile == true) then + 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 + set mod_loc_dir="./" +################## +else if $X6NEC then +################## + set f77=sxmpif90 + set f90=sxmpif90 + if $MODIPSL then + set opt_link="-L$MODIPSLDIR" + if ($veget == true) then + set opt_link="$opt_link -lsxsechiba -lsxparameters -lsxstomate" + endif + if ($couple == true) then + set opt_link="$opt_link -lsxioipsl -loasis2.4_mpi2 -float0 -size_t64 $optdbl -P static $NCDFLIB " + 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 " + 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 +set make="make RANLIB=ranlib" +endif + + + +# +# les deux test suivants sont "temporaires" pour pallier des "faiblesses" du +# compilateur fortran Sun: f90: SC4.0 11 Sep 1995 FORTRAN 90 1.1 +# +#if ($code == 'create_limit' && $SUN) then +# set link=f77 +# set opt_link="-L$NCDFLIB -lnetcdf" +#endif + +#if ($code == 'create_etat0' && $SUN) then +# if ( ! -f $libo/libdyn3d.a ) then +# echo "Priere de compiler gcm en premier pour des raisons d'optimisation" +# \rm $libf/grid/dimensions.h +# exit +# endif +# set optim=" -dalign " +# set optim90=" -dalign -fixed " +# set opt_link="-L$IOIPSLDIR -lioipsl -L$NCDFLIB -lnetcdf" +# set link="$f90 $optim90" +# touch $LMDGCM/libf/dyn3d/startvar.F +# touch $LMDGCM/libf/dyn3d/etat0_netcdf.F +#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 $LINUX then + set optim90=" $optim90 -module $libo " + 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 " +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 \ +L_ADJNT="$adjnt" \ +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 \ +L_ADJNT="$adjnt" \ +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/trunk/offline.def =================================================================== --- /LMDZ4/trunk/offline.def (revision 524) +++ /LMDZ4/trunk/offline.def (revision 524) @@ -0,0 +1,12 @@ +# +# $Header$ +# +T +4 +T +-2. +48.1 +1 +T +6 +2 Index: /LMDZ4/trunk/orchidee.def =================================================================== --- /LMDZ4/trunk/orchidee.def (revision 524) +++ /LMDZ4/trunk/orchidee.def (revision 524) @@ -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/trunk/physiq.def =================================================================== --- /LMDZ4/trunk/physiq.def (revision 524) +++ /LMDZ4/trunk/physiq.def (revision 524) @@ -0,0 +1,82 @@ +# +# $Header$ +# + +OCEAN=force +VEGET=y +OK_journe=n +OK_mensuel=y +OK_instan=n +if_ebil=0 +# +# parametres KE +# +epmax = .99 +ok_adj_ema = n +iflag_clw = 1 +# +# parametres nuages +# +cld_lc_lsc = 0.00026 +cld_lc_con = 0.00026 +cld_tau_lsc = 3600. +cld_tau_con = 3600. +ffallv_lsc = 1. +ffallv_con = 1. +coef_eva = 0.00002 +reevap_ice = y +iflag_cldcon = 3 +iflag_pdf = 1 +fact_cldcon = 1. +#facttemps = 1.e-4 +facttemps = 0.0001 +ok_newmicro = y +ratqsbas = 0.005 +ratqshaut = 0.33 +rad_froid = 35 +rad_chau1=12 +rad_chau2=11 +#ksta_ter=1.e-7 +ksta_ter=0.0000001 +# +# parametres outputs +# +#niveau de sortie "hf" lev_histhf avec +# - lev_histhf=3 => defaut +# - lev_histhf=4 => histhf3d.nc champs 3d niveaux modele +lev_histhf=3 +#niveau de sortie "day" lev_histday +# - lev_histday=2 => defaut +# - lev_histday=3 => + champs 3D => F. Lott +# - lev_histday=4 => + champs sous-surfaces +lev_histday=2 +#niveau de sortie "mth" lev_histmth avec +# - lev_histmth=2 => defaut +# - lev_histmth=3 => albedo, rugosite sous-surfaces +# - lev_histmth=4 => champs tendances 3d +lev_histmth=2 +# +# parametres climatique +# +R_ecc = 0.016715 +R_peri = 102.7 +R_incl = 23.441 +solaire = 1365. +co2_ppm = 348. +CH4_ppb = 1650. +N2O_ppb = 306. +CFC11_ppt = 280. +CFC12_ppt = 484. +# +# parametres simulateur ISCCP +# +top_height = 3 +#overlap = 1, 2 ou 3 +overlap = 3 +#cdmmax +#cdmmax = 2.5E-3 +cdmmax = 0.0025 +#cdhmax +#cdhmax = 2.0E-3 +cdhmax = 0.002 + Index: /LMDZ4/trunk/run.def =================================================================== --- /LMDZ4/trunk/run.def (revision 524) +++ /LMDZ4/trunk/run.def (revision 524) @@ -0,0 +1,20 @@ +# +# $Header$ +# +INCLUDEDEF=physiq.def +INCLUDEDEF=gcm.def +INCLUDEDEF=orchidee.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=1979 +## Nombre de jours d'integration +nday=1 +## periode de sortie des variables de controle (en pas) +iconser=5 +## periode d'ecriture du fichier histoire (en jour) +iecri=1 +## periode de stockage fichier histmoy (en jour) +periodav=1. +## unite de sortie des impressions +lunout=7 Index: /LMDZ4/trunk/traceur.def =================================================================== --- /LMDZ4/trunk/traceur.def (revision 524) +++ /LMDZ4/trunk/traceur.def (revision 524) @@ -0,0 +1,8 @@ +# +# $Header$ +# +4 +10 10 H2Ov +10 10 H2Ol +10 10 RN +10 10 PB