/[lmdze]/trunk/Sources/phylmd/phystokenc.f
ViewVC logotype

Diff of /trunk/Sources/phylmd/phystokenc.f

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

trunk/libf/phylmd/phystokenc.f revision 7 by guez, Mon Mar 31 12:24:17 2008 UTC trunk/Sources/phylmd/phystokenc.f revision 201 by guez, Mon Jun 6 17:42:15 2016 UTC
# Line 1  Line 1 
1  !  module phystokenc_m
 ! $Header: /home/cvsroot/LMDZ4/libf/phylmd/phystokenc.F,v 1.2 2004/06/22 11:45:35 lmdzadmin Exp $  
 !  
 c  
 c  
       SUBROUTINE phystokenc (  
      I                   pdtphys,rlon,rlat,  
      I                   pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,  
      I                   pfm_therm,pentr_therm,  
      I                   pcoefh,yu1,yv1,ftsol,pctsrf,  
      I                   frac_impa,frac_nucl,  
      I                   pphis,paire,dtime,itap)  
       USE ioipsl  
       USE histcom  
   
       use dimens_m  
       use indicesol  
       use dimphy  
       use conf_gcm_m  
       use tracstoke  
       IMPLICIT none  
   
 c======================================================================  
 c Auteur(s) FH  
 c Objet: Moniteur general des tendances traceurs  
 c  
   
 c======================================================================  
 c======================================================================  
   
 c Arguments:  
 c  
 c   EN ENTREE:  
 c   ==========  
 c  
 c   divers:  
 c   -------  
 c  
       real pdtphys ! pas d'integration pour la physique (seconde)  
 c  
       integer physid  
       integer, intent(in):: itap  
       save physid  
       integer ndex2d(iim*(jjm+1)),ndex3d(iim*(jjm+1)*klev)  
   
 c   convection:  
 c   -----------  
 c  
       REAL pmfu(klon,klev)  ! flux de masse dans le panache montant  
       REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant  
       REAL pen_u(klon,klev) ! flux entraine dans le panache montant  
       REAL pde_u(klon,klev) ! flux detraine dans le panache montant  
       REAL pen_d(klon,klev) ! flux entraine dans le panache descendant  
       REAL pde_d(klon,klev) ! flux detraine dans le panache descendant  
         real pt(klon,klev),t(klon,klev)  
 c  
       REAL, intent(in):: rlon(klon), rlat(klon)  
       real 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   Les Thermiques : (Abderr 25 11 02)  
 c   ---------------  
       REAL pfm_therm(klon,klev+1)  
         real fm_therm1(klon,klev)  
       REAL pentr_therm(klon,klev)  
       REAL entr_therm(klon,klev)  
       REAL fm_therm(klon,klev)  
 c  
 c   Lessivage:  
 c   ----------  
 c  
       REAL frac_impa(klon,klev)  
       REAL frac_nucl(klon,klev)  
 c  
 c Arguments necessaires pour les sources et puits de traceur  
 C  
       real ftsol(klon,nbsrf)  ! Temperature du sol (surf)(Kelvin)  
       real pctsrf(klon,nbsrf) ! Pourcentage de sol f(nature du sol)  
 c======================================================================  
 c  
       INTEGER i, k  
 c  
       REAL 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 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  
       logical ok_sync  
   
       save t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,dtcum  
         save fm_therm,entr_therm  
       save iadvtr,irec  
       save pyu1,pyv1,pftsol,ppsrf  
   
       data iadvtr,irec/0,1/  
 c  
 c   Couche limite:  
 c======================================================================  
   
       ok_sync = .true.  
         print*,'Dans phystokenc.F'  
       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'  
   
           
       ENDIF  
 c  
       ndex2d = 0  
       ndex3d = 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),ndex2d)  
 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),ndex2d)  
   
       iadvtr=iadvtr+1  
 c  
       if (mod(iadvtr,istphy).eq.1.or.istphy.eq.1) then  
         print*,'reinitialisation des champs cumules  
      s          a iadvtr=',iadvtr  
          do k=1,klev  
             do i=1,klon  
                mfu(i,k)=0.  
                mfd(i,k)=0.  
                en_u(i,k)=0.  
                de_u(i,k)=0.  
                en_d(i,k)=0.  
                de_d(i,k)=0.  
                coefh(i,k)=0.  
                 t(i,k)=0.  
                 fm_therm(i,k)=0.  
                entr_therm(i,k)=0.  
             enddo  
          enddo  
          do i=1,klon  
             pyv1(i)=0.  
             pyu1(i)=0.  
          end do  
          do k=1,nbsrf  
              do i=1,klon  
                pftsol(i,k)=0.  
                ppsrf(i,k)=0.  
             enddo  
          enddo  
   
          dtcum=0.  
       endif  
   
       do k=1,klev  
          do i=1,klon  
             mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys  
             mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys  
             en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys  
             de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys  
             en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys  
             de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys  
             coefh(i,k)=coefh(i,k)+pcoefh(i,k)*pdtphys  
                 t(i,k)=t(i,k)+pt(i,k)*pdtphys  
        fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys  
        entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys  
          enddo  
       enddo  
          do i=1,klon  
             pyv1(i)=pyv1(i)+yv1(i)*pdtphys  
             pyu1(i)=pyu1(i)+yu1(i)*pdtphys  
          end do  
          do k=1,nbsrf  
              do i=1,klon  
                pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys  
                ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys  
             enddo  
          enddo  
   
       dtcum=dtcum+pdtphys  
   
       IF(mod(iadvtr,istphy).eq.0) THEN  
 c  
 c   normalisation par le temps cumule  
          do k=1,klev  
             do i=1,klon  
                mfu(i,k)=mfu(i,k)/dtcum  
                mfd(i,k)=mfd(i,k)/dtcum  
                en_u(i,k)=en_u(i,k)/dtcum  
                de_u(i,k)=de_u(i,k)/dtcum  
                en_d(i,k)=en_d(i,k)/dtcum  
                de_d(i,k)=de_d(i,k)/dtcum  
                coefh(i,k)=coefh(i,k)/dtcum  
 c Unitel a enlever  
               t(i,k)=t(i,k)/dtcum        
                fm_therm(i,k)=fm_therm(i,k)/dtcum  
                entr_therm(i,k)=entr_therm(i,k)/dtcum  
             enddo  
          enddo  
          do i=1,klon  
             pyv1(i)=pyv1(i)/dtcum  
             pyu1(i)=pyu1(i)/dtcum  
          end do  
          do k=1,nbsrf  
              do i=1,klon  
                pftsol(i,k)=pftsol(i,k)/dtcum  
                pftsol1(i) = pftsol(i,1)  
                pftsol2(i) = pftsol(i,2)  
                pftsol3(i) = pftsol(i,3)  
                pftsol4(i) = pftsol(i,4)  
   
                ppsrf(i,k)=ppsrf(i,k)/dtcum  
                ppsrf1(i) = ppsrf(i,1)  
                ppsrf2(i) = ppsrf(i,2)  
                ppsrf3(i) = ppsrf(i,3)  
                ppsrf4(i) = ppsrf(i,4)  
   
             enddo  
          enddo  
 c  
 c   ecriture des champs  
 c  
          irec=irec+1  
   
 ccccc  
          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,ndex3d)  
   
          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,ndex3d)  
         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,ndex3d)  
         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,ndex3d)  
         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,ndex3d)  
         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,ndex3d)  
         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,ndex3d)  
         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,ndex3d)        
   
 c ajou...  
         do k=1,klev  
            do i=1,klon  
          fm_therm1(i,k)=fm_therm(i,k)    
            enddo  
         enddo  
   
       CALL gr_fi_ecrit(klev,klon,iim,jjm+1, fm_therm1, zx_tmp_3d)  
       CALL histwrite(physid,"fm_th",itap,zx_tmp_3d,  
      .                                 iim*(jjm+1)*klev,ndex3d)  
 c  
       CALL gr_fi_ecrit(klev,klon,iim,jjm+1, entr_therm, zx_tmp_3d)  
       CALL histwrite(physid,"en_th",itap,zx_tmp_3d,  
      .                                iim*(jjm+1)*klev,ndex3d)  
 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,ndex3d)  
   
         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,ndex3d)  
   
         CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyu1,zx_tmp_2d)  
       CALL histwrite(physid,"pyu1",itap,zx_tmp_2d,iim*(jjm+1),  
      .                                                ndex2d)  
           
         CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyv1,zx_tmp_2d)  
       CALL histwrite(physid,"pyv1",itap,zx_tmp_2d,iim*(jjm+1)  
      .                                                ,ndex2d)  
           
         CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol1, zx_tmp_2d)  
       CALL histwrite(physid,"ftsol1",itap,zx_tmp_2d,  
      .                                   iim*(jjm+1),ndex2d)  
          CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol2, zx_tmp_2d)  
       CALL histwrite(physid,"ftsol2",itap,zx_tmp_2d,  
      .                                   iim*(jjm+1),ndex2d)  
           CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol3, zx_tmp_2d)  
       CALL histwrite(physid,"ftsol3",itap,zx_tmp_2d,  
      .                                   iim*(jjm+1),ndex2d)  
          CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol4, zx_tmp_2d)  
       CALL histwrite(physid,"ftsol4",itap,zx_tmp_2d,  
      .                                   iim*(jjm+1),ndex2d)  
   
         CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf1, zx_tmp_2d)  
       CALL histwrite(physid,"psrf1",itap,zx_tmp_2d,    
      .                                   iim*(jjm+1),ndex2d)  
         CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf2, zx_tmp_2d)  
       CALL histwrite(physid,"psrf2",itap,zx_tmp_2d,  
      .                                   iim*(jjm+1),ndex2d)  
         CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf3, zx_tmp_2d)  
       CALL histwrite(physid,"psrf3",itap,zx_tmp_2d,  
      .                                   iim*(jjm+1),ndex2d)  
         CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf4, zx_tmp_2d)  
       CALL histwrite(physid,"psrf4",itap,zx_tmp_2d,  
      .                                   iim*(jjm+1),ndex2d)  
   
       if (ok_sync) call histsync(physid)  
 c     if (ok_sync) call histsync  
           
 c  
 cAA Test sur la valeur des coefficients de lessivage  
 c  
          zmin=1e33  
          zmax=-1e33  
          do k=1,klev  
             do i=1,klon  
                   zmax=max(zmax,frac_nucl(i,k))  
                   zmin=min(zmin,frac_nucl(i,k))  
             enddo  
          enddo  
          Print*,'------ coefs de lessivage (min et max) --------'  
          Print*,'facteur de nucleation ',zmin,zmax  
          zmin=1e33  
          zmax=-1e33  
          do k=1,klev  
             do i=1,klon  
                   zmax=max(zmax,frac_impa(i,k))  
                   zmin=min(zmin,frac_impa(i,k))  
             enddo  
          enddo  
          Print*,'facteur d impaction ',zmin,zmax  
   
       ENDIF  
   
 c   reinitialisation des champs cumules  
         go to 768  
       if (mod(iadvtr,istphy).eq.1) then  
          do k=1,klev  
             do i=1,klon  
                mfu(i,k)=0.  
                mfd(i,k)=0.  
                en_u(i,k)=0.  
                de_u(i,k)=0.  
                en_d(i,k)=0.  
                de_d(i,k)=0.  
                coefh(i,k)=0.  
                t(i,k)=0.  
                fm_therm(i,k)=0.  
                entr_therm(i,k)=0.  
             enddo  
          enddo  
          do i=1,klon  
             pyv1(i)=0.  
             pyu1(i)=0.  
          end do  
          do k=1,nbsrf  
              do i=1,klon  
                pftsol(i,k)=0.  
                ppsrf(i,k)=0.  
             enddo  
          enddo  
   
          dtcum=0.  
       endif  
   
       do k=1,klev  
          do i=1,klon  
             mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys  
             mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys  
             en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys  
             de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys  
             en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys  
             de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys  
             coefh(i,k)=coefh(i,k)+pcoefh(i,k)*pdtphys  
                 t(i,k)=t(i,k)+pt(i,k)*pdtphys  
        fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys  
        entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys  
          enddo  
       enddo  
          do i=1,klon  
             pyv1(i)=pyv1(i)+yv1(i)*pdtphys  
             pyu1(i)=pyu1(i)+yu1(i)*pdtphys  
          end do  
          do k=1,nbsrf  
              do i=1,klon  
                pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys  
                ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys  
             enddo  
          enddo  
