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