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

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

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

trunk/libf/phylmd/phystokenc.f revision 31 by guez, Thu Apr 1 14:59:19 2010 UTC trunk/libf/phylmd/phystokenc.f90 revision 51 by guez, Tue Sep 20 09:14:34 2011 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 histwrite_m  
       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, intent(in):: 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, intent(in):: 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.  
   
       IF (iadvtr.eq.0) THEN  
         CALL initphysto('phystoke',  
      . rlon,rlat,dtime, dtime*istphy,dtime*istphy,nqmx,physid)  
       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)  
 c  
       i=itap  
       CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)  
       CALL histwrite(physid,"aire",i,zx_tmp_2d)  
   
       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)  
   
          CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfu, zx_tmp_3d)  
       CALL histwrite(physid,"mfu",itap,zx_tmp_3d)  
         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfd, zx_tmp_3d)  
       CALL histwrite(physid,"mfd",itap,zx_tmp_3d)  
         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_u, zx_tmp_3d)  
       CALL histwrite(physid,"en_u",itap,zx_tmp_3d)  
         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_u, zx_tmp_3d)  
       CALL histwrite(physid,"de_u",itap,zx_tmp_3d)  
         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_d, zx_tmp_3d)  
       CALL histwrite(physid,"en_d",itap,zx_tmp_3d)  
         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_d, zx_tmp_3d)        
       CALL histwrite(physid,"de_d",itap,zx_tmp_3d)  
         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, coefh, zx_tmp_3d)          
       CALL histwrite(physid,"coefh",itap,zx_tmp_3d)      
   
 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)  
 c  
       CALL gr_fi_ecrit(klev,klon,iim,jjm+1, entr_therm, zx_tmp_3d)  
       CALL histwrite(physid,"en_th",itap,zx_tmp_3d)  
 cccc  
        CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_impa,zx_tmp_3d)  
         CALL histwrite(physid,"frac_impa",itap,zx_tmp_3d)  
   
         CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_nucl,zx_tmp_3d)  
         CALL histwrite(physid,"frac_nucl",itap,zx_tmp_3d)  
   
         CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyu1,zx_tmp_2d)  
       CALL histwrite(physid,"pyu1",itap,zx_tmp_2d)  
           
         CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyv1,zx_tmp_2d)  
       CALL histwrite(physid,"pyv1",itap,zx_tmp_2d)  
           
         CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol1, zx_tmp_2d)  
       CALL histwrite(physid,"ftsol1",itap,zx_tmp_2d)  
          CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol2, zx_tmp_2d)  
       CALL histwrite(physid,"ftsol2",itap,zx_tmp_2d)  
           CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol3, zx_tmp_2d)  
       CALL histwrite(physid,"ftsol3",itap,zx_tmp_2d)  
          CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol4, zx_tmp_2d)  
       CALL histwrite(physid,"ftsol4",itap,zx_tmp_2d)  
   
         CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf1, zx_tmp_2d)  
       CALL histwrite(physid,"psrf1",itap,zx_tmp_2d)  
         CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf2, zx_tmp_2d)  
       CALL histwrite(physid,"psrf2",itap,zx_tmp_2d)  
         CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf3, zx_tmp_2d)  
       CALL histwrite(physid,"psrf3",itap,zx_tmp_2d)  
         CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf4, zx_tmp_2d)  
       CALL histwrite(physid,"psrf4",itap,zx_tmp_2d)  
   
       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, rlon, rlat, pt, pmfu, pmfd, pen_u, pde_u, &
