/[lmdze]/trunk/libf/phylmd/physiq.f90
ViewVC logotype

Diff of /trunk/libf/phylmd/physiq.f90

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 16 by guez, Fri Aug 1 15:37:00 2008 UTC revision 22 by guez, Fri Jul 31 15:18:47 2009 UTC
# Line 10  module physiq_m Line 10  module physiq_m
10  contains  contains
11    
12    SUBROUTINE physiq(nq, firstcal, lafin, rdayvrai, gmtime, pdtphys, paprs, &    SUBROUTINE physiq(nq, firstcal, lafin, rdayvrai, gmtime, pdtphys, paprs, &
13         pplay, pphi, pphis, presnivs, u, v, t, qx, omega, d_u, d_v, &         pplay, pphi, pphis, u, v, t, qx, omega, d_u, d_v, &
14         d_t, d_qx, d_ps, dudyn, PVteta)         d_t, d_qx, d_ps, dudyn, PVteta)
15    
16      ! From phylmd/physiq.F, v 1.22 2006/02/20 09:38:28      ! From phylmd/physiq.F, v 1.22 2006/02/20 09:38:28
# Line 53  contains Line 53  contains
53      use hgardfou_m, only: hgardfou      use hgardfou_m, only: hgardfou
54      use conf_phys_m, only: conf_phys      use conf_phys_m, only: conf_phys
55      use phyredem_m, only: phyredem      use phyredem_m, only: phyredem
56        use qcheck_m, only: qcheck
57        use ozonecm_m, only: ozonecm
58    
59      ! Declaration des constantes et des fonctions thermodynamiques :      ! Declaration des constantes et des fonctions thermodynamiques :
60      use fcttre, only: thermcep, foeew, qsats, qsatl      use fcttre, only: thermcep, foeew, qsats, qsatl
61    
62      ! Variables argument:      ! Variables argument:
63    
64      INTEGER nq ! input nombre de traceurs (y compris vapeur d'eau)      INTEGER, intent(in):: nq ! nombre de traceurs (y compris vapeur d'eau)
65    
66      REAL, intent(in):: rdayvrai      REAL, intent(in):: rdayvrai
67      ! (elapsed time since January 1st 0h of the starting year, in days)      ! (elapsed time since January 1st 0h of the starting year, in days)
# Line 80  contains Line 82  contains
82    
83      REAL pphis(klon) ! input geopotentiel du sol      REAL pphis(klon) ! input geopotentiel du sol
84    
     REAL presnivs(llm)  
     ! (input pressions approximat. des milieux couches ( en PA))  
   
85      REAL u(klon, llm)  ! input vitesse dans la direction X (de O a E) en m/s      REAL u(klon, llm)  ! input vitesse dans la direction X (de O a E) en m/s
86      REAL v(klon, llm)  ! input vitesse Y (de S a N) en m/s      REAL v(klon, llm)  ! input vitesse Y (de S a N) en m/s
87      REAL t(klon, llm)  ! input temperature (K)      REAL t(klon, llm)  ! input temperature (K)
# Line 133  contains Line 132  contains
132      REAL fluxg(klon)    !flux turbulents ocean-atmosphere      REAL fluxg(klon)    !flux turbulents ocean-atmosphere
133    
134      ! Modele thermique du sol, a activer pour le cycle diurne:      ! Modele thermique du sol, a activer pour le cycle diurne:
135      logical ok_veget      logical, save:: ok_veget
136      save ok_veget      LOGICAL, save:: ok_journe ! sortir le fichier journalier
     LOGICAL ok_journe ! sortir le fichier journalier  
     save ok_journe  
137    
138      LOGICAL ok_mensuel ! sortir le fichier mensuel      LOGICAL ok_mensuel ! sortir le fichier mensuel
139    
# Line 218  contains Line 215  contains
215      INTEGER nout      INTEGER nout
216      PARAMETER(nout=3) !nout=1 : day; =2 : mth; =3 : NMC      PARAMETER(nout=3) !nout=1 : day; =2 : mth; =3 : NMC
217    
     REAL tsumSTD(klon, nlevSTD, nout)  
     REAL usumSTD(klon, nlevSTD, nout), vsumSTD(klon, nlevSTD, nout)  
     REAL wsumSTD(klon, nlevSTD, nout), phisumSTD(klon, nlevSTD, nout)  
     REAL qsumSTD(klon, nlevSTD, nout), rhsumSTD(klon, nlevSTD, nout)  
   
     SAVE tsumSTD, usumSTD, vsumSTD, wsumSTD, phisumSTD,  &  
          qsumSTD, rhsumSTD  
   
