/[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 190 by guez, Thu Apr 14 15:15:56 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, itap)
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 tracstoke, ONLY: istphy
23    
24        REAL, INTENT (IN):: pdtphys ! pas d'integration pour la physique (seconde)
25        REAL, intent(in):: pt(klon, klev)
26    
27        ! convection:
28    
29        REAL, INTENT (IN):: pmfu(klon, klev) ! flux de masse dans le panache montant
30    
31        REAL, intent(in):: pmfd(klon, klev)
32        ! flux de masse dans le panache descendant
33    
34        REAL, intent(in):: pen_u(klon, klev) ! flux entraine dans le panache montant
35        REAL, intent(in):: pde_u(klon, klev) ! flux detraine dans le panache montant
36    
37        REAL, intent(in):: pen_d(klon, klev)
38        ! flux entraine dans le panache descendant
39    
40        REAL, intent(in):: pde_d(klon, klev)
41        ! flux detraine dans le panache descendant
42    
43        ! Les Thermiques
44        REAL pfm_therm(klon, klev+1)
45        REAL pentr_therm(klon, klev)
46    
47        ! Couche limite:
48    
49        REAL pcoefh(klon, klev) ! coeff melange Couche limite
50        REAL yu1(klon)
51        REAL yv1(klon)
52    
53        ! Arguments necessaires pour les sources et puits de traceur
54    
55        REAL ftsol(klon, nbsrf) ! Temperature du sol (surf)(Kelvin)
56        REAL pctsrf(klon, nbsrf) ! Pourcentage de sol f(nature du sol)
57    
58        ! Lessivage:
59    
60        REAL frac_impa(klon, klev)
61        REAL frac_nucl(klon, klev)
62    
63        REAL, INTENT(IN):: pphis(klon)
64        real paire(klon)
65        REAL, INTENT (IN):: dtime
66        INTEGER, INTENT (IN):: itap
67    
68        ! Variables local to the procedure:
69    
70        real t(klon, klev)
71        INTEGER, SAVE:: physid
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) CALL initphysto('phystoke', dtime, dtime*istphy, dtime*istphy, physid)
111    
112        i = itap
113        CALL histwrite(physid, 'phis', i, gr_phy_write(pphis))
114        i = itap
115        CALL histwrite(physid, 'aire', i, gr_phy_write(paire))
116        iadvtr = iadvtr + 1
117    
118        IF (mod(iadvtr, istphy) == 1 .OR. istphy == 1) THEN
119           PRINT *, 'reinitialisation des champs cumules a iadvtr =', iadvtr
120           DO k = 1, klev
121              DO i = 1, klon
122                 mfu(i, k) = 0.
123                 mfd(i, k) = 0.
124                 en_u(i, k) = 0.
125                 de_u(i, k) = 0.
126                 en_d(i, k) = 0.
127                 de_d(i, k) = 0.
128                 coefh(i, k) = 0.
129                 t(i, k) = 0.
130                 fm_therm(i, k) = 0.
131                 entr_therm(i, k) = 0.
132              END DO
133           END DO
134           DO i = 1, klon
135              pyv1(i) = 0.
136              pyu1(i) = 0.
137           END DO
138           DO k = 1, nbsrf
139              DO i = 1, klon
140                 pftsol(i, k) = 0.
141                 ppsrf(i, k) = 0.
142              END DO
143           END DO
144    
145           dtcum = 0.
146        END IF
147    
148        DO k = 1, klev
149           DO i = 1, klon
150              mfu(i, k) = mfu(i, k) + pmfu(i, k)*pdtphys
151              mfd(i, k) = mfd(i, k) + pmfd(i, k)*pdtphys
152              en_u(i, k) = en_u(i, k) + pen_u(i, k)*pdtphys
153              de_u(i, k) = de_u(i, k) + pde_u(i, k)*pdtphys
154              en_d(i, k) = en_d(i, k) + pen_d(i, k)*pdtphys
155              de_d(i, k) = de_d(i, k) + pde_d(i, k)*pdtphys
156              coefh(i, k) = coefh(i, k) + pcoefh(i, k)*pdtphys
157              t(i, k) = t(i, k) + pt(i, k)*pdtphys
158              fm_therm(i, k) = fm_therm(i, k) + pfm_therm(i, k)*pdtphys
159              entr_therm(i, k) = entr_therm(i, k) + pentr_therm(i, k)*pdtphys
160           END DO
161        END DO
162        DO i = 1, klon
163           pyv1(i) = pyv1(i) + yv1(i)*pdtphys
164           pyu1(i) = pyu1(i) + yu1(i)*pdtphys
165        END DO
166        DO k = 1, nbsrf
167           DO i = 1, klon
168              pftsol(i, k) = pftsol(i, k) + ftsol(i, k)*pdtphys
169              ppsrf(i, k) = ppsrf(i, k) + pctsrf(i, k)*pdtphys
170           END DO
171        END DO
172    
173        dtcum = dtcum + pdtphys
174    
175        IF (mod(iadvtr, istphy) == 0) THEN
176           ! normalisation par le temps cumule
177           DO k = 1, klev
178              DO i = 1, klon
179                 mfu(i, k) = mfu(i, k)/dtcum
180                 mfd(i, k) = mfd(i, k)/dtcum
181                 en_u(i, k) = en_u(i, k)/dtcum
182                 de_u(i, k) = de_u(i, k)/dtcum
183                 en_d(i, k) = en_d(i, k)/dtcum
184                 de_d(i, k) = de_d(i, k)/dtcum
185                 coefh(i, k) = coefh(i, k)/dtcum
186                 ! Unitel a enlever
187                 t(i, k) = t(i, k)/dtcum
188                 fm_therm(i, k) = fm_therm(i, k)/dtcum
189                 entr_therm(i, k) = entr_therm(i, k)/dtcum
190              END DO
191           END DO
192           DO i = 1, klon
193              pyv1(i) = pyv1(i)/dtcum
194              pyu1(i) = pyu1(i)/dtcum
195           END DO
196           DO k = 1, nbsrf
197              DO i = 1, klon
198                 pftsol(i, k) = pftsol(i, k)/dtcum
199                 pftsol1(i) = pftsol(i, 1)
200                 pftsol2(i) = pftsol(i, 2)
201                 pftsol3(i) = pftsol(i, 3)
202                 pftsol4(i) = pftsol(i, 4)
203    
204                 ppsrf(i, k) = ppsrf(i, k)/dtcum
205                 ppsrf1(i) = ppsrf(i, 1)
206                 ppsrf2(i) = ppsrf(i, 2)
207                 ppsrf3(i) = ppsrf(i, 3)
208                 ppsrf4(i) = ppsrf(i, 4)
209              END DO
210           END DO
211    
212           ! ecriture des champs
213    
214           irec = irec + 1
215    
216           CALL histwrite(physid, 't', itap, gr_phy_write(t))
217           CALL histwrite(physid, 'mfu', itap, gr_phy_write(mfu))
218           CALL histwrite(physid, 'mfd', itap, gr_phy_write(mfd))
219           CALL histwrite(physid, 'en_u', itap, gr_phy_write(en_u))
220           CALL histwrite(physid, 'de_u', itap, gr_phy_write(de_u))
221           CALL histwrite(physid, 'en_d', itap, gr_phy_write(en_d))
222           CALL histwrite(physid, 'de_d', itap, gr_phy_write(de_d))
223           CALL histwrite(physid, 'coefh', itap, gr_phy_write(coefh))
224           DO k = 1, klev
225              DO i = 1, klon
226                 fm_therm1(i, k) = fm_therm(i, k)
227              END DO
228           END DO
229    
230           CALL histwrite(physid, 'fm_th', itap, gr_phy_write(fm_therm1))
231           CALL histwrite(physid, 'en_th', itap, gr_phy_write(entr_therm))
232           !ccc
233           CALL histwrite(physid, 'frac_impa', itap, gr_phy_write(frac_impa))
234           CALL histwrite(physid, 'frac_nucl', itap, gr_phy_write(frac_nucl))
235           CALL histwrite(physid, 'pyu1', itap, gr_phy_write(pyu1))
236           CALL histwrite(physid, 'pyv1', itap, gr_phy_write(pyv1))
237           CALL histwrite(physid, 'ftsol1', itap, gr_phy_write(pftsol1))
238           CALL histwrite(physid, 'ftsol2', itap, gr_phy_write(pftsol2))
239           CALL histwrite(physid, 'ftsol3', itap, gr_phy_write(pftsol3))
240           CALL histwrite(physid, 'ftsol4', itap, gr_phy_write(pftsol4))
241           CALL histwrite(physid, 'psrf1', itap, gr_phy_write(ppsrf1))
242           CALL histwrite(physid, 'psrf2', itap, gr_phy_write(ppsrf2))
243           CALL histwrite(physid, 'psrf3', itap, gr_phy_write(ppsrf3))
244           CALL histwrite(physid, 'psrf4', itap, gr_phy_write(ppsrf4))
245           IF (ok_sync) CALL histsync(physid)
246    
247           ! Test sur la valeur des coefficients de lessivage
248    
249           zmin = 1E33
250           zmax = -1E33
251           DO k = 1, klev
252              DO i = 1, klon
253                 zmax = max(zmax, frac_nucl(i, k))
254                 zmin = min(zmin, frac_nucl(i, k))
255              END DO
256           END DO
257           PRINT *, 'coefs de lessivage (min et max)'
258           PRINT *, 'facteur de nucleation ', zmin, zmax
259           zmin = 1E33
260           zmax = -1E33
261           DO k = 1, klev
262              DO i = 1, klon
263                 zmax = max(zmax, frac_impa(i, k))
264                 zmin = min(zmin, frac_impa(i, k))
265              END DO
266           END DO
267           PRINT *, 'facteur d impaction ', zmin, zmax
268        END IF
269    
270      END SUBROUTINE phystokenc
271    
272    end module phystokenc_m
Legend:
Removed from v.7  
changed lines
  Added in v.190
  ViewVC Help
Powered by ViewVC 1.1.21