8           pen_d, pde_d, pfm_therm, pentr_therm, pcoefh, yu1, yv1, ftsol, pctsrf, &
9           frac_impa, frac_nucl, pphis, paire, dtime, itap)
10    
11        ! From phylmd/phystokenc.F, version 1.2 2004/06/22 11:45:35
12        ! Author: Frédéric Hourdin
13        ! Objet: moniteur général des tendances traceurs                        
14    
15        USE histwrite_m, ONLY : histwrite
16        USE histcom, ONLY : histsync
17        USE dimens_m, ONLY : iim, jjm, nqmx
18        USE indicesol, ONLY : nbsrf
19        USE dimphy, ONLY : klev, klon
20        USE tracstoke, ONLY : istphy
21    
22        ! Arguments:                                                            
23    
24        !   EN ENTREE:                                                          
25    
26        !   divers:                                                            
27    
28        REAL, INTENT (IN) :: pdtphys ! pas d'integration pour la physique (seconde)
29        INTEGER, INTENT (IN) :: itap
30    
31        !   convection:                                                        
32    
33        REAL pmfu(klon, klev) ! flux de masse dans le panache montant
34        REAL pmfd(klon, klev) ! flux de masse dans le panache descendant
35        REAL pen_u(klon, klev) ! flux entraine dans le panache montant
36        REAL pde_u(klon, klev) ! flux detraine dans le panache montant
37        REAL pen_d(klon, klev) ! flux entraine dans le panache descendant
38        REAL pde_d(klon, klev) ! flux detraine dans le panache descendant
39        REAL, intent(in):: pt(klon, klev)
40    
41        REAL, INTENT (IN) :: rlon(klon), rlat(klon)
42        REAL, INTENT (IN) :: dtime
43    
44        !   Les Thermiques
45        REAL pfm_therm(klon, klev+1)
46        REAL pentr_therm(klon, klev)
47    
48        !   Couche limite:                                                      
49    
50        REAL yv1(klon)
51        REAL yu1(klon), paire(klon)
52        REAL, INTENT(IN):: pphis(klon)
53        REAL pcoefh(klon, klev) ! coeff melange Couche limite
54    
55        ! Arguments necessaires pour les sources et puits de traceur            
56    
57        REAL ftsol(klon, nbsrf) ! Temperature du sol (surf)(Kelvin)
58        REAL pctsrf(klon, nbsrf) ! Pourcentage de sol f(nature du sol)
59    
60        !   Lessivage:                                                          
61    
62        REAL frac_impa(klon, klev)
63        REAL frac_nucl(klon, klev)
64    
65        ! Variables local to the procedure:
66    
67        real t(klon, klev)
68        INTEGER, SAVE:: physid
69        REAL zx_tmp_3d(iim, jjm+1, klev), zx_tmp_2d(iim, jjm+1)
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 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, irec
95        REAL zmin, zmax
96        LOGICAL ok_sync
97    
98        SAVE t, mfu, mfd, en_u, de_u, en_d, de_d, coefh, dtcum
99        SAVE fm_therm, entr_therm
100        SAVE iadvtr, irec
101        SAVE pyu1, pyv1, pftsol, ppsrf
102    
103        DATA iadvtr, irec/0, 1/
104    
105        !------------------------------------------------------
106    
107        !   Couche limite:                                                      
108    
109        ok_sync = .TRUE.
110    
111        IF (iadvtr==0) THEN
112           CALL initphysto('phystoke', rlon, rlat, dtime, dtime*istphy, &
113                dtime*istphy, nqmx, physid)
114        END IF
115    
116        i = itap
117        CALL gr_fi_ecrit(1, klon, iim, jjm+1, pphis, zx_tmp_2d)
118        CALL histwrite(physid, 'phis', i, zx_tmp_2d)
119    
120        i = itap
121        CALL gr_fi_ecrit(1, klon, iim, jjm+1, paire, zx_tmp_2d)
122        CALL histwrite(physid, 'aire', i, zx_tmp_2d)
123    
124        iadvtr = iadvtr + 1
125    
126        IF (mod(iadvtr, istphy)==1 .OR. istphy==1) THEN
127           PRINT *, 'reinitialisation des champs cumules a iadvtr=', iadvtr
128           DO k = 1, klev
129              DO i = 1, klon
130                 mfu(i, k) = 0.
131                 mfd(i, k) = 0.
132                 en_u(i, k) = 0.
133                 de_u(i, k) = 0.
134                 en_d(i, k) = 0.
135                 de_d(i, k) = 0.
136                 coefh(i, k) = 0.
137                 t(i, k) = 0.
138                 fm_therm(i, k) = 0.
139                 entr_therm(i, k) = 0.
140              END DO
141           END DO
142           DO i = 1, klon
143              pyv1(i) = 0.
144              pyu1(i) = 0.
145           END DO
146           DO k = 1, nbsrf
147              DO i = 1, klon
148                 pftsol(i, k) = 0.
149                 ppsrf(i, k) = 0.
150              END DO
151           END DO
152    
153           dtcum = 0.
154        END IF
155    
156        DO k = 1, klev
157           DO i = 1, klon
158              mfu(i, k) = mfu(i, k) + pmfu(i, k)*pdtphys
159              mfd(i, k) = mfd(i, k) + pmfd(i, k)*pdtphys
160              en_u(i, k) = en_u(i, k) + pen_u(i, k)*pdtphys
161              de_u(i, k) = de_u(i, k) + pde_u(i, k)*pdtphys
162              en_d(i, k) = en_d(i, k) + pen_d(i, k)*pdtphys
163              de_d(i, k) = de_d(i, k) + pde_d(i, k)*pdtphys
164              coefh(i, k) = coefh(i, k) + pcoefh(i, k)*pdtphys
165              t(i, k) = t(i, k) + pt(i, k)*pdtphys
166              fm_therm(i, k) = fm_therm(i, k) + pfm_therm(i, k)*pdtphys
167              entr_therm(i, k) = entr_therm(i, k) + pentr_therm(i, k)*pdtphys
168           END DO
169        END DO
170        DO i = 1, klon
171           pyv1(i) = pyv1(i) + yv1(i)*pdtphys
172           pyu1(i) = pyu1(i) + yu1(i)*pdtphys
173        END DO
174        DO k = 1, nbsrf
175           DO i = 1, klon
176              pftsol(i, k) = pftsol(i, k) + ftsol(i, k)*pdtphys
177              ppsrf(i, k) = ppsrf(i, k) + pctsrf(i, k)*pdtphys
178           END DO
179        END DO
180    
181        dtcum = dtcum + pdtphys
182    
183        IF (mod(iadvtr, istphy)==0) THEN
184           !   normalisation par le temps cumule                                  
185           DO k = 1, klev
186              DO i = 1, klon
187                 mfu(i, k) = mfu(i, k)/dtcum
188                 mfd(i, k) = mfd(i, k)/dtcum
189                 en_u(i, k) = en_u(i, k)/dtcum
190                 de_u(i, k) = de_u(i, k)/dtcum
191                 en_d(i, k) = en_d(i, k)/dtcum
192                 de_d(i, k) = de_d(i, k)/dtcum
193                 coefh(i, k) = coefh(i, k)/dtcum
194                 ! Unitel a enlever
195                 t(i, k) = t(i, k)/dtcum
196                 fm_therm(i, k) = fm_therm(i, k)/dtcum
197                 entr_therm(i, k) = entr_therm(i, k)/dtcum
198              END DO
199           END DO
200           DO i = 1, klon
201              pyv1(i) = pyv1(i)/dtcum
202              pyu1(i) = pyu1(i)/dtcum
203           END DO
204           DO k = 1, nbsrf
205              DO i = 1, klon
206                 pftsol(i, k) = pftsol(i, k)/dtcum
207                 pftsol1(i) = pftsol(i, 1)
208                 pftsol2(i) = pftsol(i, 2)
209                 pftsol3(i) = pftsol(i, 3)
210                 pftsol4(i) = pftsol(i, 4)
211    
212                 ppsrf(i, k) = ppsrf(i, k)/dtcum
213                 ppsrf1(i) = ppsrf(i, 1)
214                 ppsrf2(i) = ppsrf(i, 2)
215                 ppsrf3(i) = ppsrf(i, 3)
216                 ppsrf4(i) = ppsrf(i, 4)
217    
218              END DO
219           END DO
220    
221           !   ecriture des champs                                                
222    
223           irec = irec + 1
224    
225           !cccc                                                                  
226           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, t, zx_tmp_3d)
227           CALL histwrite(physid, 't', itap, zx_tmp_3d)
228    
229           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, mfu, zx_tmp_3d)
230           CALL histwrite(physid, 'mfu', itap, zx_tmp_3d)
231           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, mfd, zx_tmp_3d)
232           CALL histwrite(physid, 'mfd', itap, zx_tmp_3d)
233           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, en_u, zx_tmp_3d)
234           CALL histwrite(physid, 'en_u', itap, zx_tmp_3d)
235           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, de_u, zx_tmp_3d)
236           CALL histwrite(physid, 'de_u', itap, zx_tmp_3d)
237           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, en_d, zx_tmp_3d)
238           CALL histwrite(physid, 'en_d', itap, zx_tmp_3d)
239           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, de_d, zx_tmp_3d)
240           CALL histwrite(physid, 'de_d', itap, zx_tmp_3d)
241           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, coefh, zx_tmp_3d)
242           CALL histwrite(physid, 'coefh', itap, zx_tmp_3d)
243    
244           ! ajou...                                                              
245           DO k = 1, klev
246              DO i = 1, klon
247                 fm_therm1(i, k) = fm_therm(i, k)
248              END DO
249           END DO
250    
251           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, fm_therm1, zx_tmp_3d)
252           CALL histwrite(physid, 'fm_th', itap, zx_tmp_3d)
253    
254           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, entr_therm, zx_tmp_3d)
255           CALL histwrite(physid, 'en_th', itap, zx_tmp_3d)
256           !ccc                                                                    
257           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, frac_impa, zx_tmp_3d)
258           CALL histwrite(physid, 'frac_impa', itap, zx_tmp_3d)
259    
260           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, frac_nucl, zx_tmp_3d)
261           CALL histwrite(physid, 'frac_nucl', itap, zx_tmp_3d)
262    
263           CALL gr_fi_ecrit(1, klon, iim, jjm+1, pyu1, zx_tmp_2d)
264           CALL histwrite(physid, 'pyu1', itap, zx_tmp_2d)
265    
266           CALL gr_fi_ecrit(1, klon, iim, jjm+1, pyv1, zx_tmp_2d)
267           CALL histwrite(physid, 'pyv1', itap, zx_tmp_2d)
268    
269           CALL gr_fi_ecrit(1, klon, iim, jjm+1, pftsol1, zx_tmp_2d)
270           CALL histwrite(physid, 'ftsol1', itap, zx_tmp_2d)
271           CALL gr_fi_ecrit(1, klon, iim, jjm+1, pftsol2, zx_tmp_2d)
272           CALL histwrite(physid, 'ftsol2', itap, zx_tmp_2d)
273           CALL gr_fi_ecrit(1, klon, iim, jjm+1, pftsol3, zx_tmp_2d)
274           CALL histwrite(physid, 'ftsol3', itap, zx_tmp_2d)
275           CALL gr_fi_ecrit(1, klon, iim, jjm+1, pftsol4, zx_tmp_2d)
276           CALL histwrite(physid, 'ftsol4', itap, zx_tmp_2d)
277    
278           CALL gr_fi_ecrit(1, klon, iim, jjm+1, ppsrf1, zx_tmp_2d)
279           CALL histwrite(physid, 'psrf1', itap, zx_tmp_2d)
280           CALL gr_fi_ecrit(1, klon, iim, jjm+1, ppsrf2, zx_tmp_2d)
281           CALL histwrite(physid, 'psrf2', itap, zx_tmp_2d)
282           CALL gr_fi_ecrit(1, klon, iim, jjm+1, ppsrf3, zx_tmp_2d)
283           CALL histwrite(physid, 'psrf3', itap, zx_tmp_2d)
284           CALL gr_fi_ecrit(1, klon, iim, jjm+1, ppsrf4, zx_tmp_2d)
285           CALL histwrite(physid, 'psrf4', itap, zx_tmp_2d)
286    
287           IF (ok_sync) CALL histsync(physid)
288           !     if (ok_sync) call histsync                                        
289    
290    
291           !AA Test sur la valeur des coefficients de lessivage                    
292    
293           zmin = 1E33
294           zmax = -1E33
295           DO k = 1, klev
296              DO i = 1, klon
297                 zmax = max(zmax, frac_nucl(i, k))
298                 zmin = min(zmin, frac_nucl(i, k))
299              END DO
300           END DO
301           PRINT *, '------ coefs de lessivage (min et max) --------'
302           PRINT *, 'facteur de nucleation ', zmin, zmax
303           zmin = 1E33
304           zmax = -1E33
305           DO k = 1, klev
306              DO i = 1, klon
307                 zmax = max(zmax, frac_impa(i, k))
308                 zmin = min(zmin, frac_impa(i, k))
309              END DO
310           END DO
311           PRINT *, 'facteur d impaction ', zmin, zmax
312    
313        END IF
314    
315      END SUBROUTINE phystokenc
316    
317    end module phystokenc_m
Legend:
Removed from v.31  
changed lines
  Added in v.51
  ViewVC Help
Powered by ViewVC 1.1.21