218      logical oknondef(klon, nlevSTD, nout)      logical oknondef(klon, nlevSTD, nout)
219      real tnondef(klon, nlevSTD, nout)      real tnondef(klon, nlevSTD, nout)
220      save tnondef      save tnondef
# Line 239  contains Line 228  contains
228      real vTSTD(klon, nlevSTD)      real vTSTD(klon, nlevSTD)
229      real wqSTD(klon, nlevSTD)      real wqSTD(klon, nlevSTD)
230    
     real uvsumSTD(klon, nlevSTD, nout)  
     real vqsumSTD(klon, nlevSTD, nout)  
     real vTsumSTD(klon, nlevSTD, nout)  
     real wqsumSTD(klon, nlevSTD, nout)  
   
231      real vphiSTD(klon, nlevSTD)      real vphiSTD(klon, nlevSTD)
232      real wTSTD(klon, nlevSTD)      real wTSTD(klon, nlevSTD)
233      real u2STD(klon, nlevSTD)      real u2STD(klon, nlevSTD)
234      real v2STD(klon, nlevSTD)      real v2STD(klon, nlevSTD)
235      real T2STD(klon, nlevSTD)      real T2STD(klon, nlevSTD)
236    
     real vphisumSTD(klon, nlevSTD, nout)  
     real wTsumSTD(klon, nlevSTD, nout)  
     real u2sumSTD(klon, nlevSTD, nout)  
     real v2sumSTD(klon, nlevSTD, nout)  
     real T2sumSTD(klon, nlevSTD, nout)  
   
     SAVE uvsumSTD, vqsumSTD, vTsumSTD, wqsumSTD  
     SAVE vphisumSTD, wTsumSTD, u2sumSTD, v2sumSTD, T2sumSTD  
     !MI Amip2  
   
237      ! prw: precipitable water      ! prw: precipitable water
238      real prw(klon)      real prw(klon)
239    
# Line 459  contains Line 433  contains
433      REAL albsollw(klon)      REAL albsollw(klon)
434      SAVE albsollw                 ! albedo du sol total      SAVE albsollw                 ! albedo du sol total
435    
436      REAL, SAVE:: wo(klon, llm) ! ozone      REAL, SAVE:: wo(klon, llm) ! column density of ozone in a cell, in kDU
437    
438      ! Declaration des procedures appelees      ! Declaration des procedures appelees
439    
# Line 470  contains Line 444  contains
444      EXTERNAL conema3  ! convect4.3      EXTERNAL conema3  ! convect4.3
445      EXTERNAL fisrtilp  ! schema de condensation a grande echelle (pluie)      EXTERNAL fisrtilp  ! schema de condensation a grande echelle (pluie)
446      EXTERNAL nuage     ! calculer les proprietes radiatives      EXTERNAL nuage     ! calculer les proprietes radiatives
     EXTERNAL ozonecm   ! prescrire l'ozone  
447      EXTERNAL radlwsw   ! rayonnements solaire et infrarouge      EXTERNAL radlwsw   ! rayonnements solaire et infrarouge
448      EXTERNAL transp    ! transport total de l'eau et de l'energie      EXTERNAL transp    ! transport total de l'eau et de l'energie
449    
# Line 621  contains Line 594  contains
594      save ratqsbas, ratqshaut, ratqs      save ratqsbas, ratqshaut, ratqs
595    
596      ! Parametres lies au nouveau schema de nuages (SB, PDF)      ! Parametres lies au nouveau schema de nuages (SB, PDF)
597      real fact_cldcon      real, save:: fact_cldcon
598      real facttemps      real, save:: facttemps
599      logical ok_newmicro      logical ok_newmicro
600      save ok_newmicro      save ok_newmicro
     save fact_cldcon, facttemps  
