/[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 12 by guez, Mon Jul 21 16:05:07 2008 UTC trunk/libf/phylmd/phystokenc.f90 revision 62 by guez, Thu Jul 26 14:37:37 2012 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 : moniteur général des tendances traceurs                        
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        ! 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, INTENT (IN):: 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, 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        REAL zmin, zmax
96        LOGICAL ok_sync
97    
98        SAVE t, mfd, en_u, de_u, en_d, de_d, coefh, dtcum
99        SAVE fm_therm, entr_therm
100        SAVE pyu1, pyv1, pftsol, ppsrf
101    
102        !------------------------------------------------------
103    
104        !   Couche limite:                                                      
105    
106        ok_sync = .TRUE.
107    
108        IF (iadvtr==0) THEN
109           CALL initphysto('phystoke', rlon, rlat, dtime, dtime*istphy, &
110                dtime*istphy, nqmx, physid)
111        END IF
112    
113        i = itap
114        CALL gr_fi_ecrit(1, klon, iim, jjm+1, pphis, zx_tmp_2d)
115        CALL histwrite(physid, 'phis', i, zx_tmp_2d)
116    
117        i = itap
118        CALL gr_fi_ecrit(1, klon, iim, jjm+1, paire, zx_tmp_2d)
119        CALL histwrite(physid, 'aire', i, zx_tmp_2d)
120    
121        iadvtr = iadvtr + 1
122    
123        IF (mod(iadvtr, istphy) == 1 .OR. istphy == 1) THEN
124           PRINT *, 'reinitialisation des champs cumules a iadvtr =', iadvtr
125           DO k = 1, klev
126              DO i = 1, klon
127                 mfu(i, k) = 0.
128                 mfd(i, k) = 0.
129                 en_u(i, k) = 0.
130                 de_u(i, k) = 0.
131                 en_d(i, k) = 0.
132                 de_d(i, k) = 0.
133                 coefh(i, k) = 0.
134                 t(i, k) = 0.
135                 fm_therm(i, k) = 0.
136                 entr_therm(i, k) = 0.
137              END DO
138           END DO
139           DO i = 1, klon
140              pyv1(i) = 0.
141              pyu1(i) = 0.
142           END DO
143           DO k = 1, nbsrf
144              DO i = 1, klon
145                 pftsol(i, k) = 0.
146                 ppsrf(i, k) = 0.
147              END DO
148           END DO
149    
150           dtcum = 0.
151        END IF
152    
153        DO k = 1, klev
154           DO i = 1, klon
155              mfu(i, k) = mfu(i, k) + pmfu(i, k)*pdtphys
156              mfd(i, k) = mfd(i, k) + pmfd(i, k)*pdtphys
157              en_u(i, k) = en_u(i, k) + pen_u(i, k)*pdtphys
158              de_u(i, k) = de_u(i, k) + pde_u(i, k)*pdtphys
159              en_d(i, k) = en_d(i, k) + pen_d(i, k)*pdtphys
160              de_d(i, k) = de_d(i, k) + pde_d(i, k)*pdtphys
161              coefh(i, k) = coefh(i, k) + pcoefh(i, k)*pdtphys
162              t(i, k) = t(i, k) + pt(i, k)*pdtphys
163              fm_therm(i, k) = fm_therm(i, k) + pfm_therm(i, k)*pdtphys
164              entr_therm(i, k) = entr_therm(i, k) + pentr_therm(i, k)*pdtphys
165           END DO
166        END DO
167        DO i = 1, klon
168           pyv1(i) = pyv1(i) + yv1(i)*pdtphys
169           pyu1(i) = pyu1(i) + yu1(i)*pdtphys
170        END DO
171        DO k = 1, nbsrf
172           DO i = 1, klon
173              pftsol(i, k) = pftsol(i, k) + ftsol(i, k)*pdtphys
174              ppsrf(i, k) = ppsrf(i, k) + pctsrf(i, k)*pdtphys
175           END DO
176        END DO
177    
178        dtcum = dtcum + pdtphys
179    
180        IF (mod(iadvtr, istphy)==0) THEN
181           ! normalisation par le temps cumule                                  
182           DO k = 1, klev
183              DO i = 1, klon
184                 mfu(i, k) = mfu(i, k)/dtcum
185                 mfd(i, k) = mfd(i, k)/dtcum
186                 en_u(i, k) = en_u(i, k)/dtcum
187                 de_u(i, k) = de_u(i, k)/dtcum
188                 en_d(i, k) = en_d(i, k)/dtcum
189                 de_d(i, k) = de_d(i, k)/dtcum
190                 coefh(i, k) = coefh(i, k)/dtcum
191                 ! Unitel a enlever
192                 t(i, k) = t(i, k)/dtcum
193                 fm_therm(i, k) = fm_therm(i, k)/dtcum
194                 entr_therm(i, k) = entr_therm(i, k)/dtcum
195              END DO
196           END DO
197           DO i = 1, klon
198              pyv1(i) = pyv1(i)/dtcum
199              pyu1(i) = pyu1(i)/dtcum
200           END DO
201           DO k = 1, nbsrf
202              DO i = 1, klon
203                 pftsol(i, k) = pftsol(i, k)/dtcum
204                 pftsol1(i) = pftsol(i, 1)
205                 pftsol2(i) = pftsol(i, 2)
206                 pftsol3(i) = pftsol(i, 3)
207                 pftsol4(i) = pftsol(i, 4)
208    
209                 ppsrf(i, k) = ppsrf(i, k)/dtcum
210                 ppsrf1(i) = ppsrf(i, 1)
211                 ppsrf2(i) = ppsrf(i, 2)
212                 ppsrf3(i) = ppsrf(i, 3)
213                 ppsrf4(i) = ppsrf(i, 4)
214              END DO
215           END DO
216    
217           !   ecriture des champs                                                
218    
219           irec = irec + 1
220    
221           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, t, zx_tmp_3d)
222           CALL histwrite(physid, 't', itap, zx_tmp_3d)
223    
224           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, mfu, zx_tmp_3d)
225           CALL histwrite(physid, 'mfu', itap, zx_tmp_3d)
226           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, mfd, zx_tmp_3d)
227           CALL histwrite(physid, 'mfd', itap, zx_tmp_3d)
228           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, en_u, zx_tmp_3d)
229           CALL histwrite(physid, 'en_u', itap, zx_tmp_3d)
230           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, de_u, zx_tmp_3d)
231           CALL histwrite(physid, 'de_u', itap, zx_tmp_3d)
232           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, en_d, zx_tmp_3d)
233           CALL histwrite(physid, 'en_d', itap, zx_tmp_3d)
234           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, de_d, zx_tmp_3d)
235           CALL histwrite(physid, 'de_d', itap, zx_tmp_3d)
236           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, coefh, zx_tmp_3d)
237           CALL histwrite(physid, 'coefh', itap, zx_tmp_3d)
238    
239           DO k = 1, klev
240              DO i = 1, klon
241                 fm_therm1(i, k) = fm_therm(i, k)
242              END DO
243           END DO
244    
245           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, fm_therm1, zx_tmp_3d)
246           CALL histwrite(physid, 'fm_th', itap, zx_tmp_3d)
247    
248           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, entr_therm, zx_tmp_3d)
249           CALL histwrite(physid, 'en_th', itap, zx_tmp_3d)
250           !ccc                                                                    
251           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, frac_impa, zx_tmp_3d)
252           CALL histwrite(physid, 'frac_impa', itap, zx_tmp_3d)
253    
254           CALL gr_fi_ecrit(klev, klon, iim, jjm+1, frac_nucl, zx_tmp_3d)
255           CALL histwrite(physid, 'frac_nucl', itap, zx_tmp_3d)
256    
257           CALL gr_fi_ecrit(1, klon, iim, jjm+1, pyu1, zx_tmp_2d)
258           CALL histwrite(physid, 'pyu1', itap, zx_tmp_2d)
259    
260           CALL gr_fi_ecrit(1, klon, iim, jjm+1, pyv1, zx_tmp_2d)
261           CALL histwrite(physid, 'pyv1', itap, zx_tmp_2d)
262    
263           CALL gr_fi_ecrit(1, klon, iim, jjm+1, pftsol1, zx_tmp_2d)
264           CALL histwrite(physid, 'ftsol1', itap, zx_tmp_2d)
265           CALL gr_fi_ecrit(1, klon, iim, jjm+1, pftsol2, zx_tmp_2d)
266           CALL histwrite(physid, 'ftsol2', itap, zx_tmp_2d)
267           CALL gr_fi_ecrit(1, klon, iim, jjm+1, pftsol3, zx_tmp_2d)
268           CALL histwrite(physid, 'ftsol3', itap, zx_tmp_2d)
269           CALL gr_fi_ecrit(1, klon, iim, jjm+1, pftsol4, zx_tmp_2d)
270           CALL histwrite(physid, 'ftsol4', itap, zx_tmp_2d)
271    
272           CALL gr_fi_ecrit(1, klon, iim, jjm+1, ppsrf1, zx_tmp_2d)
273           CALL histwrite(physid, 'psrf1', itap, zx_tmp_2d)
274           CALL gr_fi_ecrit(1, klon, iim, jjm+1, ppsrf2, zx_tmp_2d)
275           CALL histwrite(physid, 'psrf2', itap, zx_tmp_2d)
276           CALL gr_fi_ecrit(1, klon, iim, jjm+1, ppsrf3, zx_tmp_2d)
277           CALL histwrite(physid, 'psrf3', itap, zx_tmp_2d)
278           CALL gr_fi_ecrit(1, klon, iim, jjm+1, ppsrf4, zx_tmp_2d)
279           CALL histwrite(physid, 'psrf4', itap, zx_tmp_2d)
280    
281           IF (ok_sync) CALL histsync(physid)
282    
283           !AA Test sur la valeur des coefficients de lessivage                    
284    
285           zmin = 1E33
286           zmax = -1E33
287           DO k = 1, klev
288              DO i = 1, klon
289                 zmax = max(zmax, frac_nucl(i, k))
290                 zmin = min(zmin, frac_nucl(i, k))
291              END DO
292           END DO
293           PRINT *, 'coefs de lessivage (min et max)'
294           PRINT *, 'facteur de nucleation ', zmin, zmax
295           zmin = 1E33
296           zmax = -1E33
297           DO k = 1, klev
298              DO i = 1, klon
299                 zmax = max(zmax, frac_impa(i, k))
300                 zmin = min(zmin, frac_impa(i, k))
301              END DO
302           END DO
303           PRINT *, 'facteur d impaction ', zmin, zmax
304        END IF
305    
306      END SUBROUTINE phystokenc
307    
308    end module phystokenc_m
Legend:
Removed from v.12  
changed lines
  Added in v.62
  ViewVC Help
Powered by ViewVC 1.1.21