2    
3        dtcum=dtcum+pdtphys    IMPLICIT NONE
 768   continue  
4    
5        RETURN  contains
6        END  
7      SUBROUTINE phystokenc(pdtphys, pt, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
8           pfm_therm, pentr_therm, pcoefh, yu1, yv1, ftsol, pctsrf, frac_impa, &
9           frac_nucl, pphis, paire, dtime)
10    
11        ! From phylmd/phystokenc.F, version 1.2 2004/06/22 11:45:35
12        ! Author: Fr\'ed\'eric Hourdin
13        ! Objet : \'ecriture des variables pour transport offline
14    
15        use gr_phy_write_m, only: gr_phy_write
16        USE histwrite_m, ONLY: histwrite
17        USE histsync_m, ONLY: histsync
18        USE dimens_m, ONLY: iim, jjm
19        USE indicesol, ONLY: nbsrf
20        use initphysto_m, only: initphysto
21        USE dimphy, ONLY: klev, klon
22        use time_phylmdz, only: itap
23        USE tracstoke, ONLY: istphy
24    
25        REAL, INTENT (IN):: pdtphys ! pas d'integration pour la physique (seconde)
26        REAL, intent(in):: pt(klon, klev)
27    
28        ! convection:
29    
30        REAL, INTENT (IN):: pmfu(klon, klev) ! flux de masse dans le panache montant
31    
32        REAL, intent(in):: pmfd(klon, klev)
33        ! flux de masse dans le panache descendant
34    
35        REAL, intent(in):: pen_u(klon, klev) ! flux entraine dans le panache montant
36        REAL, intent(in):: pde_u(klon, klev) ! flux detraine dans le panache montant
37    
38        REAL, intent(in):: pen_d(klon, klev)
39        ! flux entraine dans le panache descendant
40    
41        REAL, intent(in):: pde_d(klon, klev)
42        ! flux detraine dans le panache descendant
43    
44        ! Les Thermiques
45        REAL, intent(in):: pfm_therm(klon, klev+1)
46        REAL, intent(in):: pentr_therm(klon, klev)
47    
48        ! Couche limite:
49        REAL, intent(in):: pcoefh(klon, klev) ! coeff melange Couche limite
50        REAL, intent(in):: yu1(klon)
51        REAL, intent(in):: yv1(klon)
52    
53        ! Arguments necessaires pour les sources et puits de traceur
54    
55        REAL, intent(in):: ftsol(klon, nbsrf) ! Temperature du sol (surf)(Kelvin)
56        REAL, intent(in):: pctsrf(klon, nbsrf) ! Pourcentage de sol f(nature du sol)
57    
58        ! Coefficients de lessivage:
59        REAL, intent(in):: frac_impa(klon, klev) ! facteur d'impaction
60        REAL, intent(in):: frac_nucl(klon, klev) ! facteur de nucleation
61    
62        REAL, INTENT(IN):: pphis(klon)
63        real, intent(in):: paire(klon)
64        REAL, INTENT (IN):: dtime
65    
66        ! Local:
67    
68        real t(klon, klev)
69        INTEGER, SAVE:: physid
70    
71        ! Les Thermiques
72    
73        REAL fm_therm1(klon, klev)
74        REAL entr_therm(klon, klev)
75        REAL fm_therm(klon, klev)
76    
77        INTEGER i, k
78    
79        REAL, save:: mfu(klon, klev) ! flux de masse dans le panache montant
80        REAL mfd(klon, klev) ! flux de masse dans le panache descendant
81        REAL en_u(klon, klev) ! flux entraine dans le panache montant
82        REAL de_u(klon, klev) ! flux detraine dans le panache montant
83        REAL en_d(klon, klev) ! flux entraine dans le panache descendant
84        REAL de_d(klon, klev) ! flux detraine dans le panache descendant
85        REAL coefh(klon, klev) ! flux detraine dans le panache descendant
86    
87        REAL pyu1(klon), pyv1(klon)
88        REAL pftsol(klon, nbsrf), ppsrf(klon, nbsrf)
89        REAL pftsol1(klon), pftsol2(klon), pftsol3(klon), pftsol4(klon)
90        REAL ppsrf1(klon), ppsrf2(klon), ppsrf3(klon), ppsrf4(klon)
91    
92        REAL dtcum
93    
94        INTEGER:: iadvtr = 0, irec = 1
95    
96        SAVE t, mfd, en_u, de_u, en_d, de_d, coefh, dtcum
97        SAVE fm_therm, entr_therm
98        SAVE pyu1, pyv1, pftsol, ppsrf
99    
100        !------------------------------------------------------
101    
102        ! Couche limite:
103    
104        IF (iadvtr==0) CALL initphysto('phystoke', dtime, dtime * istphy, &
105             dtime * istphy, physid)
106    
107        CALL histwrite(physid, 'phis', itap, gr_phy_write(pphis))
108        CALL histwrite(physid, 'aire', itap, gr_phy_write(paire))
109        iadvtr = iadvtr + 1
110    
111        IF (mod(iadvtr, istphy) == 1 .OR. istphy == 1) THEN
112           PRINT *, 'reinitialisation des champs cumules a iadvtr =', iadvtr
113           DO k = 1, klev
114              DO i = 1, klon
115                 mfu(i, k) = 0.
116                 mfd(i, k) = 0.
117                 en_u(i, k) = 0.
118                 de_u(i, k) = 0.
119                 en_d(i, k) = 0.
120                 de_d(i, k) = 0.
121                 coefh(i, k) = 0.
122                 t(i, k) = 0.
123                 fm_therm(i, k) = 0.
124                 entr_therm(i, k) = 0.
125              END DO
126           END DO
127           DO i = 1, klon
128              pyv1(i) = 0.
129              pyu1(i) = 0.
130           END DO
131           DO k = 1, nbsrf
132              DO i = 1, klon
133                 pftsol(i, k) = 0.
134                 ppsrf(i, k) = 0.
135              END DO
136           END DO
137    
138           dtcum = 0.
139        END IF
140    
141        DO k = 1, klev
142           DO i = 1, klon
143              mfu(i, k) = mfu(i, k) + pmfu(i, k) * pdtphys
144              mfd(i, k) = mfd(i, k) + pmfd(i, k) * pdtphys
145              en_u(i, k) = en_u(i, k) + pen_u(i, k) * pdtphys
146              de_u(i, k) = de_u(i, k) + pde_u(i, k) * pdtphys
147              en_d(i, k) = en_d(i, k) + pen_d(i, k) * pdtphys
148              de_d(i, k) = de_d(i, k) + pde_d(i, k) * pdtphys
149              coefh(i, k) = coefh(i, k) + pcoefh(i, k) * pdtphys
150              t(i, k) = t(i, k) + pt(i, k) * pdtphys
151              fm_therm(i, k) = fm_therm(i, k) + pfm_therm(i, k) * pdtphys
152              entr_therm(i, k) = entr_therm(i, k) + pentr_therm(i, k) * pdtphys
153           END DO
154        END DO
155        DO i = 1, klon
156           pyv1(i) = pyv1(i) + yv1(i) * pdtphys
157           pyu1(i) = pyu1(i) + yu1(i) * pdtphys
158        END DO
159        DO k = 1, nbsrf
160           DO i = 1, klon
161              pftsol(i, k) = pftsol(i, k) + ftsol(i, k) * pdtphys
162              ppsrf(i, k) = ppsrf(i, k) + pctsrf(i, k) * pdtphys
163           END DO
164        END DO
165    
166        dtcum = dtcum + pdtphys
167    
168        IF (mod(iadvtr, istphy) == 0) THEN
169           ! normalisation par le temps cumule
170           DO k = 1, klev
171              DO i = 1, klon
172                 mfu(i, k) = mfu(i, k)/dtcum
173                 mfd(i, k) = mfd(i, k)/dtcum
174                 en_u(i, k) = en_u(i, k)/dtcum
175                 de_u(i, k) = de_u(i, k)/dtcum
176                 en_d(i, k) = en_d(i, k)/dtcum
177                 de_d(i, k) = de_d(i, k)/dtcum
178                 coefh(i, k) = coefh(i, k)/dtcum
179                 t(i, k) = t(i, k)/dtcum
180                 fm_therm(i, k) = fm_therm(i, k)/dtcum
181                 entr_therm(i, k) = entr_therm(i, k)/dtcum
182              END DO
183           END DO
184           DO i = 1, klon
185              pyv1(i) = pyv1(i)/dtcum
186              pyu1(i) = pyu1(i)/dtcum
187           END DO
188           DO k = 1, nbsrf
189              DO i = 1, klon
190                 pftsol(i, k) = pftsol(i, k)/dtcum
191                 pftsol1(i) = pftsol(i, 1)
192                 pftsol2(i) = pftsol(i, 2)
193                 pftsol3(i) = pftsol(i, 3)
194                 pftsol4(i) = pftsol(i, 4)
195    
196                 ppsrf(i, k) = ppsrf(i, k)/dtcum
197                 ppsrf1(i) = ppsrf(i, 1)
198                 ppsrf2(i) = ppsrf(i, 2)
199                 ppsrf3(i) = ppsrf(i, 3)
200                 ppsrf4(i) = ppsrf(i, 4)
201              END DO
202           END DO
203    
204           ! \'Ecriture des champs
205    
206           irec = irec + 1
207    
208           CALL histwrite(physid, 't', itap, gr_phy_write(t))
209           CALL histwrite(physid, 'mfu', itap, gr_phy_write(mfu))
210           CALL histwrite(physid, 'mfd', itap, gr_phy_write(mfd))
211           CALL histwrite(physid, 'en_u', itap, gr_phy_write(en_u))
212           CALL histwrite(physid, 'de_u', itap, gr_phy_write(de_u))
213           CALL histwrite(physid, 'en_d', itap, gr_phy_write(en_d))
214           CALL histwrite(physid, 'de_d', itap, gr_phy_write(de_d))
215           CALL histwrite(physid, 'coefh', itap, gr_phy_write(coefh))
216           DO k = 1, klev
217              DO i = 1, klon
218                 fm_therm1(i, k) = fm_therm(i, k)
219              END DO
220           END DO
221    
222           CALL histwrite(physid, 'fm_th', itap, gr_phy_write(fm_therm1))
223           CALL histwrite(physid, 'en_th', itap, gr_phy_write(entr_therm))
224           CALL histwrite(physid, 'frac_impa', itap, gr_phy_write(frac_impa))
225           CALL histwrite(physid, 'frac_nucl', itap, gr_phy_write(frac_nucl))
226           CALL histwrite(physid, 'pyu1', itap, gr_phy_write(pyu1))
227           CALL histwrite(physid, 'pyv1', itap, gr_phy_write(pyv1))
228           CALL histwrite(physid, 'ftsol1', itap, gr_phy_write(pftsol1))
229           CALL histwrite(physid, 'ftsol2', itap, gr_phy_write(pftsol2))
230           CALL histwrite(physid, 'ftsol3', itap, gr_phy_write(pftsol3))
231           CALL histwrite(physid, 'ftsol4', itap, gr_phy_write(pftsol4))
232           CALL histwrite(physid, 'psrf1', itap, gr_phy_write(ppsrf1))
233           CALL histwrite(physid, 'psrf2', itap, gr_phy_write(ppsrf2))
234           CALL histwrite(physid, 'psrf3', itap, gr_phy_write(ppsrf3))
235           CALL histwrite(physid, 'psrf4', itap, gr_phy_write(ppsrf4))
236    
237           CALL histsync(physid)
238        END IF
239    
240      END SUBROUTINE phystokenc
241    
242    end module phystokenc_m
Legend:
Removed from v.7  
changed lines
  Added in v.201
  ViewVC Help
Powered by ViewVC 1.1.21