601      real facteur      real facteur
602    
603      integer iflag_cldcon      integer iflag_cldcon
# Line 633  contains Line 605  contains
605    
606      logical ptconv(klon, llm)      logical ptconv(klon, llm)
607    
     ! Variables liees a l'ecriture de la bande histoire physique  
   
     integer itau_w   ! pas de temps ecriture = itap + itau_phy  
   
608      ! Variables locales pour effectuer les appels en serie      ! Variables locales pour effectuer les appels en serie
609    
610      REAL t_seri(klon, llm), q_seri(klon, llm)      REAL t_seri(klon, llm), q_seri(klon, llm)
# Line 647  contains Line 615  contains
615      REAL d_tr(klon, llm, nbtr)      REAL d_tr(klon, llm, nbtr)
616    
617      REAL zx_rh(klon, llm)      REAL zx_rh(klon, llm)
     INTEGER ndex2d(iim*(jjm + 1)), ndex3d(iim*(jjm + 1)*llm)  
618    
619      REAL zustrdr(klon), zvstrdr(klon)      REAL zustrdr(klon), zvstrdr(klon)
620      REAL zustrli(klon), zvstrli(klon)      REAL zustrli(klon), zvstrli(klon)
# Line 686  contains Line 653  contains
653      INTEGER   ip_ebil  ! PRINT level for energy conserv. diag.      INTEGER   ip_ebil  ! PRINT level for energy conserv. diag.
654      SAVE      ip_ebil      SAVE      ip_ebil
655      DATA      ip_ebil/0/      DATA      ip_ebil/0/
656      INTEGER   if_ebil ! level for energy conserv. dignostics      INTEGER, SAVE:: if_ebil ! level for energy conservation diagnostics
     SAVE      if_ebil  
657      !+jld ec_conser      !+jld ec_conser
658      REAL d_t_ec(klon, llm)    ! tendance du a la conersion Ec -> E thermique      REAL d_t_ec(klon, llm)    ! tendance du a la conersion Ec -> E thermique
659      REAL ZRCPD      REAL ZRCPD
# Line 759  contains Line 725  contains
725      SAVE trmb2      SAVE trmb2
726      SAVE trmb3      SAVE trmb3
727    
728        real zmasse(klon, llm)
729        ! (column-density of mass of air in a cell, in kg m-2)
730    
731        real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2
732    
733      !----------------------------------------------------------------      !----------------------------------------------------------------
734    
735      modname = 'physiq'      modname = 'physiq'
# Line 901  contains Line 872  contains
872    
873         !   Initialisation des sorties         !   Initialisation des sorties
874    
875         call ini_histhf(pdtphys, presnivs, nid_hf, nid_hf3d)         call ini_histhf(pdtphys, nid_hf, nid_hf3d)
876         call ini_histday(pdtphys, presnivs, ok_journe, nid_day)         call ini_histday(pdtphys, ok_journe, nid_day, nq)
877         call ini_histins(pdtphys, presnivs, ok_instan, nid_ins)         call ini_histins(pdtphys, ok_instan, nid_ins)
878         CALL ymds2ju(annee_ref, 1, int(day_ref), 0., date0)         CALL ymds2ju(annee_ref, 1, int(day_ref), 0., date0)
879         !XXXPB Positionner date0 pour initialisation de ORCHIDEE         !XXXPB Positionner date0 pour initialisation de ORCHIDEE
880         WRITE(*, *) 'physiq date0 : ', date0         WRITE(*, *) 'physiq date0 : ', date0
# Line 1012  contains Line 983  contains
983      julien = MOD(NINT(rdayvrai), 360)      julien = MOD(NINT(rdayvrai), 360)
984      if (julien == 0) julien = 360      if (julien == 0) julien = 360
985    
986        forall (k = 1: llm) zmasse(:, k) = (paprs(:, k)-paprs(:, k+1)) / rg
987    
988      ! Mettre en action les conditions aux limites (albedo, sst, etc.).      ! Mettre en action les conditions aux limites (albedo, sst, etc.).
989      ! Prescrire l'ozone et calculer l'albedo sur l'ocean.      ! Prescrire l'ozone et calculer l'albedo sur l'ocean.
990    
991      IF (MOD(itap - 1, lmt_pas) == 0) THEN      if (nq >= 5) then
992         CALL ozonecm(REAL(julien), rlat, paprs, wo)         wo = qx(:, :, 5) * zmasse / dobson_u / 1e3
993        else IF (MOD(itap - 1, lmt_pas) == 0) THEN
994           wo = ozonecm(REAL(julien), paprs)
995      ENDIF      ENDIF
996    
997      ! Re-evaporer l'eau liquide nuageuse      ! Re-evaporer l'eau liquide nuageuse
# Line 1276  contains Line 1251  contains
1251         DO k = 1, llm         DO k = 1, llm
1252            DO i = 1, klon            DO i = 1, klon
1253               z_avant(i) = z_avant(i) + (q_seri(i, k)+ql_seri(i, k)) &               z_avant(i) = z_avant(i) + (q_seri(i, k)+ql_seri(i, k)) &
1254                    *(paprs(i, k)-paprs(i, k+1))/RG                    *zmasse(i, k)
1255            ENDDO            ENDDO
1256         ENDDO         ENDDO
1257      ENDIF      ENDIF
# Line 1304  contains Line 1279  contains
1279         ! (driver commun aux versions 3 et 4)         ! (driver commun aux versions 3 et 4)
1280    
1281         IF (ok_cvl) THEN ! new driver for convectL         IF (ok_cvl) THEN ! new driver for convectL
1282            CALL concvl (iflag_con, &            CALL concvl(iflag_con, pdtphys, paprs, pplay, t_seri, q_seri, &
                pdtphys, paprs, pplay, t_seri, q_seri, &  
1283                 u_seri, v_seri, tr_seri, ntra, &                 u_seri, v_seri, tr_seri, ntra, &
1284                 ema_work1, ema_work2, &                 ema_work1, ema_work2, &
1285                 d_t_con, d_q_con, d_u_con, d_v_con, d_tr, &                 d_t_con, d_q_con, d_u_con, d_v_con, d_tr, &
# Line 1320  contains Line 1294  contains
1294            pmfu=upwd+dnwd            pmfu=upwd+dnwd
1295         ELSE ! ok_cvl         ELSE ! ok_cvl
1296            ! MAF conema3 ne contient pas les traceurs            ! MAF conema3 ne contient pas les traceurs
1297            CALL conema3 (pdtphys, &            CALL conema3 (pdtphys, paprs, pplay, t_seri, q_seri, &
                paprs, pplay, t_seri, q_seri, &  
1298                 u_seri, v_seri, tr_seri, ntra, &                 u_seri, v_seri, tr_seri, ntra, &
1299                 ema_work1, ema_work2, &                 ema_work1, ema_work2, &
1300                 d_t_con, d_q_con, d_u_con, d_v_con, d_tr, &                 d_t_con, d_q_con, d_u_con, d_v_con, d_tr, &
# Line 1411  contains Line 1384  contains
1384         DO k = 1, llm         DO k = 1, llm
1385            DO i = 1, klon            DO i = 1, klon
1386               z_apres(i) = z_apres(i) + (q_seri(i, k)+ql_seri(i, k)) &               z_apres(i) = z_apres(i) + (q_seri(i, k)+ql_seri(i, k)) &
1387                    *(paprs(i, k)-paprs(i, k+1))/RG                    *zmasse(i, k)
1388            ENDDO            ENDDO
1389         ENDDO         ENDDO
1390         DO i = 1, klon         DO i = 1, klon
# Line 1568  contains Line 1541  contains
1541               do i=1, klon               do i=1, klon
1542                  if (d_q_con(i, k) < 0.) then                  if (d_q_con(i, k) < 0.) then
1543                     rain_tiedtke(i)=rain_tiedtke(i)-d_q_con(i, k)/pdtphys &                     rain_tiedtke(i)=rain_tiedtke(i)-d_q_con(i, k)/pdtphys &
1544                          *(paprs(i, k)-paprs(i, k+1))/rg                          *zmasse(i, k)
1545                  endif                  endif
1546               enddo               enddo
1547            enddo            enddo
# Line 1843  contains Line 1816  contains
1816      ENDDO      ENDDO
1817      DO k = 1, llm      DO k = 1, llm
1818         DO i = 1, klon         DO i = 1, klon
1819            zustrph(i)=zustrph(i)+(u_seri(i, k)-u(i, k))/pdtphys* &            zustrph(i)=zustrph(i)+(u_seri(i, k)-u(i, k))/pdtphys* zmasse(i, k)
1820                 (paprs(i, k)-paprs(i, k+1))/rg            zvstrph(i)=zvstrph(i)+(v_seri(i, k)-v(i, k))/pdtphys* zmasse(i, k)
           zvstrph(i)=zvstrph(i)+(v_seri(i, k)-v(i, k))/pdtphys* &  
                (paprs(i, k)-paprs(i, k+1))/rg  
1821         ENDDO         ENDDO
1822      ENDDO      ENDDO
1823    
1824      !IM calcul composantes axiales du moment angulaire et couple des montagnes      !IM calcul composantes axiales du moment angulaire et couple des montagnes
1825    
1826      CALL aaam_bud (27, klon, llm, gmtime, &      CALL aaam_bud(27, klon, llm, gmtime, &
1827           ra, rg, romega, &           ra, rg, romega, &
1828           rlat, rlon, pphis, &           rlat, rlon, pphis, &
1829           zustrdr, zustrli, zustrph, &           zustrdr, zustrli, zustrph, &
# Line 1874  contains Line 1845  contains
1845      call phytrac(rnpb, itap, lmt_pas, julien,  gmtime, firstcal, lafin, nq-2, &      call phytrac(rnpb, itap, lmt_pas, julien,  gmtime, firstcal, lafin, nq-2, &
1846           pdtphys, u, v, t, paprs, pplay, pmfu,  pmfd,  pen_u,  pde_u,  pen_d, &           pdtphys, u, v, t, paprs, pplay, pmfu,  pmfd,  pen_u,  pde_u,  pen_d, &
1847           pde_d, ycoefh, fm_therm, entr_therm, yu1, yv1, ftsol, pctsrf, &           pde_d, ycoefh, fm_therm, entr_therm, yu1, yv1, ftsol, pctsrf, &
1848           frac_impa,  frac_nucl, presnivs, pphis, pphi, albsol, rhcl, cldfra, &           frac_impa,  frac_nucl, pphis, pphi, albsol, rhcl, cldfra, &
1849           rneb,  diafra,  cldliq, itop_con, ibas_con, pmflxr, pmflxs, prfl, &           rneb,  diafra,  cldliq, itop_con, ibas_con, pmflxr, pmflxs, prfl, &
1850           psfl, da, phi, mp, upwd, dnwd, tr_seri)           psfl, da, phi, mp, upwd, dnwd, tr_seri, zmasse)
1851    
1852      IF (offline) THEN      IF (offline) THEN
1853    
# Line 1940  contains Line 1911  contains
1911      DO i = 1, klon      DO i = 1, klon
1912         prw(i) = 0.         prw(i) = 0.
1913         DO k = 1, llm         DO k = 1, llm
1914            prw(i) = prw(i) + &            prw(i) = prw(i) + q_seri(i, k)*zmasse(i, k)
                q_seri(i, k)*(paprs(i, k)-paprs(i, k+1))/RG  
1915         ENDDO         ENDDO
1916      ENDDO      ENDDO
1917    
# Line 1968  contains Line 1938  contains
1938      ENDIF      ENDIF
1939    
1940      ! Sauvegarder les valeurs de t et q a la fin de la physique:      ! Sauvegarder les valeurs de t et q a la fin de la physique:
   
1941      DO k = 1, llm      DO k = 1, llm
1942         DO i = 1, klon         DO i = 1, klon
1943            t_ancien(i, k) = t_seri(i, k)            t_ancien(i, k) = t_seri(i, k)
# Line 1977  contains Line 1946  contains
1946      ENDDO      ENDDO
1947    
1948      !   Ecriture des sorties      !   Ecriture des sorties
   
1949      call write_histhf      call write_histhf
1950      call write_histday      call write_histday
1951      call write_histins      call write_histins
1952    
1953      ! Si c'est la fin, il faut conserver l'etat de redemarrage      ! Si c'est la fin, il faut conserver l'etat de redemarrage
   
1954      IF (lafin) THEN      IF (lafin) THEN
1955         itau_phy = itau_phy + itap         itau_phy = itau_phy + itap
1956         CALL phyredem("restartphy.nc", rlat, rlon, pctsrf, ftsol, &         CALL phyredem("restartphy.nc", rlat, rlon, pctsrf, ftsol, &
# Line 2000  contains Line 1967  contains
1967      subroutine write_histday      subroutine write_histday
1968    
1969        use grid_change, only: gr_phy_write_3d        use grid_change, only: gr_phy_write_3d
1970          integer itau_w  ! pas de temps ecriture
1971    
1972        !------------------------------------------------        !------------------------------------------------
1973    
1974        if (ok_journe) THEN        if (ok_journe) THEN
          ndex2d = 0  
          ndex3d = 0  
1975           itau_w = itau_phy + itap           itau_w = itau_phy + itap
1976           call histwrite(nid_day, "Sigma_O3_Royer", itau_w, gr_phy_write_3d(wo))           if (nq <= 4) then
1977                call histwrite(nid_day, "Sigma_O3_Royer", itau_w, &
1978                     gr_phy_write_3d(wo) * 1e3)
1979                ! (convert "wo" from kDU to DU)
1980             end if
1981           if (ok_sync) then           if (ok_sync) then
1982              call histsync(nid_day)              call histsync(nid_day)
1983           endif           endif
# Line 2022  contains Line 1991  contains
1991    
1992        ! From phylmd/write_histhf.h, v 1.5 2005/05/25 13:10:09        ! From phylmd/write_histhf.h, v 1.5 2005/05/25 13:10:09
1993    
1994        ndex2d = 0        !------------------------------------------------
       ndex3d = 0  
   
       itau_w = itau_phy + itap  
1995    
1996        call write_histhf3d        call write_histhf3d
1997    
# Line 2042  contains Line 2008  contains
2008        ! From phylmd/write_histins.h, v 1.2 2005/05/25 13:10:09        ! From phylmd/write_histins.h, v 1.2 2005/05/25 13:10:09
2009    
2010        real zout        real zout
2011          integer itau_w  ! pas de temps ecriture
2012    
2013        !--------------------------------------------------        !--------------------------------------------------
2014    
2015        IF (ok_instan) THEN        IF (ok_instan) THEN
   
          ndex2d = 0  
          ndex3d = 0  
   
2016           ! Champs 2D:           ! Champs 2D:
2017    
2018           zsto = pdtphys * ecrit_ins           zsto = pdtphys * ecrit_ins
# Line 2278  contains Line 2241  contains
2241    
2242        ! From phylmd/write_histhf3d.h, v 1.2 2005/05/25 13:10:09        ! From phylmd/write_histhf3d.h, v 1.2 2005/05/25 13:10:09
2243    
2244        ndex2d = 0        integer itau_w  ! pas de temps ecriture
2245        ndex3d = 0  
2246          !-------------------------------------------------------
2247    
2248        itau_w = itau_phy + itap        itau_w = itau_phy + itap
2249    
# Line 2311  contains Line 2275  contains
2275    
2276    END SUBROUTINE physiq    END SUBROUTINE physiq
2277    
   !****************************************************  
   
   FUNCTION qcheck(klon, klev, paprs, q, ql, aire)  
   
     ! From phylmd/physiq.F, v 1.22 2006/02/20 09:38:28  
   
     use YOMCST  
     IMPLICIT none  
   
     ! Calculer et imprimer l'eau totale. A utiliser pour verifier  
     ! la conservation de l'eau  
   
     INTEGER klon, klev  
     REAL, intent(in):: paprs(klon, klev+1)  
     real q(klon, klev), ql(klon, klev)  
     REAL aire(klon)  
     REAL qtotal, zx, qcheck  
     INTEGER i, k  
   
     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  
   
     qcheck = qtotal/zx  
   
   END FUNCTION qcheck  
   
2278  end module physiq_m  end module physiq_m
Legend:
Removed from v.16  
changed lines
  Added in v.22
  ViewVC Help
Powered by ViewVC 1.1.21